# 99 questions/Solutions/50

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)

(***) Huffman codes.

We suppose a set of symbols with their frequencies, given as a list of fr(S,F) terms. Example: [fr(a,45),fr(b,13),fr(c,12),fr(d,16),fr(e,9),fr(f,5)]. Our objective is to construct a list hc(S,C) terms, where C is the Huffman code word for the symbol S. In our example, the result could be Hs = [hc(a,'0'), hc(b,'101'), hc(c,'100'), hc(d,'111'), hc(e,'1101'), hc(f,'1100')] [hc(a,'01'),...etc.]. The task shall be performed by the predicate huffman/2 defined as follows:

```% huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs
```

Solution:

```import Data.List
import Data.Ord (comparing)

data HTree a = Leaf a | Branch (HTree a) (HTree a)
deriving Show

huffman :: (Ord a, Ord w, Num w) => [(a,w)] -> [(a,[Char])]
huffman freq = sortBy (comparing fst) \$ serialize \$
htree \$ sortBy (comparing fst) \$ [(w, Leaf x) | (x,w) <- freq]
where htree [(_, t)] = t
htree ((w1,t1):(w2,t2):wts) =
htree \$ insertBy (comparing fst) (w1 + w2, Branch t1 t2) wts
serialize (Branch l r) =
[(x, '0':code) | (x, code) <- serialize l] ++
[(x, '1':code) | (x, code) <- serialize r]
serialize (Leaf x) = [(x, "")]```

The argument to htree is a list of (weight, tree) pairs, in order of increasing weight. The implementation could be made more efficient by using a priority queue instead of an ordered list.

Or, a solution that does not use trees:

```import List
-- tupleUpdate - a function to record the Huffman codes; add string
--               "1" or "0" to element 'c' of tuple array ta
-- let ta = [('a',"0"),('b',"1")]
-- tupleUpdate ta 'c' "1" =>  [('c',"1"),('a',"0"),('b',"1")]
tupleUpdate :: [(Char,[Char])]->Char->String ->[(Char,[Char])]
tupleUpdate ta el val
| ((dropWhile(\x -> (fst x)/= el) ta)==[])= (el,val):ta
| otherwise = (takeWhile (\x -> (fst x)/=el) ta) ++ ((fst(head ha),val ++ snd(head ha)) : (tail (dropWhile (\x -> (fst x)/=el) ta)))
where ha = [(xx,yy)|(xx,yy) <- ta,xx ==el]

-- tupleUpdater - wrapper for tupleUpdate, use a list decomposition "for loop"
-- let ta = [('a',"0"),('b',"1")]
-- tupleUpdater ta "fe" "1" => [('e',"1"),('f',"1"),('a',"0"),('b',"1")]
tupleUpdater :: [(Char,[Char])]->String->String ->[(Char,[Char])]
tupleUpdater a (x:xs) c =  tupleUpdater (tupleUpdate a x c) xs c
tupleUpdater a [] c = a

-- huffer - recursively run the encoding algorithm and record the left/right
--          codes as they are discovered in argument hc, which starts as []
-- let ha =[(45,"a"),(13,"b"),(12,"c"),(16,"d"),(9,"e"),(5,"f")]
-- huffer ha [] => ([(100,"acbfed")],[('a',"0"),('b',"101"),('c',"100"),('d',"111"),('e',"1101"),('f',"1100")])
huffer :: [(Integer,String)] -> [(Char,[Char])]-> ([(Integer,String)],[(Char,[Char])])
huffer ha hc
| ((length ha)==1)=(ha,sort hc)
| otherwise       = huffer ((num,str): tail(tail(has)) ) hc2