diff --git a/NLP/Minimorph/English.hs b/NLP/Minimorph/English.hs --- a/NLP/Minimorph/English.hs +++ b/NLP/Minimorph/English.hs @@ -51,8 +51,21 @@ 8 -> "eight" 9 -> "nine" 10 -> "ten" - _ -> T.pack (show n) + _ -> showT n +-- | > ordinalNotSpelled 1 == "1st" +-- > ordinalNotSpelled 2 == "2nd" +-- > ordinalNotSpelled 11 == "11th" +ordinalNotSpelled :: Int -> Text +ordinalNotSpelled k = case abs k `rem` 100 of + n | n > 3 && n < 21 -> k `suf` "th" + | n `rem` 10 == 1 -> k `suf` "st" + | n `rem` 10 == 2 -> k `suf` "nd" + | n `rem` 10 == 3 -> k `suf` "rd" + | otherwise -> k `suf` "th" + where + num `suf` s = showT num <> s + -- | > ordinal 1 == "first" -- > ordinal 2 == "second" -- > ordinal 3 == "third" @@ -70,18 +83,13 @@ 8 -> "eighth" 9 -> "ninth" 10 -> "tenth" - n | n < 21 -> n `suf` "th" - | n `rem` 10 == 2 -> n `suf` "nd" - | n `rem` 10 == 3 -> n `suf` "rd" - | otherwise -> n `suf` "th" - where - n `suf` s = T.pack (show n) <> s + k -> ordinalNotSpelled k -- --------------------------------------------------------------------- -- ** Nouns and verbs -- --------------------------------------------------------------------- --- | Heuristics for English plural for an unknown noun +-- | Heuristics for English plural for an unknown noun. -- -- > defaultNounPlural "egg" == "eggs" -- > defaultNounPlural "patch" == "patches" @@ -90,44 +98,64 @@ -- > defaultNounPlural "thesis" == "theses" -- -- http://www.paulnoll.com/Books/Clear-English/English-plurals-1.html +-- http://en.wikipedia.org/wiki/English_plural defaultNounPlural :: Text -> Text defaultNounPlural x | "is" `T.isSuffixOf` x = thesis - | hasSibilantSuffix x = es - | hasCySuffix x = y_ies - | "f" `T.isSuffixOf` x = f_ves + | hasSibilantSuffix x = sibilant_o + | hasCoSuffix x = sibilant_o + | hasCySuffix x = y_final + | "f" `T.isSuffixOf` x = f_final | otherwise = plain where - plain = x <> "s" - es = x <> "es" - y_ies = T.init x <> "ies" - f_ves = T.init x <> "ves" - thesis = tDropEnd 2 x <> "es" + plain = x <> "s" + sibilant_o = x <> "es" + y_final = T.init x <> "ies" + f_final = T.init x <> "ves" + thesis = tDropEnd 2 x <> "es" -- | Heuristics for 3rd person singular and past participle --- for an unknown regular verb +-- for an unknown regular verb. Doubling of final consonants +-- can be handled via a table of (partially) irrefular verbs. -- -- > defaultVerbStuff "walk" == ("walks", "walked") -- > defaultVerbStuff "push" == ("pushes", "pushed") -- > defaultVerbStuff "play" == ("plays", "played") -- > defaultVerbStuff "cry" == ("cries", "cried") defaultVerbStuff :: Text -> (Text, Text) -defaultVerbStuff v - | hasSibilantSuffix v = sibilant_o v - | "o" `T.isSuffixOf` v = sibilant_o v - | "e" `T.isSuffixOf` v = e_final v - | hasCySuffix v = y_final v - | otherwise = plain v +defaultVerbStuff x + | hasSibilantSuffix x = sibilant_o + | hasCoSuffix x = sibilant_o + | hasCySuffix x = y_final + | "e" `T.isSuffixOf` x = e_final + | otherwise = plain where - plain x = (x <> "s" , x <> "ed") - sibilant_o x = (x <> "es" , x <> "ed") - e_final x = (x <> "s" , x <> "d") - y_final x = (T.init x <> "ies", T.init x <> "ied") + plain = (x <> "s" , x <> "ed") + sibilant_o = (x <> "es" , x <> "ed") + e_final = (x <> "s" , x <> "d") + y_final = (T.init x <> "ies", T.init x <> "ied") +-- | Heuristics for a possesive form for an unknown noun. +-- +-- > defaultPossesive "pass" == "pass'" +-- > defaultPossesive "SOS" == "SOS'" +-- > defaultPossesive "Mr Blinkin'" == "Mr Blinkin's" +-- > defaultPossesive "cry" == "cry's" +defaultPossesive :: Text -> Text +defaultPossesive t = + case T.last t of + 's' -> t <> "'" + 'S' -> t <> "'" + '\'' -> t <> "s" + _ -> t <> "'s" + -- --------------------------------------------------------------------- -- ** Determiners -- --------------------------------------------------------------------- +anNumerals :: [Text] +anNumerals = [ "11", "11th", "18", "18th" ] + -- | > indefiniteDet "dog" == "a" -- > indefiniteDet "egg" == "an" -- > indefiniteDet "ewe" == "a" @@ -137,22 +165,20 @@ indefiniteDet t = if wantsAn t then "an" else "a" -- | True if the indefinite determiner for a word would normally be --- 'an' as opposed to 'a' +-- 'an' as opposed to 'a'. wantsAn :: Text -> Bool wantsAn t_ = if startsWithAcronym t_ then acronymWantsAn t_ - else useAn0 || useAn1 || useAn2 + else useAn0 || useAn1 where - t = T.toLower t_ - useAn0 = t `elem` [ "11", "11th" ] + t = fst $ T.break isSep $ T.toLower t_ + useAn0 = t `elem` anNumerals useAn1 = case T.uncons t of Just ('8',_) -> True - Just (h,_) -> isVowel h `butNot` hasSemivowelPrefix t + Just (h, "") -> isLetterWithInitialVowelSound h + Just (h, _) -> isVowel h `butNot` hasSemivowelPrefix t Nothing -> False - useAn2 = case T.break isSep t of - (T.unpack -> [c], _) -> isLetterWithInitialVowelSound c - _ -> False x `butNot` y = x && not y isSep c = isSpace c || c `elem` "-" @@ -162,13 +188,13 @@ -- > wantsAn "x-ray" == False -- > acronymWantsAn "x-ray" == True -- --- Note that this won't do the right thing for words like @"SCUBA"@ --- You really have to reserve it for those separate-letter acronyms +-- Note that this won't do the right thing for words like @"SCUBA"@. +-- You really have to reserve it for those separate-letter acronyms. acronymWantsAn :: Text -> Bool acronymWantsAn (T.toLower -> t) = useAn0 || useAn1 where - useAn0 = t `elem` [ "11", "11th" ] + useAn0 = t `elem` anNumerals useAn1 = case T.uncons t of Just ('8',_) -> True Just (h,_) -> isLetterWithInitialVowelSound h @@ -178,16 +204,18 @@ -- ** Acronyms -- --------------------------------------------------------------------- --- | True if all upper case from second letter and up +-- | True if all upper case from second letter and up. -- -- > looksLikeAcronym "DNA" == True -- > looksLikeAcronym "tRNA" == True +-- > looksLikeAcronym "x" == False -- > looksLikeAcronym "DnA" == False looksLikeAcronym :: Text -> Bool -looksLikeAcronym x = T.all isUpper (T.drop 1 x) +looksLikeAcronym "" = False +looksLikeAcronym x = T.all isUpper (if T.length x > 1 then T.drop 1 x else x) -- | True if the first word (separating on either - or space) --- looks like an acronym +-- looks like an acronym. startsWithAcronym :: Text -> Bool startsWithAcronym = looksLikeAcronym . firstWord @@ -199,34 +227,39 @@ -- ** Sounds -- --------------------------------------------------------------------- --- | Ends with a sh sound +-- | Ends with a sh sound. hasSibilantSuffix :: Text -> Bool -hasSibilantSuffix x = any (`T.isSuffixOf` x) ["x","s","ch","sh"] +hasSibilantSuffix x = any (`T.isSuffixOf` x) ["x","s","ch","sh","z","j"] --- | Starts with a semivowel +-- | Starts with a semivowel. hasSemivowelPrefix :: Text -> Bool hasSemivowelPrefix ls = any (`T.isPrefixOf` ls) ["y","w","eu","ewe"] --- | Last two letters are a consonant and 'y' +-- | Last two letters are a consonant and 'y'. hasCySuffix :: Text -> Bool hasCySuffix (T.unpack . tTakeEnd 2 -> [x, 'y']) = isConsonant x hasCySuffix _ = False --- | Is a vowel +-- | Last two letters are a consonant and 'o'. +hasCoSuffix :: Text -> Bool +hasCoSuffix (T.unpack . tTakeEnd 2 -> [x, 'o']) = isConsonant x +hasCoSuffix _ = False + +-- | Is a vowel. isVowel :: Char -> Bool isVowel = (`elem` "aeiou") . toLower -- | Letters that when pronounced independently in English sound like they --- begin with vowels +-- begin with vowels. -- -- > isLetterWithInitialVowelSound 'r' == True -- > isLetterWithInitialVowelSound 'k' == False -- -- (In the above, @'r'@ is pronounced @"are"@, but @'k'@ is pronounced --- @"kay"@) +-- @"kay"@.) isLetterWithInitialVowelSound :: Char -> Bool -isLetterWithInitialVowelSound = (`elem` "aeioufhlmnrsx") . toLower +isLetterWithInitialVowelSound = (`elem` "aeiofhlmnrsx") . toLower --- | Is a consonant +-- | Is a consonant. isConsonant :: Char -> Bool isConsonant = not . isVowel diff --git a/NLP/Minimorph/Number.hs b/NLP/Minimorph/Number.hs --- a/NLP/Minimorph/Number.hs +++ b/NLP/Minimorph/Number.hs @@ -2,7 +2,7 @@ import Data.Text ( Text ) --- | Singular and Plural +-- | Singular and Plural. data SingPlu a = SP { sg :: a , pl :: a diff --git a/NLP/Minimorph/Util.hs b/NLP/Minimorph/Util.hs --- a/NLP/Minimorph/Util.hs +++ b/NLP/Minimorph/Util.hs @@ -6,27 +6,31 @@ -- Stability : experimental -- Portability : portable -- --- Utility functions probably internal to minimorph +-- Text utility functions. module NLP.Minimorph.Util where import Data.Text ( Text ) import qualified Data.Text as T --- | @tTakeEnd n t@ returns the last @n@ letters of @t@ +-- | @tTakeEnd n t@ returns the last @n@ letters of @t@. tTakeEnd :: Int -> Text -> Text tTakeEnd n t = T.drop (T.length t - n) t --- | @tDropEnd n t@ drops the last @n@ letters of @t@ +-- | @tDropEnd n t@ drops the last @n@ letters of @t@. tDropEnd :: Int -> Text -> Text tDropEnd n x = T.take (T.length x - n) x --- | Identical to 'T.append' +-- | Identical to 'T.append'. (<>) :: Text -> Text -> Text t1 <> t2 = t1 `T.append` t2 -- | Separated by space unless one of them is empty (in which case just --- the non-empty one) +-- the non-empty one). (<+>) :: Text -> Text -> Text t1 <+> t2 | T.null t1 = t2 | T.null t2 = t1 - | otherwise = t1 `T.append` " " `T.append` t2 + | otherwise = t1 <> " " <> t2 + +-- | Show a value in Text format. +showT :: Show a => a -> Text +showT = T.pack . show diff --git a/minimorph.cabal b/minimorph.cabal --- a/minimorph.cabal +++ b/minimorph.cabal @@ -1,8 +1,8 @@ --- Initial minimorph.cabal generated by cabal init. For further +-- Initial minimorph.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: minimorph -version: 0.1.3.0 +version: 0.1.4.0 synopsis: English spelling functions with an emphasis on simplicity. description: A set of simplistic functions capturing the more regular parts of English spelling (for generation, not parsing). @@ -10,7 +10,7 @@ irregular nouns/verbs. This package is not meant to provide anything resembling a full account of English morphology (something like Functional Morphology or sequor could be - better suited). The main goal is to provide something cheap + better suited). The main goal is to provide something cheap and cheerful with no learning curve, that you can use until your application calls for more robustness. homepage: http://darcsden.com/kowey/minimorph @@ -18,7 +18,7 @@ license-file: LICENSE author: Eric Kow maintainer: eric.kow@gmail.com --- copyright: +-- copyright: category: Natural Language Processing build-type: Simple cabal-version: >=1.8 @@ -31,7 +31,7 @@ exposed-modules: NLP.Minimorph.English NLP.Minimorph.Number NLP.Minimorph.Util - -- other-modules: + -- other-modules: build-depends: base < 5 , text