Haskell Huffman

import Data.List
import qualified Data.Map.Strict as M
import Data.Monoid
import Data.Ord

-- |Queue datatype and operations ----

data Queue a = Queue [a] [a]
    deriving Show

empty = Queue [] []

push x (Queue xs ys) = Queue (x:xs) ys

pop (Queue [] []) = Nothing
pop (Queue xs []) = pop (Queue [] (reverse xs))
pop (Queue xs (x:ys)) = Just (x, Queue xs ys)

fromList :: [a] -> Queue a
fromList = foldr push empty

fromOrderedList :: [a] -> Queue a
fromOrderedList xs = Queue [] xs

distribution :: Ord a => [a] -> [(a, Int)]
distribution str = sortBy (comparing snd) $ map (\g@(x:_) -> (x, length g)) . group . sort $ str where

takeMins :: (a -> a -> Ordering ) -> Int -> Queue a -> Queue a -> ([a], Queue a, Queue a)
takeMins f i xs ys = go i [] xs ys where
    go 0 acc xs ys = (acc, xs, ys)
    go i acc xs ys = let i' = i - 1 in case (pop xs, pop ys) of
        (Nothing, Nothing) -> (acc, xs, ys)
        (Just (x, xs'), Nothing) -> go i' (x:acc) xs' ys
        (Nothing, Just (y, ys')) -> go i' (y:acc) xs ys'
        (Just (x, xs'), Just (y, ys')) -> case f x y of
            LT -> go i' (x:acc) xs' ys
            _  -> go i' (y:acc) xs ys'

-- |The Huffman itself ----

type Weight = Float
data Tree a
    = Leaf { weight :: Weight, sym :: a }
    | Internal { weight :: Weight, left, right :: Tree a }
    deriving Show

combine :: Tree a -> Tree a -> Tree a
combine n1 n2 = Internal (weight n1 + weight n2) n1 n2

buildCodeTree :: (Ord a) => [a] -> Tree a
buildCodeTree str = go start empty where
    start = fromOrderedList $ map f $ distribution str
    f (x, c) = Leaf w x where
        w = fromIntegral c / l
    l = fromIntegral $ length str
    go xs ys = case takeMins (comparing weight) 2 xs ys of
        ([x], _, _) -> x
        ([x, y], xs', ys') -> go xs' $ push (combine x y) ys'
        (_, xs', ys') -> error "Empty queues"

type CodeMap a = M.Map a [Bool]

buildCodeValues :: Ord a => Tree a -> CodeMap a
buildCodeValues tree = go [] tree where
    go pref (Leaf _ c) = M.singleton c (reverse pref)
    go pref (Internal _ l r) = M.union
        (go (False:pref) l)
        (go (True:pref) r)

buildCodeTable = buildCodeValues . buildCodeTree

compress :: CodeMap Char -> String -> String
compress cv str = concatMap (showBin . (cv M.!)) str where
    showBin = map (\x -> if x then '1' else '0')

compressText :: String -> String
compressText str = compress cv str where
    cv = buildCodeTable str

calcProfit :: String -> Float
calcProfit str = fromIntegral comprLen / fromIntegral initLen where
    cv = buildCodeTable str
    initEntr = ceiling $ logBase 2 $ fromIntegral $ length $ M.keys cv
    initLen = initEntr * length str
    comprLen = length $ compress cv str