Huffman code generation.

Huffman.hs

{-# LANGUAGE LambdaCase #-}

import qualified Data.PQueue.Min as Q
import Control.Arrow
import Data.Function

data Tree 
    = Empty
    | Leaf {weight :: Double} 
    | Node {weight :: Double, _left, _right :: Tree}

instance Ord Tree where compare = compare `on` weight
instance Eq Tree  where (==)    = (==) `on` weight

build :: Q.MinQueue Tree -> Tree
build = Q.splitAt 2 >>> \case
    ([a,b], xs') -> build (Q.insert (Node (weight a + weight b) a b) xs')
    ([x], _)     -> x
    _            -> Empty

bitStrings :: Tree -> [(String, Double)]
bitStrings = fix $ \f -> \case
    Node _ a b -> map (first ('0':)) (f a) ++ map (first ('1':)) (f b)
    Leaf w     -> [("", w)]
    Empty      -> []

genCodes :: [Double] -> [(String, Double)]
genCodes = bitStrings . build . Q.fromList . map Leaf

main :: IO ()
main = mapM_ print $ genCodes [1, 5, 8, 10]