-------------------------------------------------------------------------
--                              
--         Frequency.hs                         
--                              
--         Calculating the frequencies of words in a text, used in  
--         Huffman coding.                          
--                              
--         (c) Addison-Wesley, 1996-2011.                   
--                              
-------------------------------------------------------------------------

module Frequency ( frequency ) where

import Test.QuickCheck hiding ( frequency )

-- Calculate the frequencies of characters in a list.       
--                              
-- This is done by sorting, then counting the number of     
-- repetitions. The counting is made part of the merge      
-- operation in a merge sort.                   

frequency :: [Char] -> [ (Char,Int) ]

frequency :: [Char] -> [(Char, Int)]
frequency
  = ([(Char, Int)] -> [(Char, Int)] -> [(Char, Int)])
-> [(Char, Int)] -> [(Char, Int)]
forall a. ([a] -> [a] -> [a]) -> [a] -> [a]
mergeSort [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
freqMerge ([(Char, Int)] -> [(Char, Int)])
-> ([Char] -> [(Char, Int)]) -> [Char] -> [(Char, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Char, Int)] -> [(Char, Int)] -> [(Char, Int)])
-> [(Char, Int)] -> [(Char, Int)]
forall a. ([a] -> [a] -> [a]) -> [a] -> [a]
mergeSort [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
alphaMerge ([(Char, Int)] -> [(Char, Int)])
-> ([Char] -> [(Char, Int)]) -> [Char] -> [(Char, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (Char, Int)) -> [Char] -> [(Char, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Char -> (Char, Int)
forall {b} {a}. Num b => a -> (a, b)
start
    where
    start :: a -> (a, b)
start a
ch = (a
ch,b
1)

-- Merge sort parametrised on the merge operation. This is more 
-- general than parametrising on the ordering operation, since  
-- it permits amalgamation of elements with equal keys      
-- for instance.                            
--  
mergeSort :: ([a]->[a]->[a]) -> [a] -> [a]

mergeSort :: forall a. ([a] -> [a] -> [a]) -> [a] -> [a]
mergeSort [a] -> [a] -> [a]
merge [a]
xs
  | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2   = [a]
xs                    
  | Bool
otherwise       
      = [a] -> [a] -> [a]
merge (([a] -> [a] -> [a]) -> [a] -> [a]
forall a. ([a] -> [a] -> [a]) -> [a] -> [a]
mergeSort [a] -> [a] -> [a]
merge [a]
first)
              (([a] -> [a] -> [a]) -> [a] -> [a]
forall a. ([a] -> [a] -> [a]) -> [a] -> [a]
mergeSort [a] -> [a] -> [a]
merge [a]
second)  
        where
        first :: [a]
first  = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
half [a]
xs
        second :: [a]
second = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
half [a]
xs
        half :: Int
half   = ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

-- Order on first entry of pairs, with              
-- accumulation of the numeric entries when equal first entry.

alphaMerge :: [(Char,Int)] -> [(Char,Int)] -> [(Char,Int)]  

alphaMerge :: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
alphaMerge [(Char, Int)]
xs [] = [(Char, Int)]
xs
alphaMerge [] [(Char, Int)]
ys = [(Char, Int)]
ys
alphaMerge ((Char
p,Int
n):[(Char, Int)]
xs) ((Char
q,Int
m):[(Char, Int)]
ys)
  | (Char
pChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
q)  = (Char
p,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) (Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
alphaMerge [(Char, Int)]
xs [(Char, Int)]
ys        
  | (Char
pChar -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<Char
q)   = (Char
p,Int
n) (Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
alphaMerge [(Char, Int)]
xs ((Char
q,Int
m)(Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
:[(Char, Int)]
ys)  
  | Bool
otherwise   = (Char
q,Int
m) (Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
alphaMerge ((Char
p,Int
n)(Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
:[(Char, Int)]
xs) [(Char, Int)]
ys  

-- Lexicographic ordering, second field more significant.
--      
freqMerge :: [(Char,Int)] -> [(Char,Int)] -> [(Char,Int)]   

freqMerge :: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
freqMerge [(Char, Int)]
xs [] = [(Char, Int)]
xs
freqMerge [] [(Char, Int)]
ys = [(Char, Int)]
ys
freqMerge ((Char
p,Int
n):[(Char, Int)]
xs) ((Char
q,Int
m):[(Char, Int)]
ys)
  | (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
m Bool -> Bool -> Bool
|| (Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
m Bool -> Bool -> Bool
&& Char
pChar -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<Char
q)) 
    = (Char
p,Int
n) (Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
freqMerge [(Char, Int)]
xs ((Char
q,Int
m)(Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
:[(Char, Int)]
ys)   
  | Bool
otherwise 
    = (Char
q,Int
m) (Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
: [(Char, Int)] -> [(Char, Int)] -> [(Char, Int)]
freqMerge ((Char
p,Int
n)(Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
:[(Char, Int)]
xs) [(Char, Int)]
ys   

-- QuickCheck property

prop_mergeSort :: [Int] -> Bool

prop_mergeSort :: [Int] -> Bool
prop_mergeSort [Int]
xs =
    [Int] -> Bool
forall {a}. Ord a => [a] -> Bool
sorted (([Int] -> [Int] -> [Int]) -> [Int] -> [Int]
forall a. ([a] -> [a] -> [a]) -> [a] -> [a]
mergeSort [Int] -> [Int] -> [Int]
forall {a}. Ord a => [a] -> [a] -> [a]
merge [Int]
xs) 
           where
             sorted :: [a] -> Bool
sorted [] = Bool
True
             sorted [a
_] = Bool
True
             sorted (a
x:a
y:[a]
ys) = a
xa -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
y Bool -> Bool -> Bool
&& [a] -> Bool
sorted (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)

             merge :: [a] -> [a] -> [a]
merge [] [a]
xs = [a]
xs
             merge [a]
ys [] = [a]
ys
             merge (a
x:[a]
xs) (a
y:[a]
ys) 
                  | a
xa -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
y      = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge [a]
xs (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
                  | Bool
otherwise = a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys