Haskell-Data-Analysis-Cookbook/Ch05/Code12_huff/Main.hs

import Data.List (group, sort)
import MinHeap
import Network.HTTP (getRequest, getResponseBody, simpleHTTP)
import Data.Char (isAscii)
import Data.Maybe (fromJust)
import Data.Map (fromList, (!))

freq xs = map (\x -> (head x, length x)) . group . sort $ xs

-- Decoding a Huffman code
main = do
  rsp <- simpleHTTP (getRequest "http://norvig.com/big.txt")
  html <- fmap (takeWhile isAscii) (getResponseBody rsp)
  let freqs = freq html
  let heap = foldr (\(v,w) -> insert (single v) w) empty freqs
  let tree = htree heap
  let m = fromList $ codes tree
  print $ encode "hello world" m
  print $ decode (encode "hello world" m) tree
  
encode str m = concat $ map (m !) str
  
decode str htree = decode' str htree
  where decode' "" _ = ""
        decode' ('0':str) (HTree _ l _) 
          | leaf l    = value l : decode' str htree
          | otherwise = decode' str l
        decode' ('1':str) (HTree v _ r) 
          | leaf r    = value r : decode' str htree
          | otherwise = decode' str r
        leaf tree = left tree == Null && right tree == Null

data HTree = HTree { value  :: Char
                   , left   :: HTree
                   , right  :: HTree }
           | Null 
           deriving (Eq, Show)

single v = HTree v Null Null

htree heap = if length (items heap) == 2
             then case fromJust (viewMin heap) of (a,b,c) -> a
             else htree $ insert newNode (w1 + w2) heap3
  where (min1, w1, heap2) = fromJust $ viewMin heap
        (min2, w2, heap3) = fromJust $ viewMin heap2
        newNode = HTree { value  = ' '
                        , left   = min1
                        , right  = min2 }
                  
codes htree = codes' htree ""
  where codes' (HTree v l r) str 
          | l==Null && r==Null = [(v, str)]
          | r==Null            = leftCodes
          | l==Null            = rightCodes
          | otherwise          = leftCodes ++ rightCodes
          where leftCodes = codes' l (str ++ "0")
                rightCodes = codes' r (str ++ "1")