diff --git a/NLP/Miniutter/English.hs b/NLP/Miniutter/English.hs --- a/NLP/Miniutter/English.hs +++ b/NLP/Miniutter/English.hs @@ -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" diff --git a/miniutter.cabal b/miniutter.cabal --- a/miniutter.cabal +++ b/miniutter.cabal @@ -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. diff --git a/test/test-miniutter.hs b/test/test-miniutter.hs --- a/test/test-miniutter.hs +++ b/test/test-miniutter.hs @@ -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" ]