オフラインリアルタイムどう書く第8回の参考問題をHaskellで書いた

import qualified Data.Map as Map
import qualified Data.List as List
import Data.Char
import Control.Monad

bin = ["0000","0001","0010","0011","0100","0101","0110","0111",
       "1000","1001","1010","1011","1100","1101","1110","1111"]

table = Map.fromList [("000", "t"),
                      ("0010", "s"),
                      ("0011", "n"),
                      ("0100", "i"),
                      ("01010", "d"),
                      ("0101101", "c"),
                      ("010111", "l"),
                      ("0110", "o"),
                      ("0111", "a"),
                      ("10", "e"),
                      ("1100", "r"),
                      ("1101", "h"),
                      ("111", "")
                     ]

tableKeys :: [String]
tableKeys = Map.keys table

--入力文字列を2進数へ変換する関数
hexToBin :: String -> String
hexToBin  = concatMap (reverse . (bin !!) . digitToInt)

--入力に対応する文字は必ず見つかるのでMaybe値から通常の値を取り出して返す
tableLookUp :: String -> String
tableLookUp k = let x = Map.lookup k table
                in case x of
                    (Just y) -> y
                    Nothing -> error "invalid key"

-- > isPrefix "10" "10000" == Maybe ("10", "e", "000")
-- > isPrefix "0010" "00101101" == Maybe ("0010", "s", "1101")
-- > isPrefix "0000" "00101101" == Nothing
-- isPrefix s t sがtのプレフィックズならば
-- 三つ組(s, sに対応する文字, tからsを取り除いた残り)を返し
-- プレフィックスでなければNothingを返す
isPrefix :: String -> String -> Maybe (String, String, String)
isPrefix s t = let u = List.stripPrefix s t
               in case u of
                 Just v -> Just (s, tableLookUp s, v)
                 Nothing -> Nothing


parse :: String -> [Maybe (String, String)]
parse s = let x = foldl mplus Nothing $ map (`isPrefix` s) tableKeys
           in case x of
            Just (s, "", u) -> [Just (s, "")] -- 終端文字を読み込んだらそれ以上再帰しない
            Just (s, t, u) -> (Just (s, t)):(parse u)
            Nothing -> [Nothing] -- 対応する文字がない符号を読み込んだらNothingを返す

solve' :: String -> Maybe (String, String)
solve' s = foldl add (Just ("", "")) $ (parse . hexToBin) s
    where
        add :: Maybe (String, String) -> Maybe (String, String) -> Maybe (String, String)
        add Nothing _ = Nothing
        add _ Nothing = Nothing
        add (Just (s, t)) (Just (s', t')) = Just (s++s', t++t')

solve :: String -> String
solve s = let x = solve' s
          in case x of
            Just (y, z) -> z ++ ":" ++ (show $ length y)
            Nothing -> "*invalid*"

test = [
        ("16d9d4fbd", "ethanol:30"),
        ("df", "e:5"),
        ("ad7", "c:10"),
        ("870dcb", "t:6"),
        ("880f63d", "test:15"),
        ("a57cbe56", "cat:17"),
        ("36abef2", "roll:23"),
        ("ad576cd8", "chant:25"),
        ("3e2a3db4fb9", "rails:25"),
        ("51aa3b4c2", "eeeteee:18"),
        ("ad5f1a07affe", "charset:31"),
        ("4ab8a86d7afb0f", "slideshare:42"),
        ("ac4b0b9faef", "doctor:30"),
        ("cafebabe", "nlh:17"),
        ("43e7", "sra:15"),
        ("53e7", "eera:15"),
        ("86cf", "tera:16"),
        ("b6cf", "hon:15"),
        ("0", "*invalid*"),
        ("c", "*invalid*"),
        ("d", "*invalid*"),
        ("e", "*invalid*"),
        ("babecafe", "*invalid*"),
        ("8d", "*invalid*"),
        ("ad", "*invalid*"),
        ("af", "*invalid*"),
        ("ab6e0", "*invalid*"),
        ("a4371", "*invalid*"),
        ("a4371", "*invalid*"),
        ("96e3", "*invalid*"),
        ("0dc71", "*invalid*"),
        ("2a9f51", "*invalid*"),
        ("a43fb2", "*invalid*"),
        ("ab6e75", "*invalid*"),
        ("a5dcfa", "*invalid*"),
        ("ca97", "*invalid*"),
        ("6822dcb", "*invalid*")
        ]

main = mapM_ (\(x, y) -> print (solve x == y)) test