A-M baby

Task/Huffman-coding/Haskell/huffman-coding-1.hs

@@ -0,0 +1,24 @@
+import Data.List
+import Control.Arrow
+import Data.Ord
+
+data HTree a = Leaf a | Branch (HTree a) (HTree a)
+                deriving (Show, Eq, Ord)
+
+test :: String -> IO ()
+test s = mapM_ (\(a,b)-> putStrLn ('\'' : a : "\' : " ++ b))
+         . serialize . huffmanTree . freq $ s
+
+serialize :: HTree a -> [(a, String)]
+serialize (Branch l r) = map (second('0':)) (serialize l) ++ map (second('1':)) (serialize r)
+serialize (Leaf x)     = [(x, "")]
+
+huffmanTree :: (Ord w, Num w) => [(w, a)] -> HTree a
+huffmanTree = snd . head . until (null.tail) hstep
+                  . sortBy (comparing fst) . map (second Leaf)
+
+hstep :: (Ord a, Num a) => [(a, HTree b)] -> [(a, HTree b)]
+hstep ((w1,t1):(w2,t2):wts) = insertBy (comparing fst) (w1 + w2, Branch t1 t2) wts
+
+freq :: Ord a => [a] -> [(Int, a)]
+freq = map (length &&& head) . group . sort

Task/Huffman-coding/Haskell/huffman-coding-2.hs

@@ -0,0 +1,20 @@
+*Main> test "this is an example for huffman encoding"
+'p' : 00000
+'r' : 00001
+'g' : 00010
+'l' : 00011
+'n' : 001
+'m' : 0100
+'o' : 0101
+'c' : 01100
+'d' : 01101
+'h' : 0111
+'s' : 1000
+'x' : 10010
+'t' : 100110
+'u' : 100111
+'f' : 1010
+'i' : 1011
+'a' : 1100
+'e' : 1101
+' ' : 111

Task/Huffman-coding/Haskell/huffman-coding-3.hs

@@ -0,0 +1,12 @@
+import qualified Data.Set as S
+
+htree :: (Ord t, Num t, Ord a) => S.Set (t, HTree a) -> HTree a
+htree ts | S.null ts_1 = t1
+         | otherwise = htree ts_3
+           where
+             ((w1,t1), ts_1) = S.deleteFindMin ts
+             ((w2,t2), ts_2) = S.deleteFindMin ts_1
+             ts_3 = S.insert (w1 + w2, Branch t1 t2) ts_2
+
+huffmanTree :: (Ord w, Num w, Ord a) => [(w, a)] -> HTree a
+huffmanTree =  htree . S.fromList . map (second Leaf)

Task/Huffman-coding/Haskell/huffman-coding-4.hs

@@ -0,0 +1,17 @@
+import Data.List (sortBy, insertBy, sort, group)
+import Control.Arrow (second, (&&&))
+import Data.Ord (comparing)
+
+freq :: Ord a => [a] -> [(Int, a)]
+freq = map (length &&& head) . group . sort
+
+huffman :: [(Int, Char)] -> [(Char, String)]
+huffman = reduce . map (\(p, c) -> (p, [(c ,"")])) . sortBy (comparing fst)
+  where add (p1, xs1) (p2, xs2) = (p1 + p2, map (second ('0':)) xs1 ++ map (second ('1':)) xs2)
+        reduce [(_, ys)]  = sortBy (comparing fst) ys
+        reduce (x1:x2:xs) = reduce $ insertBy (comparing fst) (add x1 x2) xs
+
+test s = mapM_ (\(a, b) -> putStrLn ('\'' : a : "\' : " ++ b)) . huffman . freq $ s
+
+main = do
+    test "this is an example for huffman encoding"