エントロピー符号(2013.2.13の過去問)

1日1個 @nabetani さんの作った問題を解くAdventCalendarの15日目です。

今日の問題は http://nabetani.sakura.ne.jp/hena/ord8entco/ にあります。

module Doukaku.Entropy (solve) where
import Numeric.Lens (hex, binary)
import Control.Lens (review, preview)

solve :: String -> String
solve = decrypt . concatMap parse

data BDD = Leaf Char | Done | Undefined | Node BDD BDD deriving (Eq, Show)

define :: [Char] -> Char -> BDD -> BDD
define [] c Undefined = if c == '\0' then Done else Leaf c
define ('1':bs) c bdd = case bdd of
  Undefined -> Node Undefined (define bs c Undefined)
  Node f t -> Node f (define bs c t)
define ('0':bs) c bdd = case bdd of
  Undefined -> Node (define bs c Undefined) Undefined
  Node f t -> Node (define bs c f) t
define _ c _ = error ("Bad definition of " ++ [c])

codebdd :: BDD
codebdd = define "000"     't'
        $ define "0010"    's'
        $ define "0011"    'n'
        $ define "0100"    'i'
        $ define "01010"   'd'
        $ define "0101101" 'c'
        $ define "010111"  'l'
        $ define "0110"    'o'
        $ define "0111"    'a'
        $ define "10"      'e'
        $ define "1100"    'r'
        $ define "1101"    'h'
        $ define "111"     '\0'
        $ Undefined

decrypt :: String -> String
decrypt is = maybe "*invalid*" answer $ decrypt' codebdd is
  where
    answer (n, s) = s ++ ':' : show n

decrypt' :: BDD -> String -> Maybe (Int, String)
decrypt' Done _ = Just (0, [])
decrypt' (Leaf c)  xs = do
  (n', cs) <- decrypt' codebdd xs
  return (n', c:cs)
decrypt' (Node f _) ('0':xs) = do
  (n', cs) <- decrypt' f xs
  return (n' + 1, cs)
decrypt' (Node _ t) ('1':xs) = do
  (n', cs) <- decrypt' t xs
  return (n' + 1, cs)
decrypt' _ _ = Nothing

parse :: Char -> String
parse c = reverse . tail . review binary $ n
  where n = maybe 0 id . preview hex $ '1':c:[] :: Int

最初はパターンマッチでゴリ押しした解答を書いたのですが、せっかく休日なのでちょっと手直ししました。この問題の符号は2分決定木になるよう定められてますので、定義を素直に決定木codebddに翻訳しています。0がNodeの左側、1が右側となります。後は素直にこの木を辿り続ければ復号できます。結果だけでなく消費したビット数が必要なのが面倒ですが、こちらは素直に戻り値に含めました。例外処理が必要なのも地味に面倒で、こっちはMaybeで対応しています。

パース時に1を付加してtailをかけているのは変換後に上位の0が飛ばないようにするためで、@kei_q さんに教わった手法です。

http://qiita.com/Nabetani/items/24b9be4ee3bae4c89a95 に他の方の回答もありますので、見ると参考になるでしょう。