-- | This code does "Huffman" coding, using the queue implementation.  This
-- can be used for constructing Huffman encodings, or for computing factorials
-- efficiently.
module Util.Huffman(
   huffmanFold
   ) where

import Util.Queue

-- | huffmanFold op l
-- where op is associative, l is a nonempty monotonically increasing list,
-- and op has the property that (x1>=x2,y1>=y2) => (op x1 y1>=op x2 y2)
-- computes the fold of l with op, by repeatedly folding the smallest two
-- elements of the list until only one remains.
huffmanFold :: Ord a => (a -> a -> a) -> [a] -> a
huffmanFold :: (a -> a -> a) -> [a] -> a
huffmanFold a -> a -> a
op [a]
l =
   let
      pointedList :: PointedList a
pointedList = [a] -> PointedList a
forall a. [a] -> PointedList a
pointList [a]
l

      phase1 :: PointedList a -> a
phase1 PointedList a
pointedList =
         case PointedList a -> Maybe (a, PointedList a)
forall a. PointedList a -> Maybe (a, PointedList a)
removePointed PointedList a
pointedList of
            Maybe (a, PointedList a)
Nothing -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"huffmanFold requires a non-empty list"
            Just (a
a1,PointedList a
pointedList2) ->
               case PointedList a -> Maybe (a, PointedList a)
forall a. PointedList a -> Maybe (a, PointedList a)
removePointed PointedList a
pointedList2 of
                  Maybe (a, PointedList a)
Nothing -> a
a1 -- This is already the result of the folding
                  Just (a
a2,PointedList a
pointedList3) ->
                     case PointedList a -> a -> Either (Queue a) (PointedList a)
forall a.
Ord a =>
PointedList a -> a -> Either (Queue a) (PointedList a)
insertAndMovePointer PointedList a
pointedList3 (a -> a -> a
op a
a1 a
a2) of
                        Right PointedList a
pointedList4 -> PointedList a -> a
phase1 PointedList a
pointedList4
                        Left Queue a
queue -> Queue a -> a
phase2 Queue a
queue
      phase2 :: Queue a -> a
phase2 Queue a
queue =
         case Queue a -> Maybe (a, Queue a)
forall a. Queue a -> Maybe (a, Queue a)
removeQ Queue a
queue of
            -- Nothing can't happen
            Just (a
a1,Queue a
queue2) ->
               case Queue a -> Maybe (a, Queue a)
forall a. Queue a -> Maybe (a, Queue a)
removeQ Queue a
queue2 of
                  Just (a
a2,Queue a
queue3) ->
                     Queue a -> a
phase2 (Queue a -> a -> Queue a
forall a. Queue a -> a -> Queue a
insertQ Queue a
queue3 (a -> a -> a
op a
a1 a
a2))
                  Maybe (a, Queue a)
Nothing -> a
a1 -- we have a result!
   in
      PointedList a -> a
phase1 PointedList a
pointedList

-- ------------------------------------------------------------------------
-- PointedList operations
-- ------------------------------------------------------------------------

-- | effectively a list with a pointer in the middle which can only be
-- moved right.  The list should always be in increasing order.
data PointedList a = PointedList (Queue a)  [a]

instance Show a => Show (PointedList a) where
   show :: PointedList a -> [Char]
show (PointedList Queue a
queue [a]
l) = ([a], [a]) -> [Char]
forall a. Show a => a -> [Char]
show (Queue a -> [a]
forall a. Queue a -> [a]
queueToList Queue a
queue, [a]
l)
-- | pointList makes a new pointed list with the pointer at the left.
pointList :: [a] -> PointedList a
pointList :: [a] -> PointedList a
pointList [a]
l = Queue a -> [a] -> PointedList a
forall a. Queue a -> [a] -> PointedList a
PointedList Queue a
forall a. Queue a
emptyQ [a]
l

-- | removePointed gets the first element of a PointedList.  If the pointer
-- is at the start of the list, it is moved to the new head.
removePointed :: PointedList a -> Maybe (a,PointedList a)
removePointed :: PointedList a -> Maybe (a, PointedList a)
removePointed (PointedList Queue a
queue [a]
list) =
   case Queue a -> Maybe (a, Queue a)
forall a. Queue a -> Maybe (a, Queue a)
removeQ Queue a
queue of
      Maybe (a, Queue a)
Nothing ->
         case [a]
list of
            [] -> Maybe (a, PointedList a)
forall a. Maybe a
Nothing
            a
a:[a]
list' -> (a, PointedList a) -> Maybe (a, PointedList a)
forall a. a -> Maybe a
Just (a
a,Queue a -> [a] -> PointedList a
forall a. Queue a -> [a] -> PointedList a
PointedList Queue a
forall a. Queue a
emptyQ [a]
list')
      Just (a
a,Queue a
queue') -> (a, PointedList a) -> Maybe (a, PointedList a)
forall a. a -> Maybe a
Just (a
a,Queue a -> [a] -> PointedList a
forall a. Queue a -> [a] -> PointedList a
PointedList Queue a
queue' [a]
list)

-- | insertAndMovePointer inserts an element to the right of the pointer,
-- and moves the pointer after it.  It does this maintaining the invariant
-- that the pointed list is ordered, and we assume that all elements to the
-- left of the pointer are not more than the inserted element.
--
-- If the pointer reaches the end of the list, we instead of returning a
-- PointedList, return a queue containing the list contents.
insertAndMovePointer :: Ord a => PointedList a -> a
   -> Either (Queue a) (PointedList a)
insertAndMovePointer :: PointedList a -> a -> Either (Queue a) (PointedList a)
insertAndMovePointer (PointedList Queue a
queue [a]
list) a
a =
   case [a]
list of
      [] -> Queue a -> Either (Queue a) (PointedList a)
forall a b. a -> Either a b
Left (Queue a -> a -> Queue a
forall a. Queue a -> a -> Queue a
insertQ Queue a
queue a
a)
      a
a2:[a]
list' ->
         if a
a2a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
a
         then PointedList a -> a -> Either (Queue a) (PointedList a)
forall a.
Ord a =>
PointedList a -> a -> Either (Queue a) (PointedList a)
insertAndMovePointer
            (Queue a -> [a] -> PointedList a
forall a. Queue a -> [a] -> PointedList a
PointedList (Queue a -> a -> Queue a
forall a. Queue a -> a -> Queue a
insertQ Queue a
queue a
a2) [a]
list') a
a
         else
            PointedList a -> Either (Queue a) (PointedList a)
forall a b. b -> Either a b
Right (Queue a -> [a] -> PointedList a
forall a. Queue a -> [a] -> PointedList a
PointedList (Queue a -> a -> Queue a
forall a. Queue a -> a -> Queue a
insertQ Queue a
queue a
a) [a]
list)