Huffman符号木

情報理論の宿題のうちの1問，「これこれの確率分布に対してHuffman符号木を書け」をHaskellで解いてみた．情報理論は計数の科目なので．

nodakai@co:/mnt/windows/home/nodakai/prog/haskell$ hugs huffman.hs
（略）
Main> main
Input (probabilities for each alphabet): 
[('a',0.25),('b',0.25),('c',0.2),('d',0.15),('e',0.1),('f',0.05)]

Output (Huffman code tree and table):
+:1.0 +:0.45 --'c':0.2
             --'b':0.25
      +:0.55 --'a':0.25
             +:0.3 --'d':0.15
                   +:0.15 --'f':0.05
                          --'e':0.1
[('c',"00"),('b',"01"),('a',"10"),('d',"110"),('f',"1110"),('e',"1111")]

以下，ソースコード．英単語にtypoがあるな（笑

module Main where

import IO
import List

data BinTree a p = Leaf a p | Branch (BinTree a p) (BinTree a p) p

binTreeShow (Leaf x p) d h =
    (if h then wsGen d else "") ++ "--" ++ (show x) ++ ":" ++ (show p)

binTreeShow (Branch l r p) d h =
    (if h then wsGen d else "")
    ++ "+:" ++ pStr ++ " " ++ (binTreeShow l dnew False) ++ "\n"
    ++ (binTreeShow r dnew True)
        where pStr = show p
              dnew = d+(length pStr)+3

wsGen n = loop n ""
    where loop 0 acc = acc
          loop n acc = loop (n-1) (' ':acc)

instance (Show a, Show p) => Show (BinTree a p) where
    show x = binTreeShow x 0 False

occuranceProbabilities = [('a', 0.25),
                          ('b', 0.25),
                          ('c', 0.2),
                          ('d', 0.15),
                          ('e', 0.1),
                          ('f', 0.05)]

main = do putStrLn "Input (probabilities for each alphabet): "
          putStrLn $ show occuranceProbabilities
          putStrLn ""
          putStrLn "Output (Huffman code tree and table):"
          putStrLn $ show $ huffmanTree
          putStrLn $ show $ tablize $ huffmanTree
  where huffmanTree = huffmanTreefy occuranceProbabilities

huffmanTreefy spec =
    loop (sortBy od init)
          where init = map (\ (ch, p) -> (p, (Leaf ch p))) spec
                od (p1, _) (p2, _) = if p1 < p2 then LT else GT
                loop []                           = Leaf 'Q' 0
                loop [(p, tr)]                    = tr
                loop ((px, trX):(py, trY):rest) = loop sorted
                    where sorted = sortBy od ((pp, (Branch trX trY pp)):rest)
                              where pp = px+py

tablize tree =
    map (\ (c,s) -> (c, reverse s)) (rec tree "")
        where rec (Leaf x p) acc = [(x, acc)]
              rec (Branch l r p) acc = (rec l ('0':acc)) ++ (rec r ('1':acc))

ちなみに宿題の提出期限はとっくに過ぎている．