Sunday, May 10, 2009

Huffman Tree construction

I finally got the tree construction done - 

Did not like two things though -

1. I had to write a two separate sorting functions .. Cant seem to create instance of Eq of Parametric types . 

2. The pattern matching seems a little cluttered.

data WeightedCharacter = WeightedCharacter { weight :: Int,
 character :: Char
}deriving (Show)

instance Eq WeightedCharacter where
 (WeightedCharacter a _) == (WeightedCharacter b _) = a==b

instance Ord WeightedCharacter where
 (WeightedCharacter a _) > (WeightedCharacter b _) = a > b
 (WeightedCharacter a _) >= (WeightedCharacter b _) = a >= b
 (WeightedCharacter a _) < (WeightedCharacter b _) = a < b
 (WeightedCharacter a _) <= (WeightedCharacter b _) = a <= b


type CharacterFrequencyTuple = (Int,Char)
{-
 repeats hello
  = [(1,'e'),(1,'h'),(1,'o'),(2,'l')]

-}
repeats :: String -> [CharacterFrequencyTuple]
repeats string = quickSort $ zip 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 [] = []


data Tree a = Node a (Tree a) (Tree a) | Leaf a
 deriving (Show)


huffman :: [Tree CharacterFrequencyTuple] -> [Tree CharacterFrequencyTuple]
huffman (min1:min2:rest) = huffman newList
 where
 newList
  | length rest /= 0 = sortTreeList ((merge min1 min2):rest) -- TODO Sorting of the list is required
  | otherwise = [merge min1 min2]
 merge (Node node left right) (Leaf leaf)
  | node <= leaf = Node (newWeight,'*') (Node node left right) (Leaf leaf)
  | otherwise = Node (newWeight,'*') (Leaf leaf) (Node node left right)
  where
  newWeight = (fst leaf) + (fst node)
 merge (Leaf leaf) (Node node left right)
  | node <= leaf = Node (newWeight,'*') (Node node left right) (Leaf leaf)
  | otherwise = Node (newWeight,'*') (Leaf leaf) (Node node left right)
  where
  newWeight = (fst leaf) + (fst node)
 merge (Leaf leaf1) (Leaf leaf2)
  | leaf1 <= leaf2 = Node (newWeight,'*') (Leaf leaf1) (Leaf leaf2)
  | otherwise = Node (newWeight,'*') (Leaf leaf2) (Leaf leaf1)
  where
  newWeight = (fst leaf1) + (fst leaf2)
huffman x = x


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 [] = []

sortTreeList (x:xs) = l1 ++ [x] ++ l2
 where
  l1 = sortTreeList [y | y <- xs, (lessThan y x)] 
  l2 = sortTreeList [y | y <- xs, (not (lessThan y x))] 
  lessThan (Node n1 _ _) (Node n2 _ _) = (fst n1) < (fst n2)
  lessThan (Node n1 _ _) (Leaf n2) = (fst n1) < (fst n2)
  lessThan (Leaf n1) (Node n2 _ _) = (fst n1) < (fst n2)
  lessThan (Leaf n1) (Leaf n2) = (fst n1) < (fst n2)
sortTreeList [] = [] 

main=do
 x <- getLine 
 let y1=unique x
 let y2=repeats x
 putStrLn (show y1)
 putStrLn (show y2)
 let y=map Leaf y2
 let z = huffman y
 putStrLn (show z)
 return ()



No comments: