{-# 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)