September 2017 Update

Task/Roman-numerals-Decode/Haskell/roman-numerals-decode-2.hs

@@ -1,16 +1,29 @@
 import Data.List (mapAccumL, isPrefixOf)
+import Control.Arrow ((***))
 
 romanValue :: String -> Int
-romanValue s = sum . snd $ mapAccumL tr s
-    [("M", 1000), ("CM", 900), ("D", 500), ("CD", 400),
-     ("C",  100), ("XC",  90) ,("L",  50), ("XL",  40),
-     ("X",   10), ("IX",   9), ("V",   5), ("IV",   4),
-     ("I",    1)]
-  where
-    tr s (k, v) =
-        until (\(s, _) -> not $ isPrefixOf k s)
-              (\(s, n) -> (drop (length k) s, n + v)) (s, 0)
+romanValue =
+  let tr s (k, v) =
+        until (not . isPrefixOf k . fst) (drop (length k) *** (v +)) (s, 0)
+  in sum .
+     snd .
+     flip
+       (mapAccumL tr)
+       [ ("M", 1000)
+       , ("CM", 900)
+       , ("D", 500)
+       , ("CD", 400)
+       , ("C", 100)
+       , ("XC", 90)
+       , ("L", 50)
+       , ("XL", 40)
+       , ("X", 10)
+       , ("IX", 9)
+       , ("V", 5)
+       , ("IV", 4)
+       , ("I", 1)
+       ]
 
 main :: IO ()
-main = mapM_ (putStrLn . show . romanValue)
-    ["MDCLXVI", "MCMXC", "MMVIII", "MMXVI", "MMXVII"]
+main =
+  mapM_ (print . romanValue) ["MDCLXVI", "MCMXC", "MMVIII", "MMXVI", "MMXVII"]

Task/Roman-numerals-Decode/Haskell/roman-numerals-decode-3.hs

@@ -0,0 +1,12 @@
+fromRoman :: String -> Int
+fromRoman =
+  sum .
+  liftM2 (:) fst snd .
+  mapAccumR
+    (\l r ->
+        ( if l <= r
+            then r
+            else (-r)
+        , l))
+    0 .
+  fmap charVal

Task/Roman-numerals-Decode/Haskell/roman-numerals-decode-4.hs

@@ -0,0 +1,31 @@
+import qualified Data.Map.Strict as M
+
+fromRoman :: String -> Int
+fromRoman xs = partialSum + lastDigit
+  where
+    (partialSum, lastDigit) = foldl accumulate (0, 0) (evalRomanDigit <$> xs)
+    accumulate (partial, lastDigit) newDigit
+      | newDigit <= lastDigit = (partial + lastDigit, newDigit)
+      | otherwise = (partial - lastDigit, newDigit)
+
+mapRoman :: M.Map Char Int
+mapRoman =
+  M.fromList
+    [ ('I', 1)
+    , ('V', 5)
+    , ('X', 10)
+    , ('L', 50)
+    , ('C', 100)
+    , ('D', 500)
+    , ('M', 1000)
+    ]
+
+evalRomanDigit :: Char -> Int
+evalRomanDigit c =
+  let mInt = M.lookup c mapRoman
+  in case mInt of
+       Just x -> x
+       _ -> error $ c : " is not a roman digit"
+
+main :: IO ()
+main = print $ fromRoman <$> ["MDCLXVI", "MCMXC", "MMVIII", "MMXVI", "MMXVII"]

Task/Roman-numerals-Decode/Haskell/roman-numerals-decode-5.hs

@@ -0,0 +1,13 @@
+fromRoman :: String -> Int
+fromRoman =
+  snd .
+  foldr
+    (\l (r, n) ->
+        ( l
+        , (if l >= r
+             then (+)
+             else (-))
+            n
+            l))
+    (0, 0) .
+  fmap evalRomanDigit

Task/Roman-numerals-Decode/Haskell/roman-numerals-decode-6.hs

@@ -0,0 +1,39 @@
+import qualified Data.Map.Strict as M (Map, fromList, lookup)
+import Data.Maybe (isNothing, isJust, fromJust, catMaybes)
+import Data.List (mapAccumL)
+
+mapRoman :: M.Map String Int
+mapRoman =
+  M.fromList
+    [ ("M", 1000)
+    , ("CM", 900)
+    , ("D", 500)
+    , ("CD", 400)
+    , ("C", 100)
+    , ("XC", 90)
+    , ("L", 50)
+    , ("XL", 40)
+    , ("X", 10)
+    , ("IX", 9)
+    , ("V", 5)
+    , ("IV", 4)
+    , ("I", 1)
+    ]
+
+fromRoman :: String -> Int
+fromRoman s =
+  let value k = M.lookup k mapRoman
+  in sum . catMaybes . snd $
+     mapAccumL
+       (\mi (l, r, i) ->
+           let mValue = value [l, r] -- mapRoman lookup of [left, right] Chars
+               (lastPair, pairValue)
+                 | isJust mValue = (Just i, mValue) -- Pair match: index updated
+                 | isNothing mi || i - fromJust mi > 1 = (mi, value [l])
+                 | otherwise = (mi, Nothing) -- Left Char was counted in pair
+           in (lastPair, pairValue))
+       Nothing -- Accumulator – maybe Index to last matched Char pair
+       (zip3 s (tail s ++ " ") [0 ..]) -- Indexed character pairs
+
+main :: IO ()
+main = print $ fromRoman <$> ["MDCLXVI", "MCMXC", "MMVIII", "MMXVI", "MMXVII"]