```-- | 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 op l =
let
pointedList = pointList l

phase1 pointedList =
case removePointed pointedList of
Nothing -> error "huffmanFold requires a non-empty list"
Just (a1,pointedList2) ->
case removePointed pointedList2 of
Nothing -> a1 -- This is already the result of the folding
Just (a2,pointedList3) ->
case insertAndMovePointer pointedList3 (op a1 a2) of
Right pointedList4 -> phase1 pointedList4
Left queue -> phase2 queue
phase2 queue =
case removeQ queue of
-- Nothing can't happen
Just (a1,queue2) ->
case removeQ queue2 of
Just (a2,queue3) ->
phase2 (insertQ queue3 (op a1 a2))
Nothing -> a1 -- we have a result!
in
phase1 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 queue l) = show (queueToList queue, l)
-- | pointList makes a new pointed list with the pointer at the left.
pointList :: [a] -> PointedList a
pointList l = PointedList emptyQ 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 queue list) =
case removeQ queue of
Nothing ->
case list of
[] -> Nothing
a:list' -> Just (a,PointedList emptyQ list')
Just (a,queue') -> Just (a,PointedList queue' 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 queue list) a =
case list of
[] -> Left (insertQ queue a)
a2:list' ->
if a2<a
then insertAndMovePointer
(PointedList (insertQ queue a2) list') a
else
Right (PointedList (insertQ queue a) list)
```