miniutter 0.4.3.0 → 0.4.4.0
raw patch · 3 files changed
+128/−23 lines, 3 files
Files
- NLP/Miniutter/English.hs +60/−12
- miniutter.cabal +1/−1
- test/test-miniutter.hs +67/−10
NLP/Miniutter/English.hs view
@@ -10,6 +10,7 @@ import Data.Char (isAlphaNum, toUpper) import Data.Map (Map) import qualified Data.Map as Map+import Data.Monoid import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T@@ -17,7 +18,6 @@ import GHC.Generics (Generic) import NLP.Minimorph.English import NLP.Minimorph.Util hiding (showT, (<>))-import Data.Monoid ((<>)) -- | Various basic and compound parts of English simple present tense clauses. -- Many of the possible nestings do not make sense. We don't care.@@ -35,14 +35,20 @@ | WWxW !Part ![Part] -- ^ collection | Wown !Part -- ^ non-premodifying possesive | WownW !Part !Part -- ^ attributive possesive+ | Append !Part !Part -- ^ no space in between+ | !Part :> !Part -- ^ no space in between -- deprecated, use <> | Phrase ![Part] -- ^ space-separated sequence- | !Part :> !Part -- ^ no space in between | Capitalize !Part -- ^ make the first letter into a capital letter | SubjectVerb !Person !Polarity !Part !Part -- ^ conjugation according to polarity, -- with a default person (pronouns override it) | SubjectVerbSg !Part !Part -- ^ a shorthand for Sg3rd and Yes+ | SubjectVVxV !Part !Person !Polarity !Part ![Part]+ -- ^ conjugation of all verbs according to polarity,+ -- with a default person (pronouns override it)+ | SubjectVVandVSg !Part ![Part]+ -- ^ a shorthand for "and", Sg3rd and Yes deriving (Show, Eq, Ord, Generic) instance Binary Part@@ -53,6 +59,10 @@ instance IsString Part where fromString = Text . T.pack +instance Monoid Part where+ mempty = Text ""+ mappend = Append+ -- | Persons: singular 1st, singular 3rd and the rest. data Person = Sg1st | Sg3rd | PlEtc deriving (Show, Eq, Ord, Generic)@@ -112,6 +122,7 @@ Wown p -> onLastWord nonPremodifying (mkPart p) WownW p1 p2 -> onLastWord attributive (mkPart p1) <+> mkPart p2 Phrase lp -> makePhrase irr lp+ Append p1 p2 -> mkPart p1 <> mkPart p2 p1 :> p2 -> mkPart p1 <> mkPart p2 Capitalize p -> capitalize $ mkPart p SubjectVerb defaultPerson Yes s v ->@@ -122,31 +133,50 @@ qSubjectVerb defaultPerson (mkPart s) (mkPart v) SubjectVerbSg s v -> subjectVerb Sg3rd (mkPart s) (mkPart v)+ SubjectVVxV x defaultPerson Yes s vs ->+ subjectVVxV (mkPart x) defaultPerson (mkPart s) (makeParts irr vs)+ SubjectVVxV x defaultPerson No s vs ->+ notSubjectVVxV (mkPart x) defaultPerson (mkPart s) (makeParts irr vs)+ SubjectVVxV x defaultPerson Why s vs ->+ qSubjectVVxV (mkPart x) defaultPerson (mkPart s) (makeParts irr vs)+ SubjectVVandVSg s vs ->+ subjectVVxV "and" Sg3rd (mkPart s) (makeParts irr vs) where mkPart = makePart irr onFirstWord :: (Text -> Text) -> Text -> Text onFirstWord f t =- let (starting, rest) = T.span isWordLetter t+ let (starting, restRaw) = T.span isWordLetter t+ rest = T.dropWhile (not . isWordLetter) restRaw+ fstarting = f starting in if T.null starting- then rest- else f starting <> rest+ then t+ else if T.null fstarting+ then rest+ else f starting <> restRaw onLastWord :: (Text -> Text) -> Text -> Text onLastWord f t = let (spanPrefix, spanRest) = T.span isWordLetter $ T.reverse t- (ending, rest) = (T.reverse spanPrefix, T.reverse spanRest)+ (ending, restRaw) = (T.reverse spanPrefix, T.reverse spanRest)+ rest = T.dropWhile (not . isWordLetter) restRaw+ fending = f ending in if T.null ending- then rest- else rest <> f ending+ then t+ else if T.null fending+ then rest+ else restRaw <> f ending onFirstWordPair :: (Text -> (Text, Text)) -> Text -> (Text, Text) onFirstWordPair f t =- let (starting, rest) = T.span isWordLetter t+ let (starting, restRaw) = T.span isWordLetter t+ rest = T.dropWhile (not . isWordLetter) restRaw+ (t1, t2) = f starting in if T.null starting- then (rest, "")- else let (t1, t2) = f starting- in (t1, t2 <> rest)+ then (t, "")+ else if T.null t2+ then (t1, rest)+ else (t1, t2 <> restRaw) isWordLetter :: Char -> Bool isWordLetter c = isAlphaNum c || c == '\'' || c == '-'@@ -205,6 +235,11 @@ subjectVerb defaultPerson s v = s <+> onFirstWord (personVerb $ guessPerson defaultPerson s) v +subjectVVxV :: Text -> Person -> Text -> [Text] -> Text+subjectVVxV x defaultPerson s vs =+ let conjugate = onFirstWord (personVerb $ guessPerson defaultPerson s)+ in s <+> commas x (map conjugate vs)+ notPersonVerb :: Person -> Text -> Text notPersonVerb Sg1st "be" = "am not" notPersonVerb PlEtc "be" = "aren't"@@ -228,6 +263,12 @@ notSubjectVerb defaultPerson s v = s <+> onFirstWord (notPersonVerb $ guessPerson defaultPerson s) v +notSubjectVVxV :: Text -> Person -> Text -> [Text] -> Text+notSubjectVVxV _ _ s [] = s+notSubjectVVxV x defaultPerson s (v : vs) =+ let vNot = onFirstWord (notPersonVerb $ guessPerson defaultPerson s) v+ in s <+> commas x (vNot : vs)+ qPersonVerb :: Person -> Text -> (Text, Text) qPersonVerb Sg1st "be" = ("am", "") qPersonVerb PlEtc "be" = ("are", "")@@ -251,6 +292,13 @@ qSubjectVerb defaultPerson s v = let (v1, v2) = onFirstWordPair (qPersonVerb $ guessPerson defaultPerson s) v in v1 <+> s <+> v2++qSubjectVVxV :: Text -> Person -> Text -> [Text] -> Text+qSubjectVVxV _ _ s [] = s+qSubjectVVxV x defaultPerson s (v : vs) =+ let (v1, v2) = onFirstWordPair (qPersonVerb $ guessPerson defaultPerson s) v+ glue = if T.null v2 then (<>) else (<+>)+ in v1 <+> s `glue` commas x (v2 : vs) nonPremodifying :: Text -> Text nonPremodifying "who" = "whose"
miniutter.cabal view
@@ -5,7 +5,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.4.3.0+version: 0.4.4.0 synopsis: Simple English clause creation from arbitrary words description: This library helps in generating simple present tense English sentences from short, parametrized descriptions.
test/test-miniutter.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import Data.Monoid import qualified Data.Text as T import Test.Framework (Test, defaultMain, testGroup)@@ -22,6 +23,7 @@ , testMakePhraseEnumeration , testMakePhrasePossesive , testMakePhraseSubjectVerb+ , testMakePhraseSubjectVVxV , testAllureOfTheStars ] ]@@ -58,8 +60,8 @@ , tp [MU.Phrase ["blue", ""]] "blue" , tp [MU.Phrase ["", "dog"]] "dog" , tp [MU.Phrase ["", ""]] ""- , tp [MU.Ordinal 0 MU.:> ", but", MU.Ordinal 1] "0th, but first"- , tp [MU.Cardinal 20 MU.:> MU.Cardinal 0] "200"+ , tp [MU.Ordinal 0 <> ", but", MU.Ordinal 1] "0th, but first"+ , tp [MU.Cardinal 20 <> MU.Cardinal 0] "200" , tp [MU.String " "] " " , tp [ " "] " " , tp [MU.String " blue ", MU.String " dog "] " blue dog "@@ -68,7 +70,7 @@ , testCase "testPhrase makeSentence and Capitalize" $ assertEqual "makeSentence == Capitalize makePhrase :> '.'" (MU.makePhrase MU.defIrregular- [MU.Capitalize (MU.SubjectVerbSg "goblin" "hit") MU.:> "."])+ [MU.Capitalize (MU.SubjectVerbSg "goblin" "hit") <> "."]) (MU.makeSentence MU.defIrregular [MU.SubjectVerbSg "goblin" "hit"]) ]@@ -183,12 +185,12 @@ , tp [MU.Ord 952] "952nd" , tp [MU.Ord 112] "112th" , tp [MU.Ord 712] "712th"- , tp [MU.Ord 5 MU.:> MU.Cardinal 1] "5thone"- , tp [MU.Ord 4 MU.:> MU.Ordinal 2] "4thsecond"- , tp [MU.Ord 4 MU.:> MU.Ord 7] "4th7th"- , tp [MU.Ord 4 MU.:> MU.CarWs 7 "dog"] "4th7 dogs"+ , tp [MU.Ord 5 <> MU.Cardinal 1] "5thone"+ , tp [MU.Ord 4 <> MU.Ordinal 2] "4thsecond"+ , tp [MU.Ord 4 <> MU.Ord 7] "4th7th"+ , tp [MU.Ord 4 <> MU.CarWs 7 "dog"] "4th7 dogs" , tp [MU.CardinalWs 4 (MU.CarWs 7 "dog")] "four 7 dogses"- , tp [MU.CarWs 4 (MU.Ord 7 MU.:> "elf")] "4 7thelves"+ , tp [MU.CarWs 4 (MU.Ord 7 <> "elf")] "4 7thelves" ] testMakePhraseIndefinite :: Test@@ -343,6 +345,61 @@ , tp [MU.SubjectVerb MU.PlEtc MU.No "She" "had had"] "She hadn't had" ] +testMakePhraseSubjectVVxV :: Test+testMakePhraseSubjectVVxV = testGroup "subject and many verbs"+ [ tp [MU.SubjectVVandVSg "species" ["look", "hook", "fly away", "have", "kiss"]] "species looks, hooks, flies away, has and kisses"+ , tp [MU.SubjectVVxV "or" MU.Sg1st MU.No "species" ["look", "hook", "fly away", "have", "kiss"]] "species don't look, hook, fly away, have or kiss"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "species" ["look", "hook", "fly away", "have", "kiss"]] "does species look, hook, fly away, have or kiss"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "species" ["look", "hook", "fly away", "have", "kiss"]] "species look, hook, fly away, have or kiss"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "species" ["look", "hook", "fly away", "have", "kiss"]] "species don't look, hook, fly away, have or kiss"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "species" ["look", "hook", "fly away", "have", "kiss"]] "do species look, hook, fly away, have or kiss"+ , tp [MU.SubjectVVandVSg "I" ["be", "have a hat", "be cool", "be", "may swim"]] "I am, have a hat, am cool, am and may swim"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.No "you" ["be", "have a hat", "be cool", "be", "may swim"]] "you aren't, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "she" ["be", "have a hat", "be cool", "be", "may swim"]] "is she, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "we" ["be", "have a hat", "be cool", "be", "may swim"]] "we are, have a hat, are cool, are or may swim"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "I" ["be", "have a hat", "be cool", "be", "may swim"]] "I am not, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "they" ["be", "have a hat", "be cool", "be", "may swim"]] "are they, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVandVSg "they" ["be", "have a hat", "be cool", "be", "may swim"]] "they are, have a hat, are cool, are and may swim"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.No "we" ["be", "have a hat", "be cool", "be", "may swim"]] "we aren't, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "it" ["be", "have a hat", "be cool", "be", "may swim"]] "is it, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "he" ["be", "have a hat", "be cool", "be", "may swim"]] "he is, has a hat, is cool, is or may swim"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "She" ["be", "have a hat", "be cool", "be", "may swim"]] "She isn't, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "You" ["be", "have a hat", "be cool", "be", "may swim"]] "are You, have a hat, be cool, be or may swim"+ , tp [MU.SubjectVVandVSg "Tom" ["have", "talk to Bob", "kiss Helen"]] "Tom has, talks to Bob and kisses Helen"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.No "cat" ["have", "talk to Bob", "kiss Helen"]] "cat doesn't have, talk to Bob or kiss Helen"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "they" ["have", "talk to Bob", "kiss Helen"]] "do they have, talk to Bob or kiss Helen"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "he" ["have", "talk to Bob", "kiss Helen"]] "he has, talks to Bob or kisses Helen"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "She" ["have", "talk to Bob", "kiss Helen"]] "She doesn't have, talk to Bob or kiss Helen"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "Foos" ["have", "talk to Bob", "kiss Helen"]] "do Foos have, talk to Bob or kiss Helen"+ , tp [MU.SubjectVVandVSg "Tom" ["do", "mean well"]] "Tom does and means well"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.No "cat" ["do", "mean well"]] "cat doesn't do or mean well"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "they" ["do", "mean well"]] "do they do or mean well"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "he" ["go"]] "he goes"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "She" ["go"]] "She doesn't go"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "Foos" ["go"]] "do Foos go"+ , tp [MU.SubjectVVandVSg "Tom" ["can"]] "Tom can"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.No "cat" ["could"]] "cat couldn't"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "they" ["must"]] "must they"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "he" ["will"]] "he will"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "She" ["would"]] "She wouldn't"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "Foos" ["shall"]] "shall Foos"+ , tp [MU.SubjectVVandVSg "Tom" ["should"]] "Tom should"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.No "cat" ["ought"]] "cat oughtn't"+ , tp [MU.SubjectVVxV "or" MU.Sg3rd MU.Why "they" ["may"]] "may they"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Yes "he" ["might"]] "he might"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "She" ["had"]] "She hadn't"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "it" ["copy down"]] "does it copy down"+ , tp [MU.SubjectVVandVSg "Tom" ["copy down"] ] "Tom copies down"+ , tp [MU.SubjectVVandVSg "Tom" ["buzz"]] "Tom buzzes"+ , tp [MU.SubjectVVandVSg "Tom" ["it it"]] "Tom its it"+ , tp [MU.SubjectVVandVSg "Tom" ["you you"]] "Tom yous you"+ , tp [MU.SubjectVVandVSg "You" ["you you"]] "You you you"+ , tp [MU.SubjectVVandVSg "She" ["do read"]] "She does read"+ , tp [MU.SubjectVVandVSg "She" ["do do"]] "She does do"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.Why "she" ["do"]] "does she do"+ , tp [MU.SubjectVVxV "or" MU.PlEtc MU.No "She" ["had had"]] "She hadn't had"+ ]+ tc :: [MU.Part] -> T.Text -> Test tc arg expect = testCase ("testSentence " ++ show arg)@@ -378,7 +435,7 @@ , MU.CarWs 1 "vial of rose water" ] "The magenta vial turns out to be a vial of rose water." , tc [ MU.SubjectVerbSg "deranged household robot" "trie to hit"- MU.:> ", but you block" ]+ <> ", but you block" ] "Deranged household robot tries to hit, but you block." , tc [ MU.SubjectVerbSg "deranged household robot" "hit" , "you" ]@@ -412,7 +469,7 @@ , "Haskell Alvin" ] "Deranged household robot hits Haskell Alvin." , tc [ MU.SubjectVerbSg "deranged household robot" "try to hit"- MU.:> ", but Haskell Alvin blocks" ]+ <> ", but Haskell Alvin blocks" ] "Deranged household robot tries to hit, but Haskell Alvin blocks." , tc [ MU.SubjectVerbSg "deformed monkey" "hit" , "deranged household robot" ]