maxent-learner-hw (empty) → 0.1.0
raw patch · 15 files changed
+2733/−0 lines, 15 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, csv, deepseq, file-embed, maxent-learner-hw, mtl, optparse-applicative, parallel, random, text, vector
Files
- LICENSE +339/−0
- README.md +68/−0
- Setup.hs +2/−0
- app/Main.hs +209/−0
- app/ft-ipa.csv +25/−0
- ffisrc/packeddfa.c +235/−0
- maxent-learner-hw.cabal +60/−0
- src/Text/PhonotacticLearner.hs +139/−0
- src/Text/PhonotacticLearner/DFST.hs +624/−0
- src/Text/PhonotacticLearner/MaxentGrammar.hs +220/−0
- src/Text/PhonotacticLearner/PhonotacticConstraints.hs +225/−0
- src/Text/PhonotacticLearner/PhonotacticConstraints/Generators.hs +144/−0
- src/Text/PhonotacticLearner/Util/ConjugateGradient.hs +103/−0
- src/Text/PhonotacticLearner/Util/Probability.hs +128/−0
- src/Text/PhonotacticLearner/Util/Ring.hs +212/−0
+ LICENSE view
@@ -0,0 +1,339 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc., <http://fsf.org/>+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ {description}+ Copyright (C) {year} {fullname}++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ {signature of Ty Coon}, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ README.md view
@@ -0,0 +1,68 @@+# Maxent Phonotactic Learner++A tool for automatically inferring phonotactic grammars from a lexicon and using those grammars to generate random text, based on Hayes and Wilson's [A Maximum Entropy Model of Phonotactics and Phonotactic Learning](http://www.linguistics.ucla.edu/people/hayes/Phonotactics/Index.htm). This package provides functionality both as a Haskell library and as a command line tool.++To compile this package, run `stack build` in the root of this repository. Run `stack haddock` to build the library documentation. The library may be useful if you wish to use a custom set of candidate constraints beyond the generators offered by the command line tool.++## Command line usage++The command line tool (`phono-learner-hw`) has two commands: `learn`, which infers grammars, and `gensalad`, which generates random text using those grammars. The learn command takes the name of a lexicon file as an argument and outputs a grammar (note this is quite slow). By default the candidates consist of single classes and bigrams, and several; mote constraint types can be added with options. The `gensalad` takes a grammar generated by `learn` and uses it to generate random text. Both commands can also take global options to output their final results to a file, to use a custom-defined feature table for the generation of natural classes, and to control how text is divided into segments.++The command line works as follows:++ phono-learner-hw COMMAND [-t|--featuretable CSVFILE] ([-c|--charsegs] | [-w|--wordsegs] | [--fierrosegs]) [-n|--samples ARG] [-o|--output OUTFILE]+++| Option | Description |+| --- | --- |+| -t, --featuretable *CSVFILE* | Use the features and segment list from a feature table in CSV format (a table for IPA is used by default). |+| -c, --charsegs | Use characters as segments (default). |+| -w, --wordsegs | Separate segments by spaces. |+| --fierosegs | Parse segments by repeatedly taking the longest possible match and use ' to break up unintended digraphs (used for Fiero orthography). |+| -n, --samples *N* | Number of samples to use for salad generation. |+| -o, --output *OUTFILE* | Record final output to OUTFILE as well as stdout. |++ hw-learner learn LEXICON [--thresholds THRESHOLDS] [-f|--freqs] [-e|--edges] [-3|--trigrams COREFEATURES] [-l|--longdistance SKIPFEATURES] [GLOBALOPTIONS]++| Option | Description |+| --- | --- |+| --thresholds *THRESHOLDS* | thresholds to use for candidate selection (default is `[0.01, 0.1, 0.2, 0.3]``). |+| -f,--freqs | Lexicon file contains word frequencies.+| -e,--edges | Allow constraints involving word boundaries.+| -3,--trigrams *COREFEATURES* | Allow trigram constraints where at least one class uses a single one of the following features (space separated in quotes). |+| -l,--longdistance SKIPFEATURES |Allow constraints with two classes separated by a run of characters possibly restricted to all having one of the following features.++ hw-learner gensalad GRAMMAR [GLOBALOPTIONS]++### Example usage++The following two command calculates a grammar using Hayes and Wilson's Shona test data using their selection of trigram restrictions and then generate random text using it.++++ phono-learner-hw learn ShonaLearningData.txt -f -e -3 "syllabic consonantal sonorant" -t ShonaFeatures.csv -w -o shonalongdistance.txt+ phono-learner-hw gensalad ShonaGrammar.txt -t ShonaFeatures.csv -w -o ShonaSalad.txt++++## Feature Table Format++To use a feature table other than the default IPA one, you may define it in CSV format (RFC 4180). The segment names are defined by the first row (they may be any strings as long as they are all distinct, i.e. no duplicate names) and the feature names are defined by the first column (they are not hard-coded). Data cells should contain `+`, `-`, or `0` for binary features and `+` or `0` for privative features (where we do not want a minus set that could form classes).++As a simple example, consider the following CSV file, defining three segments (a, n, and t), and two features (vowel and nasal).++ ,a,n,t+ vowel,+,-,-+ nasal,0,+,-++If a row contains a different number of cells (separated by commas) than the header line, is rejected as invalid and does not define a feature (and will not be dispayed in the formatted feature table). If the CSV which is entered has duplicate segment names, no segments, or no valid features, the entire table is rejected (indicated by a red border around the text area, green is normal) and the last valid table is used and displayed.++---++Copyright © 2016-2017 George Steel and Peter Jurgec.++This project is supported by the University of Toronto Advancing Teaching and Learning in Arts and Science (ATLAS) grant to Peter Jurgec.++This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.++This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE ParallelListComp, TemplateHaskell, ScopedTypeVariables #-}++{-+Command line interface for phonotactic learner+Copyright © 2016-2017 George Steel and Peter Jurgec++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.+-}++import Text.PhonotacticLearner+import Text.PhonotacticLearner.PhonotacticConstraints+import Text.PhonotacticLearner.PhonotacticConstraints.Generators+import Text.PhonotacticLearner.DFST+import Text.PhonotacticLearner.Util.Ring+import Text.PhonotacticLearner.Util.Probability+import Text.PhonotacticLearner.MaxentGrammar++import Options.Applicative+import Options.Applicative.Extra+import Control.Monad+import Control.Monad.State+import Control.Applicative+import qualified Data.Text as T+import qualified Data.Map.Lazy as M+import Data.Array.IArray+import Data.Maybe+import Data.FileEmbed+import Data.Char+import Text.Read+import Numeric+import Control.Arrow+import System.Exit+import Control.DeepSeq+import Control.Exception+import Control.Parallel.Strategies+import System.Random++data SegmentType = Chars | Words | Fiero deriving (Enum, Eq, Ord, Read, Show)++data Command = Learn {+ lexicon :: FilePath,+ thresholds :: [Double],+ hasFreqs :: Bool,+ useEdges :: Bool,+ useTrigrams :: Maybe String,+ useBroken :: Maybe String }+ | GenSalad {+ grammarfile :: FilePath }+ deriving Show++data ParsedArgs = ParsedArgs {+ cmd :: Command,+ ftable :: Maybe FilePath,+ segtype :: SegmentType,+ samplesize :: Int,+ outfile :: Maybe FilePath+} deriving (Show)+++parseOpts :: Parser ParsedArgs+parseOpts = ParsedArgs <$>+ hsubparser (command "learn" (info (Learn+ <$> strArgument (metavar "LEXICON")+ <*> option auto (long "thresholds" <> metavar "THRESHOLDS" <> value [0.01, 0.1, 0.2, 0.3] <> help "thresholds to use for candidate selection (default is [0.01, 0.1, 0.2, 0.3]).")+ <*> switch (long "freqs" <> short 'f' <> help "Lexicon file contains word frequencies.")+ <*> switch (long "edges" <> short 'e' <> help "Allow constraints involving word boundaries.")+ <*> optional (strOption $ long "trigrams" <> short '3' <> metavar "COREFEATURES" <>+ help "Allow trigram constraints where at least one class uses a single one of the following features (comma-separated).")+ <*> optional (strOption $ long "longdistance" <> short 'l' <> metavar "SKIPFEATURES" <>+ help "Allow constraints with two classes separated by a run of characters possibly restricted to all having one of the following features.")+ ) (fullDesc <> progDesc "Learn a phonotactic grammar from a given lexicon"))+ <> command "gensalad" (info (GenSalad <$> strArgument (metavar "GRAMMAR"))+ (fullDesc <> progDesc "Generate random words from an already-calculated grammar")))+ <*> optional (option str $ long "featuretable" <> short 't' <> metavar "CSVFILE" <>+ help "Use the features and segment list from a feature table in CSV format (a table for IPA is used by default).")+ <*> (flag' Chars (long "charsegs" <> short 'c' <> help "Use characters as segments (default).")+ <|> flag' Words (long "wordsegs" <> short 'w' <> help "Separate segments by spaces.")+ <|> flag' Fiero (long "fierosegs" <> help "Parse segments by repeatedly taking the longest possible match and use ' to break up unintended digraphs (used for Fiero orthography).")+ <|> pure Chars)+ <*> option auto (long "samples" <> short 'n' <> value 3000 <> help "Number of samples to use for salad generation.")+ <*> optional (strOption $ long "output" <> short 'o' <> metavar "OUTFILE" <> help "Record final output to OUTFILE as well as stdout.")++opts = info (helper <*> parseOpts) (fullDesc <> progDesc "Automatically infer phonotactic grammars from text and apply them as probability distributions.")+++++ipaft :: FeatureTable String+ipaft = fromJust (csvToFeatureTable id $(embedStringFile "./app/ft-ipa.csv"))++freqreader :: FeatureTable String -> (String -> [String]) -> String -> [([SegRef],Int)]+freqreader ft seg text = do+ line <- lines text+ let (wt@(_:_),wf') = break (== '\t') line+ [wf] <- return (words wf')+ Just n <- return $ readMaybe wf+ return (segsToRefs ft (seg wt), n)++nofreqreader :: FeatureTable String -> (String -> [String]) -> String -> [([SegRef],Int)]+nofreqreader ft seg text = do+ line <- lines text+ return (segsToRefs ft (seg line), 1)++prettyprintGrammar :: (Show clabel) => [clabel] -> Vec -> String+prettyprintGrammar grammar weights = (unlines . reverse) [showFFloat (Just 2) w " " ++ show c | c <- grammar | w <- coords weights]++isNonComment :: String -> Bool+isNonComment [] = False+isNonComment "\n" = False+isNonComment ('#':_) = False+isNonComment _ = True++restrictedClasses :: FeatureTable String -> String -> [(NaturalClass, SegSet SegRef)]+restrictedClasses ft arg = fmap ((id &&& classToSeglist ft) . NClass False) $ [] : do+ feat <- fmap T.pack (words arg)+ Just _ <- return $ M.lookup feat (featLookup ft)+ [[(FPlus, feat)], [(FMinus, feat)]]+++main = do+ args <- execParser opts+ putStrLn (show args)+ ft <- case ftable args of+ Just fname -> do+ ftcsv <- readFile fname+ case csvToFeatureTable id ftcsv of+ Just ft -> return ft+ Nothing -> die "Invalid feature table."+ Nothing -> do+ putStrLn "Using default IPA feature table."+ return ipaft++ case cmd args of+ Learn lexfile thresh lfreqs gedges gtris gbroken -> do+ let segmenter = case segtype args of+ Words -> words+ Chars -> fmap return+ Fiero -> segmentFiero (elems (segNames ft))+ cls = force $ classesByGenerality ft 3+ lexdata <- readFile lexfile+ let lexlist = (if lfreqs then freqreader else nofreqreader) ft segmenter lexdata+ when (null lexlist) (die "Invalid lexicon file")+ let wfs = sortLexicon lexlist+ singles = ugSingleClasses cls+ edges = if gedges then (ugEdgeClasses cls) else []+ doubles = ugBigrams cls+ edoubles = if gedges then (ugEdgeBigrams cls) else []+ triples = case gtris of Just rcls -> ugLimitedTrigrams cls (restrictedClasses ft rcls)+ Nothing -> []+ longdistance = case gbroken of Just rcls -> ugLongDistance cls (restrictedClasses ft rcls)+ Nothing -> []++ globs <- evaluate . force $ join [singles,edges,doubles,edoubles,triples,longdistance]+ putStrLn $ "Generated candidates with " ++ show (length cls) ++ " classes and " ++ show (length globs) ++ " globs, running DFA generation in parallel."+ let candidates = fmap (force . (id *** matchCounter)) globs `using` (parListChunk 1000 rdeepseq)++ (grammar, dfa, weights) <- generateGrammarIO (samplesize args) thresh candidates lexlist++ let output = "# Length Distribution:\n" ++ (show . assocs . lengthFreqs $ wfs) ++ "\n\n# Rules:\n" ++ prettyprintGrammar grammar weights++ putStrLn "\n\n\n\n"+ putStrLn output++ case outfile args of+ Just outf -> writeFile outf output+ Nothing -> return ()++++ GenSalad gfile -> do+ rawgrammar <- readFile gfile++ (fline:glines) <- evaluate $ filter isNonComment (lines rawgrammar)++ let lendist :: [(Int,Int)] = read fline+ grammar :: [(Double,ClassGlob)] = fmap ((read *** read) . break isSpace) glines+ lencdf = massToCdf (fmap (second fromIntegral) lendist)+ (weightlist,rulelist) = unzip (reverse grammar)+ weights = vec weightlist+ blankdfa = nildfa (srBounds ft)+ dfa = foldr (\g t -> force $ dfaProduct consMC (unpackDFA . cgMatchCounter ft $ g) (force t)) blankdfa rulelist+ unsegmenter = case segtype args of+ Words -> unwords+ Chars -> join+ Fiero -> joinFiero (elems (segNames ft))++ evaluate . force $ grammar+ evaluate . force $ dfa++ salad <- getStdRandom . runState $ sampleWordSalad (fmap (maxentProb weights) dfa) lencdf (samplesize args)++ let output = unlines . fmap (unsegmenter . refsToSegs ft) $ salad++ putStrLn "\n\n\n\n"+ putStrLn output++ case outfile args of+ Just outf -> writeFile outf output+ Nothing -> return ()++ return ()
+ app/ft-ipa.csv view
@@ -0,0 +1,25 @@+ ,t,d,s,z,ɬ,ɮ,θ,ð,ʃ,ʒ,c,ɟ,ç,ʝ,ʈ,ɖ,ʂ,ʐ,p,b,f,v,ɸ,β,k,g,x,ɣ,q,ɢ,χ,ʁ,ħ,ʕ,h,ɦ,ʔ,ʧ,ʤ,ʦ,ʣ,m,ɱ,n,ŋ,ɳ,ɲ,ɴ,l,ɭ,ʎ,ʟ,ⱱ,ɾ,ɽ,ʙ,r,ʀ,ʋ,ɹ,ɻ,j,w,ɥ,ɰ,i,y,ɪ,ʏ,ɨ,ʉ,ɯ,u,ʊ,e,ø,ɘ,ɵ,ɤ,o,ə,ɛ,œ,ɜ,ɞ,ʌ,ɔ,æ,ɐ,a,ɶ,ɑ,ɒ+consonantal, +,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,-,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,-,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+sonorant, -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++syllabic, -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++labial, -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,-,-,-,-,-,-,-,-,-,+,-,-,+,-,-,+,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++round, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-,-,-,-,-,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-,+,+,-,-,+,-,+,-,+,+,+,+,-,+,-,+,-,+,-,-,+,-,+,-,+,-,-,-,+,-,++coronal, +,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,-,-,+,-,+,-,-,+,+,-,-,-,+,+,-,+,-,-,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+anterior, +,+,+,+,+,+,+,+,-,-,-,-,-,-,-,-,-,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-,-,+,+,0,0,+,0,-,0,0,+,-,0,0,0,+,-,0,+,0,0,+,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0+distributed, -,-,-,-,-,-,-,-,+,+,+,+,+,+,-,-,-,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+,+,-,-,0,0,-,0,-,0,0,-,-,0,0,0,-,-,0,-,0,0,-,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0+dorsal, -,-,-,-,-,-,-,-,-,-,+,+,+,+,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,+,+,+,-,-,-,-,-,+,+,-,-,-,-,-,+,+,+,+,-,-,+,+,-,-,-,-,-,+,-,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++high, 0,0,0,0,0,0,0,0,0,0,+,+,+,+,0,0,0,0,0,0,0,0,0,0,+,+,+,+,-,-,-,-,0,0,0,0,0,+,+,0,0,0,0,0,+,-,+,-,0,0,+,+,0,0,0,0,0,-,0,0,0,+,+,+,+,+,+,+,+,+,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+low, 0,0,0,0,0,0,0,0,0,0,-,-,-,-,0,0,0,0,0,0,0,0,0,0,-,-,-,-,-,-,-,-,0,0,0,0,0,-,-,0,0,0,0,0,-,-,-,-,0,0,-,-,0,0,0,0,0,-,0,0,0,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,++back, 0,0,0,0,0,0,0,0,0,0,-,-,-,-,0,0,0,0,0,0,0,0,0,0,+,+,+,+,+,+,+,+,0,0,0,0,0,-,-,0,0,0,0,0,+,-,-,+,0,0,-,+,0,0,0,0,0,+,0,0,0,-,+,-,+,-,-,-,-,-,-,+,+,+,-,-,-,-,+,+,-,-,-,-,-,+,+,-,-,-,-,+,++front, +,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,-,-,+,-,+,+,-,+,+,+,+,-,-,-,-,-,-,-,-,-,+,-,+,-,+,+,+,+,-,-,-,-,-,+,+,-,-,-,-,-,+,+,-,-,-,-,+,-,+,+,-,-+tense, 0,0,0,0,0,0,0,0,0,0,-,-,-,-,0,0,0,0,0,0,0,0,0,0,-,-,-,-,-,-,-,-,0,0,0,0,0,-,-,0,0,0,0,0,-,-,-,-,0,0,-,-,0,0,0,0,0,-,0,0,0,-,-,-,-,+,+,-,-,+,+,+,+,-,+,+,+,+,+,+,-,-,-,-,-,-,-,+,+,-,+,-,-+pharyngeal, -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++ATR, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-,-,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+,+,-,-,+,+,-,+,-,+,+,+,+,+,+,0,-,-,-,-,-,-,-,+,-,-,-,-+voice, -,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,-,-,+,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++s.g., -,-,-,-,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+c.g., -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+continuant, -,-,+,+,+,+,+,+,+,+,-,-,+,+,-,-,+,+,-,-,+,+,+,+,-,-,+,+,-,-,+,+,+,+,+,+,-,0,0,0,0,-,-,-,-,-,-,-,+,+,+,+,-,-,-,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,+,++strident, -,-,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,-,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+lateral, -,-,-,-,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+del.rel., -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-+nasal, -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,+,+,+,+,+,+,+,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-
+ ffisrc/packeddfa.c view
@@ -0,0 +1,235 @@+/*+Copyright © 2016-2017 George Steel and Peter Jurgec++This program is free software: you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation, either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.+*/++#include <stdlib.h>+#include <stdint.h>+#include <string.h>+#include <math.h>++// Optimized functions to perfor calculations on packed DFAs for FFI use by the WeightedDFA module.+// All functions read from and write into memory buffers allocted by Haskell using Data.Vector.Storable++int64_t transducePackedShort(const int16_t ns, const int16_t q0,+ const int16_t* restrict tmat, const int16_t* restrict tcounts, const int16_t* restrict fcounts,+ const int16_t* restrict cstream, int32_t* restrict fstream) {+ int64_t tacc = 0;+ int32_t wacc = 0;++ int16_t st = q0;+ const int16_t* citer = cstream;+ const int32_t* fiter = fstream;++ while(1){+ const int16_t c = *citer;+ if (c == -2){+ return tacc;+ }+ if (c == -1){+ tacc += (wacc + fcounts[st]) * (*fiter);+ wacc = 0;+ st = q0;+ ++fiter; ++citer;+ }else{+ int i = (c*ns) + st;+ st = tmat[i];+ wacc += tcounts[i];+ ++citer;+ }+ }+}++static inline int indexScalarTable(int ns, int q, int c){+ return c * ns + q;+}++static inline int indexVecTable(int ns, int dims, int q, int c){+ return (c * ns + q) * dims;+}++static inline void accumVec16(int sz, const int16_t* restrict in, int32_t* restrict out){+ for (int i = 0; i < sz; ++i){+ out[i] += in[i];+ }+}+static inline void accumTimesVec32(int sz, int32_t s, const int32_t* restrict in, int64_t* restrict out){+ for (int i = 0; i < sz; ++i){+ out[i] += s * in[i];+ }+}+static inline void zeroVec32(int sz, int32_t* v){+ memset(v,0,4*sz);+}+static inline void zeroVec64(int sz, int64_t* v){+ memset(v,0,8*sz);+}++void transducePackedMulti(const int16_t ns, const int16_t q0, const int16_t dims,+ const int16_t* restrict tmat, const int16_t* restrict tcounts, const int16_t* restrict fcounts,+ const int16_t* restrict cstream, int32_t* restrict fstream,+ int64_t* restrict out) {+ zeroVec64(dims,out);+ int32_t wacc[dims];+ zeroVec32(dims,wacc);++ int16_t st = q0;+ const int16_t* citer = cstream;+ const int32_t* fiter = fstream;++ while(1){+ const int16_t c = *citer;+ if (c == -2){+ return;+ }+ if (c == -1){+ accumVec16(dims, fcounts + (st*dims), wacc);+ accumTimesVec32(dims, *fiter, wacc, out);+ zeroVec32(dims,wacc);+ st = q0;+ ++fiter; ++citer;+ }else{+ int i = (c*ns) + st;+ st = tmat[i];+ accumVec16(dims, tcounts+ (i*dims), wacc);+ ++citer;+ }+ }+}++void weightExpVec(const int16_t ns, const int16_t nc, const int16_t dims,+ const int16_t* restrict tcounts, const int16_t* restrict fcounts,+ const double* restrict weights,+ double* restrict tprob, double* restrict tvec, double* restrict fprob, double* restrict fvec){+ //+ for (int t = 0; t < ns*nc; ++t){+ double lp = 0;+ for (int i = 0; i < dims; ++i)+ lp += tcounts[t*dims + i] * weights[i];+ double p = exp(-lp);+ tprob[t] = p;+ for (int i = 0; i < dims; ++i)+ tvec[t*dims + i] = p * tcounts[t*dims + i];+ }++ for (int t = 0; t < ns; ++t){+ double lp = 0;+ for (int i = 0; i < dims; ++i)+ lp += fcounts[t*dims + i] * weights[i];+ double p = exp(-lp);+ fprob[t] = p;+ for (int i = 0; i < dims; ++i)+ fvec[t*dims + i] = p * fcounts[t*dims + i];+ }+}+++void weightExpPartial(const int16_t ns, const int16_t nc, const int16_t dims,+ const int16_t* restrict tcounts, const int16_t* restrict fcounts,+ const double* restrict weights, const double* restrict dir,+ double* restrict tprob, double* restrict tvec, double* restrict fprob, double* restrict fvec){+ //+ for (int t = 0; t < ns*nc; ++t){+ double lp = 0;+ double v = 0;+ for (int i = 0; i < dims; ++i){+ lp += tcounts[t*dims + i] * weights[i];+ v += tcounts[t*dims + i] * dir[i];+ }+ double p = exp(-lp);+ tprob[t] = p;+ tvec[t] = p * v;+ }++ for (int t = 0; t < ns; ++t){+ double lp = 0;+ double v = 0;+ for (int i = 0; i < dims; ++i){+ lp += fcounts[t*dims + i] * weights[i];+ v += fcounts[t*dims + i] * dir[i];+ }+ double p = exp(-lp);+ fprob[t] = p;+ fvec[t] = p * v;+ }+}++++inline void expVecTimesPlusAccum(int dim, double p1, const double* restrict v1, double p2, const double* restrict v2,+ double* restrict pacc, double* restrict vacc){+ *pacc += p1 * p2;+ for (int i = 0; i < dim; ++i){+ vacc[i] += (p2 *v1[i]) + (p1 * v2[i]);+ }+}++void expsByLengthVec(const int16_t ns, const int16_t nc, const int16_t dims, const int16_t q0, const int16_t maxlen,+ const int16_t* restrict tmat, const double* restrict tprob, const double* restrict tvec, const double* restrict fprob, const double* restrict fvec,+ double* outp, double* outv) {+ double* accump = calloc(((int)ns)*(maxlen+1), sizeof(double));+ double* accumv = calloc(((int)ns)*dims*(maxlen+1), sizeof(double));+ accump[q0] = 1;++ for (int n=1; n <= maxlen; ++n)+ for (int q = 0; q < ns; ++q)+ for (int c = 0; c < nc; ++c) {+ int qprime = tmat[c*ns+q];+ expVecTimesPlusAccum(dims, tprob[c*ns+q], tvec+(c*ns+q)*dims, accump[(n-1)*ns+q], accumv+((n-1)*ns+q)*dims,+ accump+(n*ns+qprime), accumv+(n*ns+qprime)*dims);+ }++ for (int n=0; n <= maxlen; ++n)+ for (int q = 0; q < ns; ++q){+ expVecTimesPlusAccum(dims, accump[n*ns+q], accumv+(n*ns+q)*dims, fprob[q], fvec+q*dims,+ outp+n, outv+n*dims);+ }++ free(accump);+ free(accumv);+}++void expsByLengthDouble(const int16_t ns, const int16_t nc, const int16_t q0, const int16_t maxlen,+ const int16_t* restrict tmat, const double* restrict tprob, const double* restrict tvec, const double* restrict fprob, const double* restrict fvec,+ double* outp, double* outv) {+ double* accump = calloc(((int)ns)*(maxlen+1), sizeof(double));+ double* accumv = calloc(((int)ns)*(maxlen+1), sizeof(double));+ accump[q0] = 1;++ for (int n=1; n <= maxlen; ++n)+ for (int q = 0; q < ns; ++q)+ for (int c = 0; c < nc; ++c) {+ int qprime = tmat[c*ns+q];+ double p1 = tprob[c*ns+q];+ double p2 = accump[(n-1)*ns+q];+ double v1 = tvec[c*ns+q];+ double v2 = accumv[(n-1)*ns+q];+ accump[n*ns+qprime] += p1*p2;+ accumv[n*ns+qprime] += p2*v1 + p1*v2;+ }++ for (int n=0; n <= maxlen; ++n){+ outp[n] = 0;+ outv[n] = 0;+ for (int q = 0; q < ns; ++q){+ double p1 = accump[n*ns+q];+ double p2 = fprob[q];+ double v1 = accumv[n*ns+q];+ double v2 = fvec[q];+ outp[n] += p1*p2;+ outv[n] += p2*v1 + p1*v2;+ }+ }++ free(accump);+ free(accumv);+}
+ maxent-learner-hw.cabal view
@@ -0,0 +1,60 @@+name: maxent-learner-hw+version: 0.1.0+synopsis: Hayes and Wilson's maxent learning algorithm for phonotactic grammars.+description: Provides an implementation of Hayes and Wilson's machine learning algorithm for maxent phonotactic grammars, as both a command-line tool and a function library. The learner takes in a lexicon and produces a list of weighted constraints penalizing certain sound sequemces in an attempt to produce a probability distribution of words which maximizes the probability of the lexicon. Once such a set of constraints is generated, it can be tested by using it to generate random pronounceable text.+ .+ This package is an implementation of the algorithm described in Hayes and Wilson's paper /A Maximum Entropy Model of Phonotactics and Phonotactic Learning/ (available at <http://www.linguistics.ucla.edu/people/hayes/Phonotactics/Index.htm>).+homepage: https://github.com/george-steel/maxent-learner+license: GPL+license-file: LICENSE+author: George Steel+maintainer: george.steel@gmail.com+copyright: 2016 George Steel and Peter Jurgec+category: Linguistics+build-type: Simple+extra-source-files: README.md, ffisrc/packeddfa.c, app/ft-ipa.csv+cabal-version: >=1.10++library+ cc-options: -Wall -std=c11+ hs-source-dirs: src+ exposed-modules: Text.PhonotacticLearner.Util.Ring+ , Text.PhonotacticLearner.Util.Probability+ , Text.PhonotacticLearner.Util.ConjugateGradient+ , Text.PhonotacticLearner.DFST+ , Text.PhonotacticLearner.MaxentGrammar+ , Text.PhonotacticLearner.PhonotacticConstraints+ , Text.PhonotacticLearner.PhonotacticConstraints.Generators+ , Text.PhonotacticLearner+ build-depends: base >= 4.7 && < 5+ , deepseq == 1.4.*+ , vector >= 0.10+ , mtl >= 2.1 && < 2.3+ , containers == 0.5.*+ , random == 1.1+ , array >= 0.3 && < 0.6+ , text == 1.2.*+ , csv == 0.1.*+ default-language: Haskell2010+ c-sources: ffisrc/packeddfa.c++executable phono-learner-hw+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base >= 4.7 && < 5+ , maxent-learner-hw+ , optparse-applicative+ , containers == 0.5.*+ , text == 1.2.*+ , file-embed+ , parallel == 3.2.*+ , deepseq == 1.4.*+ , array >= 0.3 && < 0.6+ , mtl >= 2.1 && < 2.3+ , random == 1.1+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/githubuser/maxent-learner-hw
+ src/Text/PhonotacticLearner.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE ScopedTypeVariables, ExplicitForAll #-}++{-|+Module: Text.PhonotacticLearner+Description: Utility for automatically inferring a maxent grammar form a candidate constraint set and lexicon.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Main learning algorithm for inferring granmmar from constraint set and lexicon. To set up the parameters, you will need to use 'sortLexicon' to prepare the text input some way of generating a set of constraint candidates (reperssented as 'DFST's). The PhonotacticConstraints module and its Generators submodule will be useful here.+-}++module Text.PhonotacticLearner(+ generateGrammarIO,++ segmentFiero, joinFiero,+) where++import Text.PhonotacticLearner.Util.Ring+import Text.PhonotacticLearner.Util.Probability+import Text.PhonotacticLearner.DFST+import Text.PhonotacticLearner.MaxentGrammar++import System.Random+import Control.Monad.State+import Control.DeepSeq+import Data.Ix+import Numeric+import Data.IORef+import Data.List+import System.IO+import Control.Exception+++stopsigint :: AsyncException -> IO ()+stopsigint e = case e of+ UserInterrupt -> do+ putStrLn "\n\nInterrupted!"+ return ()+ _ -> throw e++{-|+Infer a phonotactic grammar from a list of candidate constraints and a corpus of texts.++This algorithm works by keeping a running grammar (starting with an empty one) and repeatedly taking the next constraint on the list of candidates which improves the grammar by a large enough margin. Constraints are selected for inclusion when they have an observed number of violations less then a threshold factor times the expected number of violations in the running grammar. After each constraint is added, the weights of the running grammar are optimized. Multiple passes are made with an increasing sequence of thresholds.++For maximum flexibility, constraints are reperesented as DFSTs which count the number of violations of the constraint in an input string. In order to have understandable output, each candadite DFST is paired with a unique label, with the final grammar output as a merged DFST, a list of selected labels, and a weight vector. If the constraints are generated from a list of globs, aplying @(id &&& 'matchCounter')@ to the list will produce suitable candidates.++Since we need to process these words using DFSTs, the set of valid segments must form a continous 'Ix' range, such as @[\'a\'..\'z\']@. If the segments do not, please replace them with indices into a lookup table.++Since the algorithm works by continuous refinement, this action will catch SIGINT and terminate early if the signal is received.+-}+generateGrammarIO :: forall clabel sigma . (Show clabel, Ix sigma, NFData sigma, NFData clabel, Eq clabel)+ => Int -- ^ Monte Carlo sample size+ -> [Double] -- ^ List of accuracy thresholds+ -> [(clabel, ShortDFST sigma)] -- ^ List of candidate constraints. Labels must be unique. All DFSTs must share the same input bounds.+ -> [([sigma],Int)] -- ^ Corpus of sample words and their relative frequencies+ -> IO ([clabel], MulticountDFST sigma, Vec) -- ^ Computed grammar+generateGrammarIO samplesize thresholds candidates wfs = do+ let lwfs = sortLexicon wfs+ cbound = psegBounds . snd . head $ candidates+ blankdfa = nildfa cbound+ lendist = lengthCdf lwfs+ pwfs = packMultiText cbound (wordFreqs lwfs)++ hashctr :: IORef Int <- newIORef 0+ let mark500 = do+ c <- readIORef hashctr+ when (c `mod` 500 == 0) $ do+ hPutStr stderr "#"+ hFlush stderr+ modifyIORef' hashctr (+1)++ currentGrammar :: IORef ([clabel], MulticountDFST sigma, Vec) <- newIORef ([],pruneAndPack blankdfa ,zero)++ let genSalad :: IO (PackedText sigma)+ genSalad = do+ (_,dfa,weights) <- readIORef currentGrammar+ salad' <- getStdRandom . runState $ sampleWordSalad (fmap (maxentProb weights) (unpackDFA dfa)) lendist samplesize+ return . packMultiText cbound . wordFreqs . sortLexicon . fmap (\x -> (x,1)) $ salad'++ currentSalad <- newIORef undefined++ handle stopsigint $ do+ forM_ thresholds $ \accuracy -> do+ putStrLn $ "\n\n\nStarting pass with threshold " ++ showFFloat (Just 3) accuracy ""+ writeIORef currentSalad =<< genSalad+ forM_ candidates $ \(cl,cdfa) -> do+ mark500+ (grammar, dfa, weights) <- readIORef currentGrammar+ salad <- readIORef currentSalad+ let o = fromIntegral $ transducePackedShort cdfa pwfs+ o' = fromIntegral $ transducePackedShort cdfa salad+ e = o' * fromIntegral (totalWords lwfs) / fromIntegral samplesize+ score = upperConfidenceOE o e++ when (score < accuracy && cl `notElem` grammar) $ do+ hPutStrLn stderr ""+ putStrLn $ "\nSelected Constraint " ++ show cl ++ " (score=" ++ showFFloat (Just 4) score [] ++ ", o=" ++ showFFloat (Just 1) o [] ++ ", e=" ++ showFFloat (Just 1) e [] ++ ")."+ let newgrammar = cl:grammar+ newdfa :: MulticountDFST sigma = pruneAndPack (rawIntersection consMC (unpackDFA cdfa) (unpackDFA dfa))+ putStrLn $ "New grammar has " ++ show (length newgrammar) ++ " constraints and " ++ show (numStates newdfa) ++ " states."+ let oldweights = consVec 0 weights+ newweights <- evaluate . force $ llpOptimizeWeights (lengthFreqs lwfs) pwfs newdfa oldweights+ hPutStrLn stderr ""+ putStrLn $ "Recalculated weights: " ++ showFVec (Just 2) newweights+ atomicWriteIORef currentGrammar . force $ (newgrammar, newdfa, newweights)+ writeIORef currentSalad =<< genSalad+ putStrLn "\n\n\nAll Pases Complete."++ readIORef currentGrammar++-- | Given a set of possible segments and a string, break a string into segments.+-- Uses the rules in Fiero orthography (a phonetic writing system using ASCII characters) where the longest possible match is always taken and apostrophes are used as a digraph break.+segmentFiero :: [String] -- ^ All possible segments+ -> String -- ^ Raw text+ -> [String] -- ^ Segmented text+segmentFiero [] = error "Empty segment list."+segmentFiero allsegs = go msl where+ msl = maximum . fmap length $ allsegs+ go _ [] = []+ go _ ('\'':xs) = go msl xs+ go 0 (x:xs) = go msl xs+ go len xs | seg `elem` allsegs = seg : go msl rest+ | otherwise = go (len-1) xs+ where (seg,rest) = splitAt len xs++-- | Joins segments together using Fiero rules. Inserts apostrophes where necerssary.+joinFiero :: [String] -- ^ All possible segments+ -> [String] -- ^ Segmented text+ -> String -- ^ Raw text+joinFiero allsegs = go where+ msl = maximum . fmap length $ allsegs+ go [] = []+ go [x] = x+ go (x:xs@(y:_)) = let z = x++y+ in if any (\s -> isPrefixOf s z && not (isPrefixOf s x)) allsegs+ then x ++ ('\'' : go xs)+ else x ++ go xs
+ src/Text/PhonotacticLearner/DFST.hs view
@@ -0,0 +1,624 @@+{-# LANGUAGE ScopedTypeVariables, ExplicitForAll, FlexibleInstances, BangPatterns, FlexibleContexts, ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies #-}++{-|+Module: Text.PhonotacticLearner.DFST+Description: Library for handling deterministic finite state transducers+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Implementations of deterministic finite state transducers containing both a polymorphic 'DFST' functor and a typeclass for fast specialized types (with several implementations provided). Input alphabets are assumed to be finite rectangles inside 'Ix' types. Trandsuction functions are provided for both 'Monoid' and 'Semiring' output types. DFSTs may be created directly, generated from globs, or from smaller DFSTs using the product construction.++Optimized C functions for common output types (@'Sum' 'Int'@, 'Multicount', @'Expectation' 'Vec'@, and @'Expectation' 'Double'@) are included which use the 'PackedDFA' typeclass to convert to and from the generic type. The specialized types additionally support the following operations.++ * Packing strings into a compact format ('PackedText')++ * Transducing packed strings into integer counts and Multicounts++ * Summing over all paths of expectation transducers++ * Applying maxent weights to vector counts to get expectations++-}++module Text.PhonotacticLearner.DFST (+ fnArray, xbd,++ -- * Polymorphic DFSTs+ DFST(..),+ stateBounds, segBounds, transition,+ transduceM, transduceR, --stepweights, initialWeightArray, reverseTM,++ -- * Specialized DFSTs+ PackedDFA(..), pruneUnreachable, pruneAndPack,+ rawIntersection, dfaProduct, nildfa,++ PackedText, packSingleText, packMultiText,+ ShortDFST, transducePackedShort,+ MulticountDFST, transducePackedMulti,+ ExpVecDFST, weightExpVec, expsByLengthVec,+ ExpDoubleDFST, weightExpPartial, expsByLengthDouble,++ -- * Glob recognition+ GlobReps(..), SegSet, ListGlob(..), matchCounter+)where++import Control.DeepSeq+import Control.Monad+import Control.Monad.ST+import Data.Ix+import Data.Array.IArray+import Data.Array.MArray+import Data.Array.ST+import Data.Array.Unboxed+import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Storable.Mutable as SVM+import qualified Data.Vector.Unboxed as V+import Foreign (Ptr)+import System.IO.Unsafe+import Data.List+import Data.Bits+import Data.Monoid+import Data.Int+import Control.Arrow ((&&&), first, second)++import Text.PhonotacticLearner.Util.Ring+import Text.PhonotacticLearner.Util.Probability++-- | Create an array by caching a function over a rectangle. Depending on the array type used, this can be used to memoise or precompute.+fnArray :: (Ix i, IArray a e) => (i,i) -> (i -> e) -> a i e+fnArray bds f = array bds (fmap (\x -> (x, f x)) (range bds))+{-# INLINE fnArray #-}++-- | Turn a pair of interval tuples into an interval of pairs. Used to compute array bounds for a cartesian product.+xbd :: (a,a) -> (b,b) -> ((a,b), (a,b))+xbd (w,x) (y,z) = ((w,y), (x,z))+{-# INLINE xbd #-}++++-- | Polymorphic type for deterministic finite state transducers.+-- For an efficient implementation, the set of states and input characters are both limited to be 'Ix' rectangles and their product is the array bounds.+-- This type is a functor over its output type (note that transduction is only possible into a 'Monoid' or 'Semiring').+data DFST q sigma k = DFST { initialState :: q+ , transitionMatrix :: Array (q,sigma) (q,k)+ , finalWeights :: Array q k+ } deriving (Show)++instance (NFData q, NFData sigma, NFData k) => NFData (DFST q sigma k) where+ rnf (DFST q0 tm fw) = q0 `seq` rnf tm `seq` rnf fw+++instance (Ix q, Ix sigma) => Functor (DFST q sigma) where+ fmap f (DFST q0 tm fw) = DFST q0 (fmap (second f) tm) (fmap f fw)++-- | bounds for state labels+stateBounds :: (Ix q, Ix sigma) => DFST q sigma w -> (q,q)+stateBounds (DFST _ arr _) = let ((a,_), (b,_)) = bounds arr in (a,b)++-- | boounds for accepted segments (characters)+segBounds :: (Ix q, Ix sigma) => DFST q sigma k -> (sigma,sigma)+segBounds (DFST _ arr _) = let ((_,a), (_,b)) = bounds arr in (a,b)++-- | advance by one state and get weight output+transition :: (Ix q, Ix sigma) => DFST q sigma k -> q -> sigma -> (q,k)+transition (DFST _ arr _) s c = arr!(s,c)++advanceState :: (Ix q, Ix sigma) => DFST q sigma k -> q -> sigma -> q+advanceState (DFST _ arr _) s c = fst (arr!(s,c))++{-# INLINE stateBounds #-}+{-# INLINE segBounds #-}+{-# INLINE transition #-}+{-# INLINE advanceState #-}+++++-- | Structure holding text and word frequencies as a flat array of segment indices (in the input rectangle) for fast transduction.+data PackedText sigma = PackedText !(sigma,sigma) !(SV.Vector Int16) !(SV.Vector Int32)++-- | Pack a single string+packSingleText :: Ix sigma => (sigma,sigma) -> [sigma] -> PackedText sigma+packSingleText cbound t = PackedText cbound (SV.fromList $ fmap pchar t ++ [-1,-2]) (SV.singleton 1)+ where pchar = fromIntegral . index cbound++-- | Pack a list of string, fewquency pairs+packMultiText :: Ix sigma => (sigma,sigma) -> [([sigma],Int)] -> PackedText sigma+packMultiText cbound ts = PackedText cbound (SV.fromList $ foldr constext [-2] ts) (SV.fromList $ fmap (fromIntegral . snd) ts)+ where constext (t,_) lts = fmap (fromIntegral . index cbound) t ++ [-1] ++ lts++++-- | Typeclass for converting speaiclized DFSTs to and from polymorphic ones. This is used by several optimized versions for various output types that can be manupulated by fast C functions.+class PackedDFA pd k | pd -> k where+ -- | Number fo states in DFA+ numStates :: (Ix sigma) => pd sigma -> Int+ -- | Bounds of input rectangle+ psegBounds :: (Ix sigma) => pd sigma -> (sigma, sigma)+ -- | umpack+ unpackDFA :: (Ix sigma) => pd sigma -> DFST Int sigma k+ -- | Pack a DFA from its component functions. Use 'pruneAndPack' to convert a polymorphic 'DFST'.+ packDFA :: forall sigma . (Ix sigma)+ => Int16 -- number of states+ -> Int16 -- initial state+ -> (sigma, sigma) -- sigma bounds+ -> ((Int16,sigma) -> Int16) -- transition state+ -> ((Int16,sigma) -> k) -- transition weight+ -> (Int16 -> k) --final weight+ -> pd sigma++++++-- | Remove unreachable states and renumber as integers (starting from 1) using a mark-sweep algorithm. Result is polymorphic.+pruneUnreachable :: forall q sigma k . (Ix q, Ix sigma) => DFST q sigma k -> DFST Int sigma k+pruneUnreachable dfa = DFST (newlabels ! initialState dfa) newTM newFW+ where+ qbound = stateBounds dfa+ cbound = segBounds dfa+ reachable = runSTUArray $ do+ reached :: STUArray s q Bool <- newArray qbound False+ let dfs :: q -> ST s ()+ dfs n = do+ writeArray reached n True+ forM_ (range cbound) $ \c -> do+ let n' = advanceState dfa n c+ seen <- readArray reached n'+ when (not seen) (dfs n')+ return ()+ dfs (initialState dfa)+ return reached+ keepstates :: [q] = filter (reachable!) (range qbound)+ nbound = (1,length keepstates)+ oldlabels :: Array Int q = listArray nbound keepstates+ newlabels :: Array q Int = array qbound (zip keepstates (range nbound))+ tmbound = nbound `xbd` cbound+ newTF (s,c) = let (t,w) = transition dfa (oldlabels!s) c in (newlabels!t, w)+ newTM = fnArray tmbound newTF+ newFW = fnArray nbound ((finalWeights dfa !) . (oldlabels !))++-- | Prune unreachable states and pack into a specialized implementation+pruneAndPack :: forall q sigma pd k. (Ix q, Ix sigma, PackedDFA pd k) => DFST q sigma k -> pd sigma+pruneAndPack dfa = packDFA (fromIntegral ns) (newlabels ! initialState dfa) cbound newTF newTW newFW+ where+ qbound = stateBounds dfa+ cbound = segBounds dfa+ reachable = runSTUArray $ do+ reached :: STUArray s q Bool <- newArray qbound False+ let dfs :: q -> ST s ()+ dfs n = do+ writeArray reached n True+ forM_ (range cbound) $ \c -> do+ let n' = advanceState dfa n c+ seen <- readArray reached n'+ when (not seen) (dfs n')+ return ()+ dfs (initialState dfa)+ return reached+ keepstates :: [q] = filter (reachable!) (range qbound)+ ns = (length keepstates)+ nbound = (0, fromIntegral (ns - 1))+ oldlabels :: Array Int16 q = listArray nbound keepstates+ newlabels :: Array q Int16 = array qbound (zip keepstates (range nbound))+ newTF (s,c) = let (t,_) = transition dfa (oldlabels!s) c in newlabels!t+ newTW (s,c) = let (_,w) = transition dfa (oldlabels!s) c in w+ newFW = (finalWeights dfa !) . (oldlabels !) . fromIntegral+++-- | Lifts a weight combining function into one that combines DFAs. Performs no pruning and new states are all pairs of old ones.+-- For boolean weights, use (&&) for intersection and (||) for union.+rawIntersection :: (Ix q1, Ix q2, Ix sigma) => (k1 -> k2 -> k3) -> DFST q1 sigma k1 -> DFST q2 sigma k2 -> DFST (q1,q2) sigma k3+rawIntersection f dfa1@(DFST qi1 tm1 fw1) dfa2@(DFST qi2 tm2 fw2)+ | cbound == cbound2 = DFST (qi1,qi2) (fnArray tmbound newTF) (fnArray qbound' newFW)+ | otherwise = error "Segment ranges must match"+ where+ qbound1 = stateBounds dfa1+ qbound2 = stateBounds dfa2+ cbound = segBounds dfa1+ cbound2 = segBounds dfa2+ qbound' = qbound1 `xbd` qbound2+ tmbound = qbound' `xbd` cbound+ newTF ((s1,s2),c) = let (t1,w1) = tm1 ! (s1,c)+ (t2,w2) = tm2 ! (s2,c)+ in ((t1,t2), f w1 w2)+ newFW (s1,s2) = f (fw1!s1) (fw2!s2)++-- | Product construction with pruning.+dfaProduct :: (Ix l1, Ix l2, Ix sigma) => (w1 -> w2 -> w3) -> DFST l1 sigma w1 -> DFST l2 sigma w2 -> DFST Int sigma w3+dfaProduct f dfa1 dfa2 = pruneUnreachable (rawIntersection f dfa1 dfa2)++-- | Given input bounds, Construct a DFST which always returns mempty for any string.+nildfa :: (Ix sigma, Monoid k) => (sigma,sigma) -> DFST Int sigma k+nildfa (a,z) = DFST 1 tm fm+ where+ tm = fnArray ((1,a),(1,z)) (const (1,mempty))+ fm = fnArray (1,1) (const mempty)++-- | Transduce a string of segments where and output the product of the weights (as a Monoid).+transduceM :: (Ix q, Ix sigma, Monoid k) => DFST q sigma k -> [sigma] -> k+transduceM (DFST q0 tm fw) cs = mconcat ws <> (fw ! fq)+ where (fq, ws) = mapAccumL (curry (tm!)) q0 cs++-- | Transduce a string of segments where and output the product of the weights (as a Ring).+transduceR :: (Ix q, Ix sigma, Semiring k) => DFST q sigma k -> [sigma] -> k+transduceR (DFST q0 tm fw) cs = productR ws ⊗ (fw ! fq)+ where (fq, ws) = mapAccumL (curry (tm!)) q0 cs++++------------------------------------------------------------------------------+-- structurees for packed DFST counter with compact representation optimized c transduce implementation+++-- | Optimized DFST specialized to transduce integers+data ShortDFST sigma = ShortDFST {-# UNPACK #-} !Int16 -- number of states+ {-# UNPACK #-} !Int16 -- initial state+ {-# UNPACK #-} !(sigma, sigma) -- segment bounds+ !(SV.Vector Int16) -- state transitions+ !(SV.Vector Int16) -- weight transitions+ !(SV.Vector Int16) -- final weights+ deriving (Show)+++instance NFData sigma => NFData (ShortDFST sigma) where+ rnf (ShortDFST ns q0 sb tf tw fw) = ns `seq` q0 `seq` rnf sb `seq` tf `seq` tw `seq` fw `seq` ()++foreign import ccall unsafe "transducePackedShort"+ c_transducePackedShort :: Int16 -> Int16+ -> Ptr Int16 -> Ptr Int16 -> Ptr Int16+ -> Ptr Int16 -> Ptr Int32+ -> IO (Int64)++boxArray :: Ix i => (i,i) -> [(i,e)] -> Array i e+boxArray = array++instance PackedDFA ShortDFST (Sum Int) where+ numStates (ShortDFST ns _ _ _ _ _) = fromIntegral ns+ psegBounds (ShortDFST _ _ sb _ _ _) = sb++ packDFA ns' q0 cbound tf tw fw = ShortDFST ns' q0 cbound tfm twm fwm where+ ns = fromIntegral ns'+ nc = rangeSize cbound+ unIxc = boxArray (0,rangeSize cbound - 1) (fmap (index cbound &&& id) (range cbound))+ oldix i = let (qt,r) = i `quotRem` ns in (fromIntegral r, unIxc ! qt)+ tfm = SV.generate (ns*nc) (tf . oldix)+ twm = SV.generate (ns*nc) (fromIntegral . getSum . tw . oldix)+ fwm = SV.generate ns (fromIntegral . getSum . fw . fromIntegral)++ unpackDFA (ShortDFST ns q0 cbound tm twm fwm) = DFST (fromIntegral q0) tm' fwm' where+ qbound :: (Int, Int)+ qbound = (0, fromIntegral ns - 1)+ tbound = qbound `xbd` cbound+ --idx :: (Int,sigma) -> Int+ idx (s,c) = s + fromIntegral ns * index cbound c+ tf :: Int -> (Int, Sum Int)+ tf = (fromIntegral . (tm SV.!)) &&& (fromIntegral . (twm SV.!))+ tm' = fnArray tbound (tf . idx)+ fwm' = fnArray qbound (fromIntegral . (fwm SV.!))++-- | Fast transduction of integers. For multiple words, returns the sum of all transductions.+transducePackedShort :: (Ix sigma) => ShortDFST sigma -> PackedText sigma -> Int+transducePackedShort (ShortDFST ns q0 cb tf tw fw) (PackedText cb' tvec fvec)+ | cb == cb' = fromIntegral . unsafePerformIO $+ SV.unsafeWith tf $ \ptf -> SV.unsafeWith tw $ \ptw -> SV.unsafeWith fw $ \pfw ->+ SV.unsafeWith tvec $ \ptvec -> SV.unsafeWith fvec $ \pfvec ->+ c_transducePackedShort ns q0 ptf ptw pfw ptvec pfvec+ | otherwise = error "Mismatched chatacter bounds in packed text vs DFA"+++++++-- | Optimized DFST specialized to transduce into 'Multicount' mnd count multiple quantities in parallel.+data MulticountDFST sigma = MulticountDFST {-# UNPACK #-} !Int16 -- number of states+ {-# UNPACK #-} !Int16 -- initial state+ {-# UNPACK #-} !(sigma, sigma) -- segment bounds+ {-# UNPACK #-} !Int16 -- vector dimensions+ !(SV.Vector Int16) -- state transitions+ !(SV.Vector Int16) -- weight transitions+ !(SV.Vector Int16) -- final weights+ deriving (Show)++instance NFData sigma => NFData (MulticountDFST sigma) where+ rnf (MulticountDFST ns q0 sb dims tf tw fw) = ns `seq` q0 `seq` rnf sb `seq` dims `seq` tf `seq` tw `seq` fw `seq` ()++instance PackedDFA MulticountDFST (Multicount) where+ numStates (MulticountDFST ns _ _ _ _ _ _) = fromIntegral ns+ psegBounds (MulticountDFST _ _ sb _ _ _ _) = sb++ packDFA ns' q0 cbound tf tw fw = MulticountDFST ns' q0 cbound (fromIntegral dims) tfm twm fwm where+ ns = fromIntegral ns'+ nc = rangeSize cbound+ dims::Int = let (MC x) = tw (0,fst cbound) in fromIntegral (V.length x)+ unIxc = boxArray (0,rangeSize cbound - 1) (fmap (index cbound &&& id) (range cbound))+ oldix i = let (qt,r) = i `quotRem` ns in (fromIntegral r, unIxc ! qt)+ tfm = SV.generate (ns*nc) (tf . oldix)+ twm = SV.generate (ns*nc*dims) (\i -> let (i',j) = i `quotRem` dims in fromIntegral (unMC (tw (oldix i')) V.! j))+ fwm = SV.generate (ns*dims) (\i -> let (i',j) = i `quotRem` dims in fromIntegral (unMC (fw (fromIntegral i')) V.! j))++ unpackDFA (MulticountDFST ns q0 cbound dims' tm twm fwm) = DFST (fromIntegral q0) tm' fwm' where+ dims = fromIntegral dims'+ qbound :: (Int, Int)+ qbound = (0, fromIntegral ns - 1)+ tbound = qbound `xbd` cbound+ --idx :: (Int,sigma) -> Int+ idx (s,c) = s + fromIntegral ns * index cbound c+ tf :: Int -> (Int, Multicount)+ tf i = (fromIntegral (tm SV.! i), MC ((V.map fromIntegral . SV.convert) (SV.slice (i*dims) dims twm)))+ tm' = fnArray tbound (tf . idx)+ fwm' = fnArray qbound (\i -> MC ((V.map fromIntegral . SV.convert) (SV.slice (i*dims) dims fwm)))++foreign import ccall unsafe "transducePackedMulti"+ c_transducePackedMulti :: Int16 -> Int16 -> Int16+ -> Ptr Int16 -> Ptr Int16 -> Ptr Int16+ -> Ptr Int16 -> Ptr Int32+ -> Ptr Int64 -> IO ()++-- | Fast transduction of 'Multicount'. For multiple words, returns the sum of all transductions.+transducePackedMulti :: (Ix sigma) => MulticountDFST sigma -> PackedText sigma -> Multicount+transducePackedMulti (MulticountDFST ns q0 cb dims tf tw fw) (PackedText cb' tvec fvec)+ | cb == cb' = MC . V.map fromIntegral . SV.convert . unsafePerformIO $+ SV.unsafeWith tf $ \ptf -> SV.unsafeWith tw $ \ptw -> SV.unsafeWith fw $ \pfw ->+ SV.unsafeWith tvec $ \ptvec -> SV.unsafeWith fvec $ \pfvec -> do+ outv :: SVM.IOVector Int64 <- SVM.new (fromIntegral dims)+ SVM.unsafeWith outv (c_transducePackedMulti ns q0 dims ptf ptw pfw ptvec pfvec)+ SV.freeze outv+ | otherwise = error "Mismatched chatacter bounds in packed text vs DFA"+++-- | Optimized DFST form calculating verctor expectations over the entire probability distribution defined by the DFA.+data ExpVecDFST sigma = ExpVecDFST {-# UNPACK #-} !Int16 -- number of states+ {-# UNPACK #-} !Int16 -- initial state+ {-# UNPACK #-} !(sigma, sigma) -- segment bounds+ {-# UNPACK #-} !Int16 -- vector dimensions+ !(SV.Vector Int16) -- state transitions+ !(SV.Vector Double) -- transition probabilities+ !(SV.Vector Double) -- transition vectors+ !(SV.Vector Double) -- final probabilities+ !(SV.Vector Double) -- final vectors+ deriving (Show)++instance PackedDFA ExpVecDFST (Expectation Vec) where+ numStates (ExpVecDFST ns _ _ _ _ _ _ _ _ ) = fromIntegral ns+ psegBounds (ExpVecDFST _ _ sb _ _ _ _ _ _ ) = sb++ packDFA ns' q0 cbound tf tw fw = ExpVecDFST ns' q0 cbound (fromIntegral dims) tm tpm tvm fpm fvm where+ ns = fromIntegral ns'+ nc = rangeSize cbound+ dims::Int = let (Exp _ (Vec x)) = tw (0,fst cbound) in fromIntegral (V.length x)+ unIxc = boxArray (0,rangeSize cbound - 1) (fmap (index cbound &&& id) (range cbound))+ oldix i = let (qt,r) = i `quotRem` ns in (fromIntegral r, unIxc ! qt)+ tm = SV.generate (ns*nc) (tf . oldix)+ tpm = SV.generate (ns*nc) (prob . tw . oldix)+ tvm = SV.generate (ns*nc*dims) (\i -> let (i',j) = i `quotRem` dims in (unVec . exps . tw . oldix $ i') V.! j)+ fpm = SV.generate ns (prob . fw . fromIntegral)+ fvm = SV.generate (ns*dims) (\i -> let (i',j) = i `quotRem` dims in (unVec . exps . fw . fromIntegral $ i') V.! j)++ unpackDFA (ExpVecDFST ns q0 cbound dims' tm tpm tvm fpm fvm) = DFST (fromIntegral q0) tm' fwm' where+ dims = fromIntegral dims'+ qbound :: (Int, Int)+ qbound = (0, fromIntegral ns - 1)+ tbound = qbound `xbd` cbound+ --idx :: (Int,sigma) -> Int+ idx (s,c) = s + fromIntegral ns * index cbound c+ tf i = (fromIntegral (tm SV.! i), Exp (tpm SV.! i) (Vec (SV.convert (SV.slice (i*dims) dims tvm))))+ tm' = fnArray tbound (tf . idx)+ fw i = Exp (fpm SV.! i) (Vec (SV.convert (SV.slice (i*dims) dims fvm)))+ fwm' = fnArray qbound fw++--void weightExpVec(const int16_t ns, const int16_t nc, const int16_t dims,+-- const int16_t* restrict tcounts, const int16_t* restrict fcounts,+-- const double* restrict weights,+-- double* restrict tprob, double* restrict tvec, double* restrict fprob, double* restrict fvec){++foreign import ccall unsafe "weightExpVec"+ c_weightExpVec :: Int16 -> Int16 -> Int16+ -> Ptr Int16 -> Ptr Int16+ -> Ptr Double+ -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()++-- | Assign maxent weights to the counts in a Multicount to get expectations (which include probabilities).+weightExpVec :: (Ix sigma) => MulticountDFST sigma -> Vec -> ExpVecDFST sigma+weightExpVec (MulticountDFST ns q0 cbound dims tm tc fc) (Vec weights)+ | dims' == V.length weights = (ExpVecDFST ns q0 cbound dims tm tpm tvm fpm fvm)+ where+ w' = SV.convert weights+ ns' = fromIntegral ns+ nc = rangeSize cbound+ dims' = fromIntegral dims+ (tpm,tvm,fpm,fvm) = unsafePerformIO $ do+ tpm' <- SVM.new (ns'*nc)+ tvm' <- SVM.new (ns'*nc*dims')+ fpm' <- SVM.new (ns')+ fvm' <- SVM.new (ns'*dims')+ SV.unsafeWith tc $ \ptc -> SV.unsafeWith fc $ \pfc -> SV.unsafeWith w' $ \pw ->+ SVM.unsafeWith tpm' $ \ptp -> SVM.unsafeWith tvm' $ \ptv -> SVM.unsafeWith fpm' $ \pfp -> SVM.unsafeWith fvm' $ \pfv ->+ c_weightExpVec ns (fromIntegral nc) dims ptc pfc pw ptp ptv pfp pfv+ (,,,) <$> SV.freeze tpm' <*> SV.freeze tvm' <*> SV.freeze fpm' <*> SV.freeze fvm'++--void expsByLengthVec(const int16_t ns, const int16_t nc, const int16_t dims, const int16_t q0, const int16_t maxlen,+-- const int16_t* restrict tmat, const double* restrict tprob, const double* restrict tvec, const double* restrict fprob, const double* restrict fvec,+-- double* outp, double* outv) {+foreign import ccall unsafe "expsByLengthVec"+ c_expsByLengthVec :: Int16 -> Int16 -> Int16 -> Int16 -> Int16+ -> Ptr Int16 -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double+ -> Ptr Double -> Ptr Double -> IO ()++-- | Get the total expectations over each length of string up to a maximum+expsByLengthVec :: (Ix sigma) => ExpVecDFST sigma -> Int -> Array Int (Expectation Vec)+expsByLengthVec (ExpVecDFST ns q0 cbound dims tm tpm tvm fpm fvm) maxlen = unsafePerformIO $ do+ let nc = rangeSize cbound+ dims' = fromIntegral dims+ ns' = fromIntegral ns+ lpm <- SVM.new (ns'*(maxlen+1))+ lvm <- SVM.new (dims'*ns'*(maxlen+1))+ SV.unsafeWith tm $ \ptm -> SV.unsafeWith tpm $ \ptp -> SV.unsafeWith tvm $ \ptv -> SV.unsafeWith fpm $ \pfp -> SV.unsafeWith fvm $ \pfv ->+ SVM.unsafeWith lpm $ \plp -> SVM.unsafeWith lvm $ \plv ->+ c_expsByLengthVec ns (fromIntegral nc) dims q0 (fromIntegral maxlen) ptm ptp ptv pfp pfv plp plv+ fmap (listArray (0,maxlen)) . forM (range (0,maxlen)) $ \n -> do+ p <- SVM.read lpm n+ v <- SV.freeze (SVM.slice (n*dims') dims' lvm)+ return $ Exp p (Vec (SV.convert v))+++-- | Optimized DFST form calculating scalar expectations over the entire probability distribution defined by the DFA.+data ExpDoubleDFST sigma = ExpDoubleDFST {-# UNPACK #-} !Int16 -- number of states+ {-# UNPACK #-} !Int16 -- initial state+ {-# UNPACK #-} !(sigma, sigma) -- segment bounds+ !(SV.Vector Int16) -- state transitions+ !(SV.Vector Double) -- transition probabilities+ !(SV.Vector Double) -- transition vectors+ !(SV.Vector Double) -- final probabilities+ !(SV.Vector Double) -- final vectors+ deriving (Show)++instance PackedDFA ExpDoubleDFST (Expectation Double) where+ numStates (ExpDoubleDFST ns _ _ _ _ _ _ _ ) = fromIntegral ns+ psegBounds (ExpDoubleDFST _ _ sb _ _ _ _ _ ) = sb++ packDFA ns' q0 cbound tf tw fw = ExpDoubleDFST ns' q0 cbound tm tpm tvm fpm fvm where+ ns = fromIntegral ns'+ nc = rangeSize cbound+ unIxc = boxArray (0,rangeSize cbound - 1) (fmap (index cbound &&& id) (range cbound))+ oldix i = let (qt,r) = i `quotRem` ns in (fromIntegral r, unIxc ! qt)+ tm = SV.generate (ns*nc) (tf . oldix)+ tpm = SV.generate (ns*nc) (prob . tw . oldix)+ tvm = SV.generate (ns*nc) (exps . tw . oldix)+ fpm = SV.generate ns (prob . fw . fromIntegral)+ fvm = SV.generate ns (exps . fw . fromIntegral)++ unpackDFA (ExpDoubleDFST ns q0 cbound tm tpm tvm fpm fvm) = DFST (fromIntegral q0) tm' fwm' where+ qbound :: (Int, Int)+ qbound = (0, fromIntegral ns - 1)+ tbound = qbound `xbd` cbound+ --idx :: (Int,sigma) -> Int+ idx (s,c) = s + fromIntegral ns * index cbound c+ tf i = (fromIntegral (tm SV.! i), Exp (tpm SV.! i) (tvm SV.! i))+ tm' = fnArray tbound (tf . idx)+ fw i = Exp (fpm SV.! i) (fvm SV.! i)+ fwm' = fnArray qbound fw++--void weightExpVec(const int16_t ns, const int16_t nc, const int16_t dims,+-- const int16_t* restrict tcounts, const int16_t* restrict fcounts,+-- const double* restrict weights,+-- double* restrict tprob, double* restrict tvec, double* restrict fprob, double* restrict fvec){++foreign import ccall unsafe "weightExpPartial"+ c_weightExpPartial :: Int16 -> Int16 -> Int16+ -> Ptr Int16 -> Ptr Int16+ -> Ptr Double -> Ptr Double+ -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()++-- | Assign maxent weights to the counts in a Multicount to and apply a covector to the resulting expectations.+weightExpPartial :: (Ix sigma) => MulticountDFST sigma -> Vec -> Vec -> ExpDoubleDFST sigma+weightExpPartial (MulticountDFST ns q0 cbound dims tm tc fc) (Vec weights) (Vec dir)+ | dims' == V.length weights && dims' == V.length dir = (ExpDoubleDFST ns q0 cbound tm tpm tvm fpm fvm)+ where+ w' = SV.convert weights+ dir' = SV.convert dir+ ns' = fromIntegral ns+ nc = rangeSize cbound+ dims' = fromIntegral dims+ (tpm,tvm,fpm,fvm) = unsafePerformIO $ do+ tpm' <- SVM.new (ns'*nc)+ tvm' <- SVM.new (ns'*nc)+ fpm' <- SVM.new (ns')+ fvm' <- SVM.new (ns')+ SV.unsafeWith tc $ \ptc -> SV.unsafeWith fc $ \pfc -> SV.unsafeWith w' $ \pw -> SV.unsafeWith dir' $ \pdir ->+ SVM.unsafeWith tpm' $ \ptpm -> SVM.unsafeWith tvm' $ \ptvm -> SVM.unsafeWith fpm' $ \pfpm -> SVM.unsafeWith fvm' $ \pfvm ->+ c_weightExpPartial ns (fromIntegral nc) dims ptc pfc pw pdir ptpm ptvm pfpm pfvm+ (,,,) <$> SV.freeze tpm' <*> SV.freeze tvm' <*> SV.freeze fpm' <*> SV.freeze fvm'+++++--vvoid expsByLengthDouble(const int16_t ns, const int16_t nc, const int16_t dims, const int16_t q0, const int16_t maxlen,+-- const int16_t* restrict tmat, const double* restrict tprob, const double* restrict tvec, const double* restrict fprob, const double* restrict fvec,+-- double* outp, double* outv) {+foreign import ccall unsafe "expsByLengthDouble"+ c_expsByLengthDouble :: Int16 -> Int16 -> Int16 -> Int16+ -> Ptr Int16 -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double+ -> Ptr Double -> Ptr Double -> IO ()++-- | Get the total expectations over each length of string up to a maximum+expsByLengthDouble :: (Ix sigma) => ExpDoubleDFST sigma -> Int -> Array Int (Expectation Double)+expsByLengthDouble (ExpDoubleDFST ns q0 cbound tm tpm tvm fpm fvm) maxlen = unsafePerformIO $ do+ let nc = rangeSize cbound+ ns' = fromIntegral ns+ lpm <- SVM.new (ns'*(maxlen+1))+ lvm <- SVM.new (ns'*(maxlen+1))+ SV.unsafeWith tm $ \ptm -> SV.unsafeWith tpm $ \ptp -> SV.unsafeWith tvm $ \ptv -> SV.unsafeWith fpm $ \pfp -> SV.unsafeWith fvm $ \pfv ->+ SVM.unsafeWith lpm $ \plp -> SVM.unsafeWith lvm $ \plv ->+ c_expsByLengthDouble ns (fromIntegral nc) q0 (fromIntegral maxlen) ptm ptp ptv pfp pfv plp plv+ fmap (listArray (0,maxlen)) . forM (range (0,maxlen)) $ \n -> do+ p <- SVM.read lpm n+ v <- SVM.read lvm n+ return (Exp p v)++++--------------------------------------------------------------------------------+++-- | Type for Glob quantifiers+data GlobReps = GSingle | GPlus | GStar deriving (Enum, Eq, Ord, Read, Show)+instance NFData GlobReps where+ rnf gr = gr `seq` ()++-- | Fast reperesentation of a set of segments by its characteristic function over an enclosing rectangle of segments.+type SegSet sigma = UArray sigma Bool++-- | Glob of segment lists, nore generalized version of ngrams allowing for repeated classes as well as single ones. The two boolean parameters restrict the glob to match a prefixes or suffixes only.+data ListGlob sigma = ListGlob Bool -- Is restricted to string start+ Bool -- Is restricted to string end+ [(GlobReps, SegSet sigma)] -- List of character sets and their quantifiers.+ deriving (Eq, Ord)++instance (IArray UArray e, NFData i, Ix i) => NFData (UArray i e) where+ rnf a = let b = bounds a in (a ! fst b) `seq` rnf b++instance (NFData sigma, Ix sigma) => NFData (ListGlob sigma) where+ rnf (ListGlob isinit isfin parts) = isinit `seq` isfin `seq` rnf parts++-- | Globs are displayed in regex format+instance Show (ListGlob Char) where+ show (ListGlob isinit isfin parts) = (guard isinit >> "^") ++ (showGP =<< parts) ++ (guard isfin >> "$")+ where showGP :: (GlobReps, SegSet Char) -> String+ showGP (rep, cs) = "[" ++ fmap fst (filter snd (assocs cs)) ++ "]" +++ case rep of GSingle -> ""+ GPlus -> "+"+ GStar -> "*"++-- | Create a DFST countign the violations of a ListGlob. Each 'SegSet' in the glob must have the same bounds and the glob must not be empty.+matchCounter :: forall sigma . (Ix sigma) => ListGlob sigma -> ShortDFST sigma+matchCounter (ListGlob isinit isfin gparts) = pruneAndPack $ DFST (followEpsilons 0) tm fw where+ cbound = bounds . snd . head $ gparts+ ngp = length gparts+ nns = if isfin then ngp + 1 else ngp+ maxq = 2^nns - 1 -- this alo works as a bitmask+ tmbound = (0,maxq) `xbd` cbound+ gparr = listArray (0,ngp-1) gparts :: Array Int (GlobReps, SegSet sigma)+ -- glob to nfa using bitmask lists+ followEpsilons b | b >= ngp = bit b+ | fst (gparr ! b) == GStar = bit b .|. followEpsilons (b+1)+ | otherwise = bit b+ ntf (b,c) = (if (b == 0) && not isinit then bit 0 .|. followEpsilons 0 else 0)+ .|. if not (snd (gparr ! b) ! c) then 0 else case fst (gparr ! b) of+ GSingle -> followEpsilons (b+1)+ GPlus -> followEpsilons b .|. followEpsilons (b+1)+ GStar -> followEpsilons b+ ntm = fnArray ((0,ngp-1) `xbd` cbound) ntf :: Array (Int,sigma) Int+ --nfa to dfst+ dtf (s,c) = (ns',w) where+ ns = foldl (.|.) 0 $ do+ b <- range (0,ngp-1)+ guard (testBit s b)+ return (ntm ! (b,c))+ ns' = ns .&. maxq+ w = if not isfin && testBit ns ngp then 1 else 0+ tm = fnArray tmbound dtf :: Array (Int,sigma) (Int, Sum Int)+ fwf s = if testBit s ngp then 1 else 0+ fw = fnArray (0,maxq) fwf
+ src/Text/PhonotacticLearner/MaxentGrammar.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE ScopedTypeVariables,+ ExplicitForAll,+ MultiParamTypeClasses,+ FlexibleInstances,+ FlexibleContexts,+ UndecidableInstances,+ BangPatterns #-}++{-|+Module: Text.PhonotacticLearner.MaxentGrammar.MaxentGrammar+Description: Functions to model maxent grammars using DFSTs.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Library for using DFAs to represent maxent grammars. A mexent grammar consists of a set of constraints, each of which is given a weight, which define a probability diatribution over the set of strings of each given length.+The relative probability (maxent score) of each string is equal to the negative exponential of the the total weight of the violated constraints. In this module, such a grammar is reperesented by a 'DFST' which can count violations and a 'Vec' of weights.++This module is mainly concerned with calculating probabilities of samples of text and finding the optimal weights to maximize that probability. There are also functions to randomly generate text using the distribution implied by a mexent grammar.+-}++module Text.PhonotacticLearner.MaxentGrammar (+ Length, Lexicon(..), sortLexicon, lengthCdf, lengthPdf,++ maxentProb,+ lexLogProbTotalDeriv, lexLogProbPartialDeriv,+ llpOptimizeWeights,++ sampleWord, sampleWordSalad+) where++import Text.PhonotacticLearner.Util.Ring+import Text.PhonotacticLearner.DFST+import Text.PhonotacticLearner.Util.Probability+import Text.PhonotacticLearner.Util.ConjugateGradient++import Data.Array.IArray+import Data.Array.Unboxed+import Control.Monad+import Control.Monad.State+--import Control.Monad.Trans.Class+import Control.Arrow ((&&&),(***))+import System.Random+import Data.List as L+import Data.Monoid+import Data.Maybe+import qualified Data.Map as M+import qualified Data.Vector.Unboxed as V+--------------------------------------------------------------------------------++++--------------------------------------------------------------------------------++-- | Apply weights to violation counts to get a relative probability.+maxentProb :: Vec -> Multicount -> Double+maxentProb !weights !counts = exp . negate $ innerProd weights (fromMC counts)++{-# INLINE maxentProb #-}++type Length = Int++-- | Returns the probability (as a logarithm) of a lexicon with aand associated length distribution.+data Lexicon sigma = Lex { totalWords :: Int+ , lengthFreqs :: Array Length Int+ , wordFreqs :: [([sigma], Int)]+ } deriving Show++-- | Convert jumbled list of words and frequencies to sorted lexicon.+sortLexicon :: (Ord sigma) => [([sigma],Int)] -> Lexicon sigma+sortLexicon wfs = Lex twords alengths awf+ where+ mwf = M.fromListWith (+) wfs+ awf = M.assocs mwf+ mlengths = M.mapKeysWith (+) length mwf+ maxlen = fst (M.findMax mlengths)+ alengths = accumArray (+) 0 (0,maxlen) (M.assocs mlengths)+ twords = sum (M.elems mlengths)++-- | Retrieve length distribution as a 'Cdf' for sampling.+lengthCdf :: Lexicon sigma -> Cdf Length+lengthCdf = massToCdf . assocs . fmap fromIntegral . lengthFreqs++-- | Retrieve length distribution as a normalized probability mass function. Probabilities add up to 1.+lengthPdf :: Lexicon sigma -> [(Length, Double)]+lengthPdf wfs = assocs . fmap fracOfTotal . lengthFreqs $ wfs+ where fracOfTotal k = fromIntegral k / fromIntegral (totalWords wfs)+++priorDeriv :: Vec -> Vec -> Vec+priorDeriv (Vec !weights) (Vec !dlp) = Vec $ V.zipWith (\w d -> if w < 0.01 then min (d+1) 0 else d+1) weights dlp+{-# INLINE priorDeriv #-}++-- | For a given set of consteraints (reperesented by a DFST counting violations),+-- lexicon (reprersented as length distribution and total violation count, which should be precomputed),+-- and weight vector, returns the absolute probability (as a negative logarithm) and its derivative with respect to the weight vector.+--+-- Minimize this to find the optimal weights.+-- To prevent overfitting, this function includes an exponential (L₁) prior equivalent to each constraint being violated once for existing.+-- This intentionally differs from Hayes and Wilson since their gaussian (L₂²) prior had a strong preference for as many simillar constraints as possible as opposed to a single constraint. The exponential prior was chosen since it is independent of splitting constraints into duplicates with the weight distributed between them.+lexLogProbTotalDeriv :: (Ix sigma) => MulticountDFST sigma -- ^ DFST counting constraint violations+ -> Array Length Int -- ^ Length distribution of lexicon+ -> Vec -- ^ Observed violations in lexicon+ -> Vec -- ^ Weights to give constraints+ -> (Double, Vec) -- ^ Probability and its derivative w.r.t. the weights+lexLogProbTotalDeriv !ctr !lengths !oviols !weights = (totalViolWeight + totalNormalizer + prior, priorDeriv weights (oviols ⊖ expviols))+ where+ --prior = innerProd weights weights / 2+ prior = l1Vec weights+ edfa = weightExpVec ctr weights+ (_,maxlen) = bounds lengths+ exps = expsByLengthVec edfa maxlen+ totalViolWeight = innerProd oviols weights+ totalNormalizer = sum . fmap (\(l,n) -> n ⊙ log (prob (exps ! l))) . assocs $ lengths+ expviols = sumR . fmap (\(l,n) -> n ⊙ normalizeExp (exps ! l)) . assocs $ lengths+++-- | Compute partial derivative of lexicon probability. Much faster equivalent of+--+-- > lexLogProbPartialDeriv ctr lengths oviols weights dir = dir `innerProd` snd (lexLogProbTotalDeriv ctr lengths oviols weights)++lexLogProbPartialDeriv :: (Ix sigma) => MulticountDFST sigma -> Array Length Int -> Vec -> Vec -> Vec -> Double+lexLogProbPartialDeriv !ctr !lengths !oviols !weights !dir = innerProd (dl1Vec weights) dir + innerProd dir oviols - expviols+ where+ edfa = weightExpPartial ctr weights dir+ (_,maxlen) = bounds lengths+ exps = expsByLengthDouble edfa maxlen+ expviols = sumR . fmap (\(l,n) -> n ⊙ normalizeExp (exps ! l)) . assocs $ lengths++++zeroNeg :: Vec -> (Vec, Bool)+zeroNeg (Vec v) = (Vec (V.map (\x -> if x < 0.01 then 0 else x) v), V.any (\x -> x /= 0 && x < -0.01) v)++-- | Calculate weights to maximize probability of lexicon.+-- Takes starting position of search which MUST have the correct dimensionality (do not use 'zero')+llpOptimizeWeights :: (Ix sigma) => Array Length Int -- Length distribution+ -> PackedText sigma -- Packed lexicon+ -> MulticountDFST sigma -- Constraint violation counter+ -> Vec -- initial guess at weights+ -> Vec -- Weights+llpOptimizeWeights lengths pwfs dfa initweights =+ let oviols = fromMC (transducePackedMulti dfa pwfs)+ in conjugateGradientSearch True+ (0.01, 0.005)+ zeroNeg+ (lexLogProbTotalDeriv dfa lengths oviols)+ (lexLogProbPartialDeriv dfa lengths oviols)+ initweights+++--------------------------------------------------------------------------------+++-- used for statistical calculations over an entire dfa with ring weights (e.g. probabilities)+-- given an array mapping states to weights (e.g, a maxent distribution),+-- gives a new distribution after transducing an additional character+stepweights :: (Ix q, Ix sigma, Semiring k) => DFST q sigma k -> Array q k -> Array q k+stepweights dfa@(DFST _ tm _) prev = accumArray (⊕) zero sbound (fmap pathweight (range (bounds tm)))+ where+ sbound = stateBounds dfa+ pathweight (s,c) = let (ns,w) = tm!(s,c) in (ns, (prev!s) ⊗ w)++-- gives an array from states to weights with 1 in the first position and 0 elsewhere+initialWeightArray :: (Ix l, Ix sigma, Semiring w) => DFST l sigma w -> Array l w+initialWeightArray dfa = fnArray (stateBounds dfa) (\x -> if x == initialState dfa then one else zero)++-- converts to an NFA with all the arrows reversed+reverseTM :: (Ix q, Ix sigma) => DFST q sigma k -> Array (q,sigma) [(q,k)]+reverseTM (DFST _ arr _) = accumArray (flip (:)) [] (bounds arr) (fmap (\((s,c),(s',w)) -> ((s',c),(s,w))) (assocs arr))+++-- | Returns a monadic action to sample random words from a probability transducer,+-- which may be generated from a violation counter with @('fmap' ('maxentProb' weights) ctr)@).+-- For efficiency, evaluate this once then sequence the action repeatedly as intermediate values will be memoized.++sampleWord :: forall g sigma m . (RandomGen g, Ix sigma, MonadState g m)+ => DFST Int sigma Double -- ^ Probability DFST+ -> Length -- ^ Maximum length to greate generator fot+ -> (Length -> m [sigma]) -- ^ Random generator taking length and returning action.+sampleWord dfa maxn = backDists `seq` \n -> do+ fs <- sampleCdf (finalStates ! n)+ rcs <- flip evalStateT fs . forM (reverse . range $ (1, min n maxn)) $ \k -> do+ s <- get+ (c,s') <- lift . sampleCdf $ backDists!(k,s)+ put s'+ return c+ return (reverse rcs)+ where+ backnfa = reverseTM dfa+ qbound = stateBounds dfa++ maxentPrefixes = take (maxn + 1) (iterate (stepweights dfa) (initialWeightArray dfa))+ maxentArray :: UArray (Int,Int) Double+ maxentArray = array ((0,maxn) `xbd` qbound) . join . snd . mapAccumL (\k a -> (k+1, fmap (\(x,p)->((k,x),p)) (assocs a))) 0 $ maxentPrefixes++ backDist :: (Int, Int) -> Cdf (sigma, Int)+ backDist (k, s) = massToCdf $ do+ c <- range (segBounds dfa)+ (s', w) <- backnfa!(s,c)+ return ((c,s'), w * (maxentArray!(k-1,s')))+ -- memoized version+ backDists :: Array (Int, Int) (Cdf (sigma, Int))+ backDists = fnArray ((1,maxn) `xbd` qbound) backDist++ finalStates :: Array Int (Cdf Int)+ finalStates = array (1,maxn) $ do+ n <- range (1,maxn)+ let cdf = massToCdf $ do+ s <- range qbound+ return (s, maxentArray!(n,s) * finalWeights dfa!s)+ return (n,cdf)+-- | Like sampleWord but generates multiple words. Length distribution is specified as a 'Cdf' and number of words to generate.+sampleWordSalad :: (RandomGen g, Ix sigma, MonadState g m) => DFST Int sigma Double -> Cdf Length -> Int -> m [[sigma]]+sampleWordSalad dfa lengthdist samples = mapM sampler wordlenlist+ where+ wordlen = uniformSample lengthdist samples+ maxn = maximum (fmap fst wordlen)+ sampler = sampleWord dfa maxn+ wordlenlist = wordlen >>= uncurry (flip replicate)
+ src/Text/PhonotacticLearner/PhonotacticConstraints.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, GeneralizedNewtypeDeriving, OverloadedStrings #-}++{-|+Module: Text.PhonotacticLearner.PhonotacticConstraints+Description: Description of phonological features and consrtraints.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Data structures and functions for working with phonological features and natural classes.++Feature tables are designed work with strings reperesented as lists of 'SegRef' indices into their internal segment lists, enabling processing with fast array lookups even with non-contiguous sets of segments.+-}++module Text.PhonotacticLearner.PhonotacticConstraints (+ -- * Phonological Features+ FeatureState(..), SegRef,++ FeatureTable(..), srBounds, ftlook,+ segsToRefs, refsToSegs,+ csvToFeatureTable,++ -- * Natural Classes+ NaturalClass(..), classToSeglist,+ GlobReps(..), ClassGlob(..), classesToLists,++ cgMatchCounter+) where++import Text.PhonotacticLearner.Util.Ring+import Text.PhonotacticLearner.Util.Probability+import Text.PhonotacticLearner.MaxentGrammar+import Text.PhonotacticLearner.DFST++import Text.CSV+import Data.Array.IArray+import Data.Maybe+import Data.Tuple+import Data.List+import Data.Char+import Data.Monoid+import Control.Monad+import Control.Applicative hiding (many, some)+import Control.DeepSeq+import Control.Arrow((***),(&&&),first,second)+import qualified Data.Text as T+import qualified Data.Map.Lazy as M+import Text.ParserCombinators.ReadP+import Text.Read(Read(..),lift,parens)+++-- | Enumeration for feature states (can be +,-,0)+data FeatureState = FOff | FPlus | FMinus deriving (Enum, Eq, Ord, Read, Show)+instance NFData FeatureState where+ rnf fs = fs `seq` ()++-- | Indices for segment lookup table+newtype SegRef = Seg Int deriving (Eq, Ord, Read, Show, Ix, NFData)++-- | Type for phonological feature table. Segments and features are referred to by indices so this structure includes lookup tables for those.+data FeatureTable sigma = FeatureTable { featTable :: Array (SegRef,Int) FeatureState+ , featNames :: Array Int T.Text+ , segNames :: Array SegRef sigma+ , featLookup :: M.Map T.Text Int+ , segLookup :: M.Map sigma SegRef } deriving (Show)++-- | Bounds for segment references+srBounds :: FeatureTable sigma -> (SegRef, SegRef)+srBounds ft = bounds (segNames ft)+{-# INLINE srBounds #-}++-- | Shortcut for feature table array access+ftlook :: FeatureTable sigma -> SegRef -> Int -> FeatureState+ftlook ft sr fi = featTable ft ! (sr,fi)+{-# INLINE ftlook #-}++-- | Convert a string of raw segments to a string of 'SegRef's+segsToRefs :: (Ord sigma) => FeatureTable sigma -> [sigma] -> [SegRef]+segsToRefs ft = mapMaybe (\x -> M.lookup x (segLookup ft))++-- | Convert a string of 'SegRef's back to segments+refsToSegs :: FeatureTable sigma -> [SegRef] -> [sigma]+refsToSegs ft = fmap (segNames ft !) . filter (inRange (srBounds ft))++-- | List of all features in table+allFeatures :: FeatureTable sigma -> [T.Text]+allFeatures ft = elems (featNames ft)+++++lstrip :: String -> String+lstrip (' ':xs) = lstrip xs+lstrip ('\t':xs) = lstrip xs+lstrip xs = xs++{- |+Parse feature table from CSV.++To use a feature table other than the default IPA one, you may define it in CSV format (RFC 4180). The segment names are defined by the first row (they may be any strings as long as they are all distinct, i.e. no duplicate names) and the feature names are defined by the first column (they are not hard-coded). Data cells should contain @+@, @-@, or @0@ for binary features and @+@ or @0@ for privative features (where we do not want a minus set that could form classes).++As a simple example, consider the following CSV file, defining three segments (a, n, and t), and two features (vowel and nasal).++> ,a,n,t+> vowel,+,-,-+> nasal,0,+,-++If a row contains a different number of cells (separated by commas) than the header line, is rejected as invalid and does not define a feature (and will not be dispayed in the formatted feature table). If the CSV which is entered has duplicate segment names, no segments, or no valid features, the entire table is rejected (indicated by a red border around the text area, green is normal) and the last valid table is used and displayed.+-}+csvToFeatureTable :: (Ord sigma) => (String -> sigma) -> String -> Maybe (FeatureTable sigma)+csvToFeatureTable readSeg rawcsv = do+ Right parsedcsv <- return (parseCSV "" rawcsv)+ ((_:segcells) : rawfeatrecs) <- return (fmap (fmap lstrip) parsedcsv)+ let numsegs = length segcells+ guard (numsegs > 0)+ let seglist = listArray (Seg 1, Seg numsegs) (fmap readSeg segcells)+ featrecs = filter (\xs -> length xs == numsegs + 1) rawfeatrecs+ numfeats = length featrecs+ guard (numfeats > 0)+ let featlist = listArray (1, numfeats) (fmap (T.pack . head) featrecs)+ ft = array ((Seg 1,1), (Seg numsegs, numfeats)) $ do+ (featidx, _:featdata) <- zip [1..] featrecs+ (segidx, segfield) <- zip (fmap Seg [1..]) featdata+ let fstate = case segfield of+ "+" -> FPlus+ "✓" -> FPlus+ "√" -> FPlus+ "-" -> FMinus+ "−" -> FMinus+ _ -> FOff+ return ((segidx, featidx), fstate)+ let segmap = M.fromList (fmap swap (assocs seglist))+ featmap = M.fromList (fmap swap (assocs featlist))+ guard (M.size segmap == rangeSize (bounds seglist))+ return (FeatureTable ft featlist seglist featmap segmap)+++--------------------------------------------------------------------------------++-- | Representation of a natural class as a list of features and their states. Can ahso handle inverted classes.+data NaturalClass = NClass { isInverted :: Bool+ , featureList :: [(FeatureState, T.Text)]+ } deriving (Eq, Ord)+instance NFData NaturalClass where+ rnf c@(NClass b fs) = b `seq` rnf fs++-- | Uses SPE format+instance Show NaturalClass where+ show (NClass isNegated feats) = (if isNegated then "[¬ " else "[") ++ unwords (fmap showfeat feats) ++ "]"+ where showfeat (fs, fn) = (case fs of+ FPlus -> "+"+ FMinus -> "−"+ FOff -> "0")+ ++ T.unpack fn++isPrintNelem :: String -> Char -> Bool+isPrintNelem s c = isPrint c && not (isSpace c) && c `notElem` s++featP :: ReadP (FeatureState, T.Text)+featP = do+ skipSpaces+ state <- choice [FPlus <$ char '+', FPlus <$ char '✓', FPlus <$ char '√', FMinus <$ char '-', FMinus <$ char '−', FOff <$ char '0'] <++ return FPlus+ feat <- (:) <$> satisfy (isPrintNelem "0123456789+-√−✓(){}[]¬^") <*> munch (isPrintNelem "(){}[]¬^")+ return (state, T.pack feat)++classP = between (char '[') (char ']') (NClass+ <$> ((True <$ char '¬') +++ (True <$ char '^') +++ return False)+ <*> many featP)++instance Read NaturalClass where+ readPrec = parens (lift (skipSpaces >> classP))++++xor :: Bool -> Bool -> Bool+xor False p = p+xor True p = not p++-- | Convert a class to a 'SegSet'+classToSeglist :: FeatureTable sigma -> NaturalClass -> SegSet SegRef+classToSeglist ft (NClass isNegated cls) = force $ fnArray (srBounds ft) (\c -> isNegated `xor` and [ftlook ft c fi == fs | (fs,fi) <- icls])+ where icls = do+ (s,fn) <- cls+ Just fi <- return (M.lookup fn (featLookup ft))+ return (s,fi)++-- | Globs using 'NaturalClass' instead of 'SegSet'+data ClassGlob = ClassGlob Bool Bool [(GlobReps, NaturalClass)] deriving (Eq, Ord)+instance NFData ClassGlob where+ rnf (ClassGlob isinit isfin gparts) = isinit `seq` isfin `seq` rnf gparts++-- | Uses SPE format+instance Show ClassGlob where+ show (ClassGlob isinit isfin parts) = (guard isinit >> "#") ++ (showGP =<< parts) ++ (guard isfin >> "#") where+ showGP (GStar, NClass False []) = "…"+ showGP (rep, NClass False [(FPlus,"syllabic")]) = "V" ++ suf rep+ showGP (rep, NClass False [(FMinus,"syllabic")]) = "C" ++ suf rep+ showGP (rep, c) = show c ++ suf rep+ suf GSingle = ""+ suf GPlus = "₁"+ suf GStar = "₀"++globRepsP :: ReadP GlobReps+globRepsP = choice [GPlus <$ char '+', GPlus <$ char '₁', GStar <$ char '*', GStar <$ char '₀', return GSingle]++classGlobP :: ReadP ClassGlob+classGlobP = do+ isinit <- (True <$ char '#') +++ return False+ gparts <- many1 $ ((GStar, NClass False []) <$ char '…') +++ do+ cls <- classP +++ (NClass False [(FPlus,"syllabic")] <$ char 'V') +++ (NClass False [(FMinus,"syllabic")] <$ char 'C')+ rep <- globRepsP+ return (rep,cls)+ isfin <- (True <$ char '#') +++ return False+ return (ClassGlob isinit isfin gparts)++instance Read ClassGlob where+ readPrec = parens (lift (skipSpaces >> classGlobP))++-- | Convert to a 'ListGlob'+classesToLists :: FeatureTable sigma -> ClassGlob -> ListGlob SegRef+classesToLists ft (ClassGlob isinit isfin gparts) = ListGlob isinit isfin (fmap (second (classToSeglist ft)) gparts)++-- | Create a DFST which counts the matches of the glob.+cgMatchCounter :: FeatureTable sigma -> ClassGlob -> ShortDFST SegRef+cgMatchCounter ft = matchCounter . classesToLists ft
+ src/Text/PhonotacticLearner/PhonotacticConstraints/Generators.hs view
@@ -0,0 +1,144 @@+{-|+Module: Text.PhonotacticLearner.PhonotacticConstraints.Generators+Description: Generation of candidate constraint sets.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Functions for generating sets of candidate constraint sets.+For efficiency, classes are reperesented as @('NaturalClass', 'SegSet' 'SegRef')@ pairs and+constraints are output as @('ClassGlob', 'ListGlob' 'SegRef')@ pairs, avoiding the need for repeated conversions and copying of classes.++The 'classesByGenreraity' function enumerates the classes defined by a feature table in a sensible order, removing duplicate descriptions of the same class. The ug functions then take these classes and then combine them imto globs in various ways.++-}++module Text.PhonotacticLearner.PhonotacticConstraints.Generators (+ ngrams,+ classesByGenerality,+ ugSingleClasses, ugBigrams,+ ugEdgeClasses, ugEdgeBigrams,+ ugLimitedTrigrams, ugLongDistance,++ ugHayesWilson,+) where++import Text.PhonotacticLearner.PhonotacticConstraints+import Text.PhonotacticLearner.DFST+import Data.List+import Data.Array.IArray+import qualified Data.Map as M+import Control.Monad+import Control.DeepSeq++-- | Given a number n and a sequence, returns all subsewuences of length n.+ngrams :: Int -> [a] -> [[a]]+ngrams 0 _ = [[]]+ngrams _ [] = []+ngrams n (x:xs) = fmap (x:) (ngrams (n-1) xs) ++ ngrams n xs++-- | Enumerate all classes (and their inverses) to a certain number of features+-- in descending order of the number of segments the uninverted class contains.+-- Discards duplicates (having the same set of segments).+--+-- Each segment is returned as a tripple with the (negated for sorting) numbet of segments in the class, the class label, and the set of segments it contains.+classesByGenerality :: FeatureTable sigma -> Int -> [(Int, (NaturalClass, SegSet SegRef))]+classesByGenerality ft maxfeats = force $ fmap (\((ns, cs), c) -> (ns,(c,cs))) (M.assocs cls)+ where+ cls = M.fromListWith (const id) $ do+ isInv <- [False,True]+ nf <- range (0, maxfeats)+ fs <- ngrams nf (elems (featNames ft))+ c <- fmap (NClass isInv) . forM fs $ \f -> [(FPlus,f), (FMinus,f)]+ let cs = classToSeglist ft c+ let ns = length . filter id . elems $ cs+ guard (ns /= 0)+ return ((negate ns, cs), c)++-- | Given a set of classes, return a set of globs matching those classes.+ugSingleClasses :: [(Int, (NaturalClass, SegSet SegRef))] -> [(ClassGlob, ListGlob SegRef)]+ugSingleClasses cls = fmap snd . sortOn fst $ do+ (w,(c,l)) <- cls+ guard (not (isInverted c))+ let g = ClassGlob False False [(GSingle,c)]+ lg = ListGlob False False [(GSingle,l)]+ return (w,(g,lg))++-- Given a set of classes, return a set of globs matching those globs at word boundaries. At most one class may be inverted.+ugEdgeClasses :: [(Int, (NaturalClass, SegSet SegRef))] -> [(ClassGlob, ListGlob SegRef)]+ugEdgeClasses cls = fmap snd . sortOn fst $ do+ (w,(c,l)) <- cls+ guard (not (isInverted c))+ (isinit,isfin) <- [(False,True),(True,False)]+ let g = ClassGlob isinit isfin [(GSingle,c)]+ lg = ListGlob isinit isfin [(GSingle,l)]+ return (w,(g,lg))++-- | Given a set of classes, return a set pf globs matching class pairs, ordered by total weight. At most one class may be inverted.+ugBigrams :: [(Int, (NaturalClass, SegSet SegRef))] -> [(ClassGlob, ListGlob SegRef)]+ugBigrams cls = fmap snd . sortOn fst $ do+ (w1,(c1,l1)) <- cls+ (w2,(c2,l2)) <- cls+ guard (not (isInverted c1 && isInverted c2))+ let g = ClassGlob False False [(GSingle,c1),(GSingle,c2)]+ lg = ListGlob False False [(GSingle,l1),(GSingle,l2)]+ return (w1+w2,(g,lg))++-- | Given a set of classes, return a set pf globs matching class pairs at word boundaries, ordered by total weight. At most one class may be inverted.+ugEdgeBigrams :: [(Int, (NaturalClass, SegSet SegRef))] -> [(ClassGlob, ListGlob SegRef)]+ugEdgeBigrams cls = fmap snd . sortOn fst $ do+ (w1,(c1,l1)) <- cls+ (w2,(c2,l2)) <- cls+ guard (not (isInverted c1 && isInverted c2))+ (isinit,isfin) <- [(False,True),(True,False)]+ let g = ClassGlob isinit isfin [(GSingle,c1),(GSingle,c2)]+ lg = ListGlob isinit isfin [(GSingle,l1),(GSingle,l2)]+ return (w1+w2,(g,lg))++-- | Given a set of classes ansd a smaller subset, return a set of globs matching trigrams of classes from the set where at least one class is contained in the subset. At most one class may be inverted.+ugLimitedTrigrams :: [(Int, (NaturalClass, SegSet SegRef))] -> [(NaturalClass, SegSet SegRef)] -> [(ClassGlob, ListGlob SegRef)]+ugLimitedTrigrams cls rcls = fmap snd . sortOn fst $ do+ (w1,(c1,l1)) <- cls+ (w2,(c2,l2)) <- cls+ (w,(c3,l3)) <- case () of+ () | (c1,l1) `elem` rcls -> do+ (w3,(c3',l3')) <- cls+ guard (not (isInverted c2 && isInverted c3'))+ return (w2+w3, (c3',l3'))+ | (c2,l2) `elem` rcls -> do+ (w3,(c3',l3')) <- cls+ guard (not (isInverted c1 && isInverted c3'))+ return (w1+w3, (c3',l3'))+ | otherwise -> do+ guard (not (isInverted c1 && isInverted c2))+ (c3',l3') <- rcls+ return (w1+w2, (c3',l3'))+ let g = ClassGlob False False [(GSingle,c1),(GSingle,c2),(GSingle,c3)]+ lg = ListGlob False False [(GSingle,l1),(GSingle,l2),(GSingle,l3)]+ return (w, (g,lg))++-- | Given two sets of classes, return globs matching a pair oc slasses in the first set separated by any number of occurrences of a class in the second set. At most one class may be inverted. At most one class may be inverted.+-- This can lead to fairly large grammar DFAs when multiple such constraints are merged.+ugLongDistance :: [(Int, (NaturalClass, SegSet SegRef))] -> [(NaturalClass, SegSet SegRef)] -> [(ClassGlob, ListGlob SegRef)]+ugLongDistance cls rcls = fmap snd . sortOn fst $ do+ (w1,(c1,l1)) <- cls+ (c2,l2) <- rcls+ (w3,(c3,l3)) <- cls+ let w = w1+w3+ g = ClassGlob False False [(GSingle,c1),(GPlus,c2),(GSingle,c3)]+ lg = ListGlob False False [(GSingle,l1),(GPlus,l2),(GSingle,l3)]+ return (w, (g,lg))++{-ugMiddleHayesWilson :: [(Int, NaturalClass,SegSet SegRef)] -> [(NaturalClass,SegSet SegRef)] -> [(ClassGlob, ListGlob SegRef)]+ugMiddleHayesWilson cls rcls = join [ ugSingleClasses cls+ , ugBigrams cls+ , ugLimitedTrigrams cls rcls]+-}++-- | Combine the above functions (not including 'ugLongDistance') into the original candidate generator from the Hayes and Wilson paper.+ugHayesWilson :: [(Int, (NaturalClass, SegSet SegRef))] -> [(NaturalClass, SegSet SegRef)] -> [(ClassGlob, ListGlob SegRef)]+ugHayesWilson cls rcls = join [ ugSingleClasses cls+ , ugEdgeClasses cls+ , ugBigrams cls+ , ugEdgeBigrams cls+ , ugLimitedTrigrams cls rcls]
+ src/Text/PhonotacticLearner/Util/ConjugateGradient.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE ScopedTypeVariables, ExplicitForAll, BangPatterns #-}++{-|+Module: Text.PhonotacticLearner.Util.ConjugateGradient+Description: Line search and Conjugate Gradient Search.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Implementations of line search and conjugate gradient search for minimization. Line search uses Illinois False Position.+-}++module Text.PhonotacticLearner.Util.ConjugateGradient (+ traceInline, regulaFalsiSearch, conjugateGradientSearch,++ -- llpOptimizeWeights+) where++import qualified Data.Map as M+import Data.List+import Data.Ix+import Debug.Trace+import qualified Data.Vector.Unboxed as V+import System.IO+import System.IO.Unsafe+import Numeric+import Data.Array.IArray+--import Text.PhonotacticLearner.WeightedDFA+--import Text.PhonotacticLearner.Util.Probability+import Text.PhonotacticLearner.Util.Ring+--import Text.PhonotacticLearner.MaxentGrammar++-- using conjugate gradient method ad described by Shewchuk in+-- "An Introduction to the Conjugate Gradient Method Without the Agonizing Pain"+++-- length of starting guess for line search+rfInitSigma :: Double+rfInitSigma = 0.05++-- | Version of 'trace' which does not output a trailing linebreak. Good for progress bars.+traceInline :: String -> a -> a+traceInline s x = unsafePerformIO $ do+ hPutStr stderr s+ hFlush stderr+ return x++-- | Line search minimization using a modified Illinois False Position method.+--+-- Adapted from description at https://en.wikipedia.org/wiki/False_position_method+regulaFalsiSearch :: Double -- ^ stoping threshold uncertainty+ -> (Vec -> Vec -> Double) -- ^ derivative of function to minimize+ -> Vec -- ^ starting point+ -> Vec -- ^ direction to search in+ -> Vec -- ^ minimum point+regulaFalsiSearch epsilon f' xinit sdir = if (dxinit > 0) then xinit else pos (rfs a1 a2 0)+ where+ dir = normalizeVec sdir+ dxinit = f' xinit dir+ pos :: Double -> Vec+ pos alpha = xinit ⊕ (alpha ⊙ dir)+ doublingSearch = [(a, f' (pos a) dir) | a <- iterate (*2) rfInitSigma]+ (a1,a2) = head (filter (\((_,dx),(_,dy)) -> (dx <= 0) && (dy >= 0)) (zip ((0, dxinit):doublingSearch) doublingSearch))+ secant (!x,!dx) (!y,!dy) = (x*dy - y*dx) / (dy - dx)+ rfs :: (Double, Double) -> (Double, Double) -> Int -> Double+ rfs (!x,!dx) (!y,!dy) !bal+ | (dx == 0) = x+ | (dy == 0) = y+ | ((y-x) < epsilon) = secant (x,dx) (y,dy)+ | (dz <= 0) = {-traceShow (x,y, dx, dy, bal) $-} rfs (z,dz) (y,dy) (min bal 0 - 1)+ | otherwise = {-traceShow (x,y, dx, dy, bal) $-} rfs (x,dx) (z,dz) (max bal 0 + 1)+ where+ sy = if bal <= (-2) then (0.707 ^ negate bal) else 1+ sx = if bal >= 2 then (0.707 ^ bal) else 1+ z = (secant (x, sx*dx) (y, sy*dy))+ dz = f' (pos z) dir++-- | Nonlinear conjugate gradient search using Polak-Ribière method.+-- Stopping condition is two steps both havong a delta below the threshold.+conjugateGradientSearch :: Bool -- ^ trace progress to 'stderr' if true+ -> (Double, Double) -- ^ stopping thresholds for conjugate gradient step and line search+ -> (Vec -> (Vec, Bool)) -- ^ function to project points back into area defined by inequality constraints+ -- (for unconstrained problems use @(\x->(x,False))@)+ -> (Vec -> (Double, Vec)) -- ^ function to minimize, returns value and gradient+ -> (Vec -> Vec -> Double) -- ^ partial derivative of function to minimize+ -> Vec -- ^ starting point+ -> Vec -- ^ minimum point+conjugateGradientSearch shouldtrace (e1, e2) conproj fstar f' start = cjs dims (start ⊕ vec [2*e1]) zero zero start+ where -- fake last step triggers restart and aviods stopping condition+ opttrace = if shouldtrace then traceInline else const id+ dims = length (coords start)+ cjs :: Int -> Vec -> Vec -> Vec -> Vec -> Vec+ cjs !bal !oldx !olddir !oldgrad !x = if normVec (oldx ⊖ x) < e1 || normVec (x ⊖ newx) < e1 -- two steps small enough+ then newx+ else cjs nbal' x sdir grad newx'+ where+ (v,grad) = fstar x+ beta' = innerProd grad (grad ⊖ oldgrad) / innerProd oldgrad oldgrad --Polak-Ribière+ (beta, nbal) = if (bal >= dims || beta' <= 0) then (0,0) else (beta', bal + 1)+ sdir = (beta ⊙ olddir) ⊖ grad+ newx = opttrace (if beta <= 0 then "+" else "-") $ regulaFalsiSearch e2 f' x sdir+ (newx', iscorr) = conproj newx+ nbal' = if iscorr then dims else nbal
+ src/Text/PhonotacticLearner/Util/Probability.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, GeneralizedNewtypeDeriving #-}++{-|+Module: Text.PhonotacticLearner.Util.Probability+Description: Data structures and functions for counting and probability.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++Data structures and functions for counting and probability.+-}++module Text.PhonotacticLearner.Util.Probability (+ -- * Counting+ Multicount (..),+ getCounts, consMC, singleMC, fromMC,+ -- * Expectations+ Expectation(..),+ normalizeExp,+ -- * Sampling and Distributions+ Cdf, massToCdf, sampleCdf, uniformSample,+ upperConfidenceOE+) where++import Text.PhonotacticLearner.Util.Ring+--import Data.List+import Data.Tuple+import Data.Monoid+import qualified Data.Map as M+import System.Random+import Control.Monad.State+import qualified Data.Vector.Unboxed as V+import Control.DeepSeq++-- | Monoid holding a list of integer counters which are summed independently+newtype Multicount = MC {unMC :: V.Vector Int} deriving (Eq, Show, NFData)++-- | Return the counts as a list of 'Int's+getCounts :: Multicount -> [Int]+getCounts (MC xs) = V.toList xs++instance Monoid Multicount where+ mempty = MC V.empty+ mappend (MC xs) (MC ys)+ | V.null xs = MC ys+ | V.null ys = MC xs+ | lx == ly = MC (V.zipWith (+) xs ys)+ | lx < ly = MC (V.zipWith (+) xs (V.take lx ys) V.++ V.drop lx ys)+ | ly < lx = MC (V.zipWith (+) ys (V.take ly xs) V.++ V.drop ly xs)+ where lx = V.length xs+ ly = V.length ys++-- | Add a new count to the head of the list+consMC :: Sum Int -> Multicount -> Multicount+consMC (Sum x) (MC xs) = MC (V.cons x xs)++-- | Use a single coutner as a Multicount.+singleMC :: Sum Int -> Multicount+singleMC (Sum x) = MC (V.singleton x)++-- | Convert the counts to coordinates+fromMC :: Multicount -> Vec+fromMC (MC xs) = Vec (V.map fromIntegral xs)+++--------------------------------------------------------------------------------++{-| Expectation semiring as described by Eisner.++Represents an events contribution to the total expectation of a vector-valued variable. Addition takes the union of mutually exclusive events and multiplication either takes the intersection fo independent events or applies a conditional probability.++As a simple example, the expectation of the total value from rolling a 2 on a 6 sided die would be @Exp (1/6) (2/6)@.+-}+data Expectation v = Exp {+ prob :: {-# UNPACK #-} !Double -- ^ Probability of event occuring.+ , exps :: !v -- ^ Event's contribution to expectation of the variable+} deriving (Eq, Show)++-- combine exclusive events+instance (RingModule Double v) => Additive (Expectation v) where+ zero = Exp 0 zero+ (Exp p1 v1) ⊕ (Exp p2 v2) = Exp (p1 + p2) (v1 ⊕ v2)++-- intersect independent events or combine event with conditional probability+instance (RingModule Double v) => Semiring (Expectation v) where+ one = Exp 1 zero+ (Exp p1 v1) ⊗ (Exp p2 v2) = Exp (p1 * p2) ((p1 ⊙ v2) ⊕ (p2 ⊙ v1))++-- | Get the expectation conditional on the event actually occurring.+normalizeExp :: (RingModule Double v) => Expectation v -> v+normalizeExp (Exp p vs) = (1/p) ⊙ vs+++--------------------------------------------------------------------------------++-- | Cumulative distribution table that can be sampled easily.+newtype Cdf a = Cdf (M.Map Double a) deriving Show++-- | Generate a CDF which from a list of outcomes and their relative probabilities (their sum will eb normalized and does not have to be 1).+massToCdf :: [(a, Double)] -> Cdf a+massToCdf xs = Cdf (M.fromList (zip partialsums (fmap fst xs')))+ where+ xs' = filter ((/=0) . snd) xs+ totalp = sum (fmap snd xs)+ partialsums = scanl (+) 0 (fmap ((/ totalp) . snd) xs')++-- | Sample a random variable according to a 'Cdf', gets the random generator state from the monad.+sampleCdf :: (RandomGen g, MonadState g m) => Cdf a -> m a+sampleCdf (Cdf cdm) = do+ y :: Double <- state (randomR (0,1))+ let (Just (_,x)) = M.lookupLE y cdm+ return x++-- | Deterministically sample n points spaced throughout the distribution. Used when the number of samples greatly outnumbers the number of outcomes.+uniformSample :: Cdf a -> Int -> [(a, Int)]+uniformSample (Cdf cmf) n = zipWith subentries (tail breaks ++ [(undefined, n)]) breaks+ where+ breaks = fmap (fmap (round . (n ⊙)) . swap) . M.assocs $ cmf+ subentries (_,cx) (y,cy) = (y,cx-cy)++--------------------------------------------------------------------------------++-- | Get the upper confidence bound of Observed/Expected+upperConfidenceOE :: Double -> Double -> Double+upperConfidenceOE o e = if p >= 1 then 1 else min 1 (p + 3*v)+ where+ p = (o + 0.5) / (e+1)+ v = sqrt (p * (1-p) / (e+1))
+ src/Text/PhonotacticLearner/Util/Ring.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++{-|+Module: Text.PhonotacticLearner.Util.Ring+Description: Classes for rings and modules and data type for ℝ*.+Copyright: © 2016-2017 George Steel and Peter Jurgec+License: GPL-2++Maintainer: george.steel@gmail.com++This module provides a hierarchy of typeclasses to describe rings and their substructures without all of the additional structure found in 'Num' (which does not apply to most rings). 'Num' instances are automatically 'Ring' instances if no explicit instance is given, making 'Ring' a drop-in replacenent for 'Num' to make more generic functions.++A typeclass for algebraic modules (aka. vector spaces if over a field) is also included as well as a data type for the vector space ℝ[x]=ℝ∪ℝ²∪ℝ³∪… (usable for ℝⁿ although dimensions are not checked).++In order to not clash with Num or Arrow, this module uses the unicode circled operators '⊕', '⊖', '⊗', and '⊙'. If you are using XIM (Linux) or WinCompose, add the following lines to your .XCompose file:++> <Multi_key> <r> <plus> : "⊕"+> <Multi_key> <r> <period> : "⊙"+> <Multi_key> <r> <asterisk> : "⊗"+> <Multi_key> <r> <minus> : "⊖"+-}+module Text.PhonotacticLearner.Util.Ring (+ -- * Rings+ Additive(..)+ , AdditiveGroup(..)+ , Semiring(..)+ , Ring+ , RSum(..), RProd(..)+ , sumR, productR+ -- * Modules and vectors+ , RingModule(..)+ , Vec(..), coords, fromInts, vec+ , innerProd, normVec, normalizeVec, consVec+ , l1Vec, dl1Vec+ , showFVec+ ) where++import Numeric+import qualified Data.Vector.Unboxed as V+import Control.DeepSeq+import Data.Monoid++-- | Monoids with additive syntax+class Additive g where+ zero :: g -- ^ Additive identity+ (⊕) :: g -> g -> g -- ^ Addition++-- | Additive groups with inverses and suntraction+class (Additive g) => AdditiveGroup g where+ addinv :: g -> g -- ^ Additive inverse, more general version of 'negate'+ (⊖) :: g -> g -> g -- ^ Subtraction+ x ⊖ y = x ⊕ addinv y++-- | Semirings with addition and multiplication (but not subtraction).+class (Additive r) => Semiring r where+ one :: r -- ^ Multiplicative identity+ (⊗) :: r -> r -> r -- ^ Multiplication++-- | Rings have both subtraction and multiplication+class (Semiring r, AdditiveGroup r) => Ring r++-- | A module over a 'Ring' r is an 'AdditiveGroup' which can be multiplied by scalars in r.+class (Ring r, AdditiveGroup v) => RingModule r v where+ (⊙) :: r -> v -> v -- ^ Scalar multiplication++-- | Every Ring is a module over itself.+instance (Ring r) => RingModule r r where+ (⊙) = (⊗)+--------------------------------------------------------------------------------++-- trivial ring+instance Additive () where+ zero = ()+ () ⊕ () = ()+instance Semiring () where+ one = ()+ () ⊗ () = ()+instance AdditiveGroup () where+ addinv () = ()+ () ⊖ () = ()+instance Ring ()++-- Boolean semiring+instance Additive Bool where+ zero = False+ (⊕) = (||)+instance Semiring Bool where+ one = True+ (⊗) = (&&)++-- make a superclass of Num+instance {-# OVERLAPPABLE #-} (Num r) => Additive r where+ zero = 0+ (⊕) = (+)+instance {-# OVERLAPPABLE #-} (Num r) => Semiring r where+ one = 1+ (⊗) = (*)+instance {-# OVERLAPPABLE #-} (Num r) => AdditiveGroup r where+ addinv = negate+ (⊖) = (-)+instance {-# OVERLAPPABLE #-} (Num r) => Ring r++++-- ring cartesian product+instance (Additive r, Additive s) => Additive (r,s) where+ zero = (zero,zero)+ (a,b) ⊕ (c,d) = (a ⊕ c, b ⊕ d)+instance (Semiring r, Semiring s) => Semiring (r,s) where+ one = (one,one)+ (a,b) ⊗ (c,d) = (a ⊗ c, b ⊗ d)+instance (AdditiveGroup r, AdditiveGroup s) => AdditiveGroup (r,s) where+ addinv (a,b) = (addinv a, addinv b)+ (a,b) ⊖ (c,d) = (a ⊖ c, b ⊖ d)+instance (Ring r, Ring s) => Ring (r,s)+++instance (RingModule r v, RingModule r w) => RingModule r (v,w) where+ a ⊙ (b,c) = (a ⊙ b, a ⊙ c)+++--------------------------------------------------------------------------------++-- | 'Monoid' wrapper using addition, same as 'Sum'+newtype RSum r = RSum r deriving (Ord, Eq, Show, Additive, AdditiveGroup, Semiring, Ring)++-- | 'Monoid' wrapper using multiplication, same as 'Product'+newtype RProd r = RProd r deriving (Ord, Eq, Show, Additive, AdditiveGroup, Semiring, Ring)++instance (Additive r) => Monoid (RSum r) where+ mempty = RSum zero+ (RSum a) `mappend` (RSum b) = RSum (a ⊕ b)++instance (Semiring r) => Monoid (RProd r) where+ mempty = RProd one+ (RProd a) `mappend` (RProd b) = RProd (a ⊗ b)++-- | Fold using addition+sumR :: (Foldable f, Additive r) => f r -> r+sumR xs = let (RSum x) = foldMap RSum xs in x++-- | Fold using multiplication+productR :: (Foldable f, Semiring r) => f r -> r+productR xs = let (RProd x) = foldMap RProd xs in x++--------------------------------------------------------------------------------++-- | Since ℝ is a module over ℤ, using scalar multiplication can save a lot of coersion noise.+instance RingModule Int Double where+ x ⊙ y = fromIntegral x * y++-- | Implements variable-length vectors. Addition batween vectors of different lengths occurs by letting ℝ⊆ℝ²⊆ℝ³⊆… by embedding each length in the space op polynomials.+newtype Vec = Vec {unVec :: V.Vector Double} deriving (Eq, Read, Show, NFData)++-- | Returns a list of coordinates.+coords :: Vec -> [Double]+coords (Vec xs) = V.toList xs++-- | Convert from a list of coordinates.+vec :: [Double] -> Vec+vec = Vec . V.fromList++-- | Convert from a list of integers.+fromInts :: [Int] -> Vec+fromInts xs = Vec . V.fromList . fmap fromIntegral $ xs++instance Additive Vec where+ zero = Vec V.empty+ (Vec xs) ⊕ (Vec ys)+ | V.null xs = Vec ys+ | V.null ys = Vec xs+ | lx == ly = Vec (V.zipWith (+) xs ys)+ | lx < ly = Vec (V.zipWith (+) xs (V.take lx ys) V.++ V.drop lx ys)+ | ly < lx = Vec (V.zipWith (+) ys (V.take ly xs) V.++ V.drop ly xs)+ where lx = V.length xs+ ly = V.length ys++instance AdditiveGroup Vec where+ addinv (Vec xs) = Vec (V.map negate xs)++instance RingModule Double Vec where+ a ⊙ (Vec xs) = Vec (V.map (a *) xs)+instance RingModule Int Vec where+ a ⊙ (Vec xs) = Vec (V.map (fromIntegral a *) xs)++-- | Standard inner product on ℝⁿ.+innerProd :: Vec -> Vec -> Double+innerProd (Vec xs) (Vec ys) = V.sum (V.zipWith (*) xs ys)++-- | Show a vector to a certain precision, equivalent of 'showFFloat'.+showFVec :: Maybe Int -> Vec -> String+showFVec prec (Vec xs) = "[" ++ (unwords . fmap (\x -> showFFloat prec x []) . V.toList $ xs) ++ "]"++-- | Calculate the euclidean norm of a vector.+normVec :: Vec -> Double+normVec x = sqrt (innerProd x x)++-- | Taxicab norm.+l1Vec :: Vec -> Double+l1Vec (Vec xs) = V.sum (V.map abs xs)++-- | Gradient of taxicab norm.+dl1Vec :: Vec -> Vec+dl1Vec (Vec xs) = Vec (V.map signum xs)++-- | Return a vector of unit length pointing in the same direction.+normalizeVec :: Vec -> Vec+normalizeVec x = if n == 0 then x else (1/n) ⊙ x+ where n = normVec x++-- | Add a number to the begining of the list of coordinates.+consVec :: Double -> Vec -> Vec+consVec x (Vec xs) = Vec (V.cons x xs)