EnglishNumeral.hs

-- references:
-- The Book of Numbers, J. H. Conway and R. K. Guy, New York: Springer-Verlag, 1996, pp. 15–16. ISBN 0-387-97993-X.

import Data.Tuple
import Data.List

unfoldBase :: (Integral a)=> a -> a -> [a]
unfoldBase b = unfoldr (\ x -> if x == 0 then Nothing else Just (swap $ quotRem x b))

onesPlace :: (Integral a)=> a -> [String]
onesPlace 0 = []
onesPlace 1 = ["one"]
onesPlace 2 = ["two"]
onesPlace 3 = ["three"]
onesPlace 4 = ["four"]
onesPlace 5 = ["five"]
onesPlace 6 = ["six"]
onesPlace 7 = ["seven"]
onesPlace 8 = ["eight"]
onesPlace 9 = ["nine"]

tensPlace :: (Integral a)=> a -> [String]
tensPlace 4 = ["forty"]
tensPlace x = [combinationShape x ++ "ty"]

teen :: (Integral a)=> a -> [String]
teen 0 = ["ten"]
teen 1 = ["eleven"]
teen 2 = ["twelve"]
teen x = [combinationShape x ++ "teen"]

combinationShape :: (Integral a)=> a -> String
combinationShape 2 = "twen"
combinationShape 3 = "thir"
combinationShape 4 = "four"
combinationShape 5 = "fif"
combinationShape 6 = "six"
combinationShape 7 = "seven"
combinationShape 8 = "eigh"
combinationShape 9 = "nin"

twoDigits :: (Integral a)=> a -> [String]
twoDigits x | x ==  0 = []
            | x <  10 = onesPlace x
            | x <  20 = teen (x - 10)
            | x < 100 = [intercalate "-" $ tensPlace tens ++ onesPlace ones]
                    where
                      (tens, ones) = quotRem x 10

threeDigits :: (Integral a)=> a -> [String]
threeDigits x | x <  100 = twoDigits ones
              | x < 1000 = onesPlace hundreds ++ hundred ++ td
                       where
                         (hundreds, ones) = quotRem x 100
                         td = twoDigits ones
                         hundred | null td   = ["hundred"]
                                 | otherwise = ["hundred", "and"]

milOnesPlace :: (Integral a)=> a -> [String]
milOnesPlace 0 = []
milOnesPlace 1 = ["un"]
milOnesPlace 2 = ["duo"]
milOnesPlace 3 = ["treS"]
milOnesPlace 4 = ["quattuor"]
milOnesPlace 5 = ["quinqua"]
milOnesPlace 6 = ["seX"]
milOnesPlace 7 = ["septeM"]
milOnesPlace 8 = ["octo"]
milOnesPlace 9 = ["noveM"]

milTensPlace :: (Integral a)=> a -> [String]
milTensPlace 0 = []
milTensPlace 1 = ["deci"]
milTensPlace 2 = ["viginti"]
milTensPlace 3 = ["triginta"]
milTensPlace 4 = ["quadraginta"]
milTensPlace 5 = ["quinquaginta"]
milTensPlace 6 = ["sexaginta"]
milTensPlace 7 = ["septuaginta"]
milTensPlace 8 = ["octoginta"]
milTensPlace 9 = ["nonaginta"]

milHundredsPlace :: (Integral a)=> a -> [String]
milHundredsPlace 0 = []
milHundredsPlace 1 = ["centi"]
milHundredsPlace 2 = ["ducenti"]
milHundredsPlace 3 = ["trecenti"]
milHundredsPlace 4 = ["quadrigenti"]
milHundredsPlace 5 = ["quingenti"]
milHundredsPlace 6 = ["sescenti"]
milHundredsPlace 7 = ["septingenti"]
milHundredsPlace 8 = ["octingenti"]
milHundredsPlace 9 = ["nongenti"]

milThreeDigits :: (Integral a)=> a -> [String]
milThreeDigits x | x < 1000 = milOnesPlace ones ++ milTensPlace tens ++ milHundredsPlace hundreds
    where
      (hundreds, (tens, ones)) = (\ (h, r) -> (h, quotRem r 10)) $ quotRem x 100

assimilation :: Char -> Char -> String
assimilation 'S' c | c `elem` "vtqco" = "s"
                   | otherwise = ""
assimilation 'X' c | c `elem` "co" = "x"
                   | c `elem` "vtq" = "s"
                   | otherwise = ""
assimilation 'M' c | c `elem` "dtsqc" = "n"
                   | c `elem` "vo" = "m"
                   | otherwise = ""
assimilation 'i' c | c `elem` "i" = ""
                   | otherwise = "i"
assimilation x _ = [x]

wordAssimilation :: String -> Char -> String
wordAssimilation "" _ = error "empty string is not acceptable as word"
wordAssimilation w c = reverse $ assimilation (head rw) c ++ tail rw
                   where
                     rw = reverse w

totAssimilation :: [String] -> [String]
totAssimilation [] = []
totAssimilation [w] = [wordAssimilation w '$']
totAssimilation (w:(ws@(nw:_))) = wordAssimilation w (head nw) : totAssimilation ws

zillionPrefix :: (Integral a)=> a -> [String]
zillionPrefix 0 = ["ni"]
zillionPrefix 1 = ["mi"]
zillionPrefix 2 = ["bi"]
zillionPrefix 3 = ["tri"]
zillionPrefix 4 = ["quadr"]
zillionPrefix 5 = ["quint"]
zillionPrefix 6 = ["sext"]
zillionPrefix 7 = ["sept"]
zillionPrefix 8 = ["oct"]
zillionPrefix 9 = ["non"]
zillionPrefix 15 = ["quin", "deci"]
zillionPrefix x | x < 1000 = milThreeDigits x
zillionPrefix x = zillionPrefix thousands ++ ["illi"] ++ zillionPrefix ones
    where
      (thousands, ones) = quotRem x 1000

zillion :: (Integral a)=> a -> String
zillion x = concat . totAssimilation . (++ ["illion"]) . zillionPrefix $ x

number :: (Integral a)=> a -> [String]
number 0 = ["zero"]
number x = concat . reverse . map thosandPlaces . zip [(0::Integer)..] . unfoldBase 1000 $ x
    where
      thosandPlaces (_, 0) = []
      thosandPlaces (e, n) = threeDigits n ++ thousand e

      thousand 0 = []
      thousand 1 = ["thousand"]
      thousand n = [zillion (n - 1)]

main :: IO ()
main = print . unwords . number $ (123456789012345678901234567890123456789000123456789 :: Integer)