Huffman Encoding

data WeightCharacterTuple = WeightCharacterTuple { weight :: Int, character :: Char }deriving (Show) instance Eq WeightCharacterTuple where a == b = (weight a) == (weight b) instance Ord WeightCharacterTuple where a > b = (weight a) > (weight b) a >= b = (weight a) >= (weight b) a < b = (weight a) < (weight b) a <= b = (weight a) <= (weight b) data Tree a = Node a (Tree a) (Tree a) | Leaf a deriving (Show) instance Eq a => Eq (Tree a) where (==) a b = (node a) == (node b) node x = case x of (Node n _ _) -> n (Leaf n) -> n instance Ord a => Ord (Tree a) where left >= right = (node left) >= (node right) left < right = (node left) < (node right) left > right = (node left) > (node right) left <= right = (node left) <= (node right) toFrequencyCharacterTuple :: String -> [WeightCharacterTuple] toFrequencyCharacterTuple string = quickSort $ zipWith WeightCharacterTuple counts uniqueLetters where counts = map (frequency string) uniqueLetters frequency :: String -> Char -> Int frequency (x:xs) c | c == x = 1 + frequency xs c | otherwise = frequency xs c frequency _ c = 0 uniqueLetters = unique string unique :: String -> String -- get the unique letters in the string unique (x:xs) = [x] ++ unique [y | y <- xs, y /= x ] unique [] = [] huffman :: [Tree WeightCharacterTuple] -> [Tree WeightCharacterTuple] huffman (min1:min2:rest) = huffman newList where newList | length rest /= 0 = quickSort ((merge min1 min2):rest) | otherwise = [merge min1 min2] where merge a b | a <= b = Node (WeightCharacterTuple newWeight '*') a b | otherwise = Node (WeightCharacterTuple newWeight '*') b a where newWeight = (weight (node a)) + (weight (node b)) huffman x = x x `endsWith` y = (take (length y) (reverse x)) == (reverse y) encode::WeightCharacterTuple -> Tree WeightCharacterTuple -> String encode w (Node n left right) = oneOf ('0':(encode w left)) ('1':(encode w right)) where oneOf x y | y `endsWith` "WRONG-LEAF" = x | otherwise = y encode w (Leaf l) | (character l) == (character w) = "" | otherwise = "WRONG-LEAF" quickSort (x:xs) = l1 ++ [x] ++ l2 -- items less than x + x + items bigger than x where l1 = quickSort [y | y <- xs, y < x] -- sorted items less than x l2 = quickSort [y | y <- xs, y >= x] -- sorted items greater than x quickSort [] = [] displayAllEncodings :: [WeightCharacterTuple] -> Tree WeightCharacterTuple -> String displayAllEncodings (x:xs) tree= (codeForX x) ++ "\n" ++ (displayAllEncodings xs tree) where codeForX (WeightCharacterTuple w c) = (show c) ++ " weight = " ++ (show w) ++ " code = " ++ (encode x tree) displayAllEncodings _ _ = [] main=do x <- getLine let tupleList=toFrequencyCharacterTuple x let inputTreeList=map Leaf tupleList let tree=huffman inputTreeList putStrLn (show tree) putStrLn (displayAllEncodings tupleList (tree!!0)) return ()