106 lines
3.2 KiB
Haskell
106 lines
3.2 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
module Data.RomanNum (
|
|
RomanNum(..)
|
|
, nullus
|
|
, parse
|
|
, plus
|
|
, r
|
|
, validate
|
|
) where
|
|
|
|
import Data.Char (toUpper)
|
|
import Data.Map (Map, (!))
|
|
import qualified Data.Map as Map (fromList)
|
|
import Text.Read (readMaybe)
|
|
|
|
newtype RomanNum = RomanNum Int deriving (Eq, Ord, Enum)
|
|
|
|
data RomanChar = I | V | X | L | C | D | M deriving (Bounded, Eq, Ord, Enum, Show, Read)
|
|
|
|
romanChars :: [RomanChar]
|
|
romanChars = [minBound .. maxBound]
|
|
|
|
base :: [(Int, [Char])]
|
|
base = base' 1 [] . concat $ show <$> romanChars where
|
|
base' _ l "" = l
|
|
base' size l chars =
|
|
base' (size * 10) ((size, take 3 chars):l) (drop 2 chars)
|
|
|
|
values :: Map RomanChar Int
|
|
values = Map.fromList $
|
|
zip romanChars (concat $ iterate (fmap (*10)) [1, 5])
|
|
|
|
instance Show RomanNum where
|
|
show (RomanNum 0) = "nullus"
|
|
show (RomanNum n) = show' n base where
|
|
show' 0 _ = ""
|
|
show' _ [] = error "Numeral system not fine-grained enough"
|
|
show' k ((size, digits):others)
|
|
| k < size = show' k others
|
|
| otherwise =
|
|
let decDigit = k `div` size in
|
|
showDecDigit decDigit digits ++ show' (k `mod` size) others
|
|
showDecDigit _ [] = error "no digits for conversion"
|
|
showDecDigit k [digit] = k `times` digit
|
|
showDecDigit k digits
|
|
| k == 4 || (k == 9 && length digits > 2) =
|
|
(head digits) : [head (drop (if k > 5 then 2 else 1) digits)]
|
|
| k > 4 = head (drop 1 digits) : (showDecDigit (k-5) digits)
|
|
| otherwise = k `times` (head digits)
|
|
times count letter = take count $ repeat letter
|
|
|
|
r :: String -> RomanNum
|
|
r = either error id . parse
|
|
|
|
validate :: String -> Bool
|
|
validate = either (\_ -> False) (\_ -> True) . parse
|
|
|
|
readDigit :: Char -> Either String Int
|
|
readDigit c = maybe errMsg (Right . (values !)) $ readMaybe [toUpper c]
|
|
where
|
|
errMsg = Left $ "Not a roman digit: «" ++ c:"»"
|
|
|
|
log10 :: Int -> Int
|
|
log10 n = length (show n) - 1
|
|
|
|
parse :: String -> Either String RomanNum
|
|
parse "" = Right nullus
|
|
parse "nullus" = Right nullus
|
|
parse s = RomanNum <$>
|
|
(mapM readDigit s >>= mapM analyzeBlock . romanGroups >>= romanSum)
|
|
where
|
|
romanGroups [] = []
|
|
romanGroups (x:xs) =
|
|
let groups = romanGroups xs in
|
|
case groups of
|
|
(group@(y:_):otherGroups)
|
|
| x <= y -> (x:group):otherGroups
|
|
_ -> [x]:groups
|
|
|
|
analyzeBlock [n] = Right (log10 n, n)
|
|
analyzeBlock l@(n1:n2:ns)
|
|
| n1 == 10 ^ p =
|
|
if n1 < n2 && 10*n1 >= n2 && null ns
|
|
then Right (p, n2 - n1)
|
|
else if n1 == n2 && all (== n1) ns && length ns < 2
|
|
then Right (p, (length ns +2)*n1)
|
|
else invalidSequence l
|
|
where
|
|
p = log10 n1
|
|
analyzeBlock l = invalidSequence l
|
|
|
|
romanSum [] = Right 0
|
|
romanSum [(_, n)] = Right n
|
|
romanSum ((p1, n1):blocks@((p2, n2):otherBlocks))
|
|
| p1 > p2 = (n1+) <$> romanSum blocks
|
|
| p1 == p2 && n1 == 5*10^p1 && n2 < n1 = (n1+n2+) <$> romanSum otherBlocks
|
|
| otherwise = invalidSequence [n1, n2]
|
|
invalidSequence l =
|
|
Left $ "Invalid sequence : " ++ concat (show . RomanNum <$> l)
|
|
|
|
nullus :: RomanNum
|
|
nullus = RomanNum 0
|
|
|
|
plus :: RomanNum -> RomanNum -> RomanNum
|
|
plus (RomanNum a) (RomanNum b) = RomanNum (a + b)
|