3
\$\begingroup\$

I need to use the English numerals (American) in Haskell, so I looked for a library that did it. I have not found one, therefore I developed the program that I am presenting here. There are actually two versions of the program: one "analytical" and the other "synthetic".

The analytical version (presented here) aims to represent the deep complex structure of the numerals and the close relation between cardinal and ordinal. The synthetic version is a simplification of the analytic version.

Since I am neither a linguist nor a native English speaker, so I would first need an assessment of the soundness of the analysis and representation of numerals.

I believe that the program can be more concise, but I have no idea how to proceed.

module EnglishNumerals
    (toEngCard
    ,toEngCardOrd
    ,toEngOrd
    ,fromEngCardinal
    ,fromEngOrdinal) where

import Text.Parsec
import Text.Parsec.Char
import Control.Monad (msum)
import Data.List (delete,elemIndex,isInfixOf,isSuffixOf)
import Data.Maybe (fromJust)

----- ENGLISH NUMERAL (American) -----

{- EXAMPLES

toEngCard 703012832745 == "seven hundred three billion twelve million eight hundred thirty-two thousand seven hundred forty-five"

fromEngCardinal "seven hundred three billion twelve million eight hundred thirty-two thousand seven hundred forty-five" == 703012832745

map toEngCardOrd [0 .. 24] == ["0th","1st","2nd","3rd","4th","5th","6th","7th","8th","9th","10th","11th","12th","13th","14th","15th","16th","17th","18th","19th","20th","21st","22nd","23rd","24th"]

map fromEngOrdinal ["0th","1st","2nd","3rd","4th","5th","6th","7th","8th","9th","10th","11th","12th","13th","14th","15th","16th","17th","18th","19th","20th","21st","22nd","23rd","24th"] ==
[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24]

toEngOrd 703012832745 == "seven hundred three billion twelve million eight hundred thirty-two thousand seven hundred forty-fifth"

fromEngOrdinal "seven hundred three billion twelve million eight hundred thirty-two thousand seven hundred forty-fifth" == 703012832745
-}

---------------  F R O M   I N T E G E R   T O   C A R D I N A L   N U M B E R  ------------------

toEngCard :: Integer -> String  
toEngCard n
  | n < 0     = error "Negative number."
  | n < 100   = toEngCardTill99 n
  | otherwise = toEngCardFrom100To999Trillion n

toEngCardTill99 :: Integer -> String
toEngCardTill99 n
  | n < 10  = engCardUnit !! fromInteger n
  | n < 20  = engCardinalTeen n
  | n < 100 = let t = tens n ; d = mod n 10 in
     engCardTens t ++ if d == 0 then "" else "-" ++ engCardUnit !! fromInteger d

toEngCardFrom100To999Trillion :: Integer -> String
toEngCardFrom100To999Trillion n
  | n < 10^3  = f n 100     "hundred"
  | n < 10^6  = f n (10^3)  "thousand"
  | n < 10^9  = f n (10^6)  "million"
  | n < 10^12 = f n (10^9)  "billion"
  | n < 10^15 = f n (10^12) "trillion"
  | otherwise = error "About " ++ show n ++ " .. work in progress :)"
  where
  f x y s = let (q,r) = divMod x y
    in toEngCard q ++ " " ++ s ++ if r == 0 then "" else " " ++ toEngCard r

engCardUnit = ["zero","one","two","three","four","five","six","seven","eight","nine"] 

irregularRoot :: Integer -> String
irregularRoot n = case n of
  2  -> init   (engCardUnit !! 2) ++ "e"  -- "twe"
  3  -> take 2 (engCardUnit !! 3) ++ "ir" -- "thir"
  4  -> delete 'u' (engCardUnit !! 4)     -- "for"
  5  -> take 2 (engCardUnit !! 5) ++ "f"  -- "fif"
  8  -> init   (engCardUnit !! 8)         -- "eigh"
  9  -> init   (engCardUnit !! 9)         -- "nin"
  20 -> irregularRoot 2 ++ "n"             -- "twen"
  _  -> error "Irregular root not defined"

twe   = irregularRoot 2
thir  = irregularRoot 3
for   = irregularRoot 4
fif   = irregularRoot 5
eigh  = irregularRoot 8
nin   = irregularRoot 9
twen  = irregularRoot 20

irregularRoots = [twe,thir,for,fif,eigh,nin,twen]

engCardinalTeen :: Integer -> String
engCardinalTeen n
  | n == 10 = "ten"
  | n == 11 = "eleven"
  | n == 12 = twe ++ "lve"
  | otherwise  = case n of
                      13 -> thir
                      15 -> fif
                      18 -> eigh
                      _  -> toEngCard (n - 10)
                   ++ "teen"

engCardTens :: Integer -> String
engCardTens n = [twen,thir,for,fif,toEngCard 6,toEngCard 7,eigh,toEngCard 9] !! fromInteger (n-2) ++ "ty"

tens :: Integer -> Integer
tens m = mod (div m 10) 10

---------------  F R O M   I N T E G E R   T O   O R D I N A L   N U M B E R  -------------------

toEngCardOrd :: Integer -> String  -- Concise Ordinal
toEngCardOrd n
    | n < 0    = error "Negative number."
    | otherwise = show n ++ if n >= 11 && n <= 13 then "th" else suff
  where
  suff = case mod n 10 of
    1 -> "st"
    2 -> "nd"
    3 -> "rd"
    _ -> "th"

toEngOrd :: Integer -> String -- Verbose Ordinal
toEngOrd n
  | n < 0    = error "Negative number."
  | n < 100  = engVerbOrdTill99 n
  | otherwise = engVerbOrdFrom1000Up n

engVerbOrdTill99 n
  | elem n [0,4,6,7] = toEngCard n ++ "th"
  | n == 1  = "first"
  | n == 2  = "second"
  | n == 3  = thir ++ "d"
  | n < 10  = irregularRoot n ++ "th"
  | n == 12 = twe ++ "lf" ++ "th"
  | n <  20 = toEngCard n ++ "th"
  | n < 100 = let t = tens n ; u = mod n 10 in
     if u == 0 then init (engCardTens t) ++ "ieth"
       else (engCardTens t) ++ "-" ++ toEngOrd u
  | otherwise = error "Number not between 0 and 99: " ++ show n

engVerbOrdFrom1000Up n = toEngCard h ++
  if r == 0 then "th" else " " ++ toEngOrd r
  where
  r = rem n 100
  h = 100 * div n 100 -- hundreds

---------------- P A R S I N G  C A R D I N A L   N U M B E R S   ---------------

fromEngCardinal :: String -> Integer
fromEngCardinal s = case parse parseCardinalNumber "" s of
   Left xs -> error $ show xs
   Right n  -> n

parseCardinalNumber :: Parsec String u Integer
parseCardinalNumber = do
  many space
  do eof; return 0
     <|> do n1 <- parseFrom0To999
            try (do eof; return n1)
              <|> do spaces
                     n2 <- parseMultiplier
                     let n3 = n1 * n2
                     try (do eof; return n3) <|> do n4 <- parseCardinalNumber; return (n3 + n4)

parseFrom0To999 = try parseFrom100To999 <|> parseUpTo99

parseFrom100To999 = do
  n1 <- parseHundreds
  try (do spaces; n2 <- parseUpTo99; return $ n1 + n2)
    <|> return n1

parseHundreds = do n <- parseDigit; spaces; string "hundred"; return $ n * 100

parseUpTo99 = do
  n <- try parseTensHyphenDigit <|> try parseTens <|> try parseTeen <|> parseDigit
  return n

parseMultiplier = try thousand <|> million <|> billion <|> trillion

thousand = string "thousand" >> return (10^3)
million  = string "million"  >> return (10^6)
billion  = string "billion"  >> return (10^9)
trillion = string "trillion" >> return (10^12)

parseDigit = do s <- tryStrings engCardUnit; return $ index s engCardUnit

parseTeen = try parseTeenIrregular1 <|> parseTeenIrregular2 <|> parseTeenRegular

parseTeenRegular = do n <- parseDigit; string "teen"; return $ 10 + n

parseTeenIrregular1 = do d <- tryStrings ectn; return $ 10 + index d ectn
  where ectn = ["ten","eleven",twe ++ "lve"]

parseTeenIrregular2 = do d <- tryStrings ectn; string "teen"; return $ v d
  where
  ectn = [thir, fif, eigh]
  v x = fromJust $ lookup x [(thir,13),(fif,15),(eigh,18)]

parseTens = try parseTensIrregular <|> parseTensRegular  

parseTensIrregular = do s <- tryStrings prefTens; string "ty"; return $ v s
  where
  prefTens = [twe ++ "n",thir,for,fif,eigh]
  v x = fromJust $ lookup x [(twe ++ "n",20),(thir,30),(for,40),(fif,50),(eigh,80)]

parseTensRegular = do n <- parseDigit; string "ty"; return $ n * 10

parseTensHyphenDigit = do n1 <- parseTens; char '-'; n2 <- parseDigit; return $ n1 + n2

bigCardinals = ["hundred","thousand","million","billion","trillion"]

-- ------------- P A R S I N G  O R D I N A L   N U M B E R S   ---------------

fromEngOrdinal :: String -> Integer
fromEngOrdinal s = case parse parseOrdinalNumber "" s of
   Left xs -> error $ show xs 
   Right n  -> n

parseOrdinalNumber :: Parsec String () Integer 
parseOrdinalNumber = parseConciseOrdinalNumber <|> parseVerboseOrdinalNumber

parseConciseOrdinalNumber = do
  ds <- many1 digit
  suf <- tryStrings ["st","nd","rd","th"]
  eof
  if agreement ds suf
    then return (read ds :: Integer)
    else error "There is no agreement between digits and suffix"

agreement ds suf
  | or (zipWith isSuffixOf ["11","12","13"] (repeat ds))  = suf == "th"
  | isSuffixOf "1" ds = suf == "st"
  | isSuffixOf "2" ds = suf == "nd"
  | isSuffixOf "3" ds = suf == "rd"
  | otherwise = suf == "th"

parseVerboseOrdinalNumber = do
  many space
  do eof; return 0
     <|> try parseOrdinalDigit
     <|> try parseOrdinalTeenRegular
     <|> try parseOrdinal12
     <|> try parseOrdinal20
     <|> try parseOrdinalTens
     <|> try parseOrdinalTensWithCardinalPrefix
     <|> try parseOrdinalHundreds
     <|> do s <- getInput
            if isLastWordHypenate s
               then parseOrdinalWithCardinalPrefixAndLastNumberHyphenate s
               else parseRemainingOrdinals

parseOrdinalDigit = do s <- tryStrings eod; return $ index s eod
  where  eod = map toEngOrd [0..9]

parseOrdinalTeenRegular = do n <- parseTeen; string "th"; return n

parseOrdinal12 = do string (twe ++ "lf" ++ "th"); return 12

parseOrdinal20 = do string (twe ++ "n" ++ "tieth"); return 20

parseOrdinalTens = do s <- tryStrings eots; string "tieth"; return $ 10 * (2 + index s eots)
  where eots = [twen,thir,for,fif,toEngCard 6,toEngCard 7,eigh,toEngCard 9]

parseOrdinalTensWithCardinalPrefix = do n <- parseTens; char '-'; n2 <- parseOrdinalDigit; return (n + n2)

parseOrdinalHundreds = do n <- parseDigit; space; string ("hundred" ++ "th"); return (n * 100)

parseOrdinalWithCardinalPrefixAndLastNumberHyphenate s = do
  let (s1,_:s2) = span (/= '-'). reverse $ s
  let eoc = case parse parseCardinalNumber "" (reverse s2) of
               Left xs -> error $ show xs 
               Right n  -> n
  let eon = case parse parseOrdinalDigit "" (reverse s1) of
               Left xs -> error $ show xs 
               Right n  -> n
  return (eoc + eon)

parseRemainingOrdinals = do
  inp <- getInput 
  let ws = words inp
  let eon = last ws
  let ecn = unwords . init $ ws
  if elem eon bigOrdinals
    then do
      let inp2 = take (length inp - 2) inp
      let rn = case parse parseCardinalNumber "" inp2 of
                 Left xs -> error $ show xs 
                 Right n  -> n
      return rn
    else do
      let rn1 = case parse parseCardinalNumber "" ecn of
                  Left xs -> error $ show xs 
                  Right n  -> n
      let rn2 = case parse parseVerboseOrdinalNumber "" eon of
                  Left xs -> error $ show xs 
                  Right n  -> n
      return (rn1 + rn2)

bigOrdinals = map (++ "th") bigCardinals  

-- -------------- P A R S I N G   S T U F F   --------------

-- UTILITY functions

index :: Eq a => a -> [a] -> Integer
index x xs = fromIntegral . fromJust $ elemIndex x xs

isLastWordHypenate :: String -> Bool
isLastWordHypenate = isInfixOf "-" . last . words

-- UILITY parsers

tryStrings :: [String] -> Parsec String u String
tryStrings = msum . fmap (try . string)
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.