Adaptation of the solution to problem 50 at https://github.com/nilthehuman/H-99/blob/master/Logic.hs

Main.hs

module Main where
import Solution (huffmann)
import SolutionList (ListQueue(..))
import SolutionPQ   (Priority(..))

-- Uncomment one of these lines to pick the instance used
type Instance = ListQueue
-- type Instance = Priority

main = print $ huffmann i [('a',45),('b',13),('c',12),('d',16),('e',9),('f',5)]
    where i = id :: Instance a -> Instance a

Solution.hs

{-# LANGUAGE TypeFamilies #-}
module Solution where
import Utils (alignBy, get)

import Data.Maybe (fromJust)

-- | In order to be able to overload the definition of 'huffmann' to be backed
-- by either lists or actual priority queues, we use this typeclass.
-- 'pq a' is the type of "queues", where'a' is the type of the symbols
-- 'Root pq a' is the type of the trees held in the queue, whether real or
-- simulated.
-- Note that 'leaf' and 'node' have a parameter of type 'pq a' in case the new
-- node needs metadata based on the original queue.
-- I have attempted to make this parameter optional, but haven't succeeded yet.
class WeightedQueue pq where
    type Root pq :: * -> *
    empty  :: pq a
    push   :: Root pq a -> pq a -> pq a
    pop    :: pq a -> Maybe (Root pq a, pq a)
    size   :: pq a -> Int
    leaf   :: pq a -> (a, Int) -> Root pq a
    node   :: pq a -> Root pq a -> Root pq a -> Root pq a
    toList :: pq a -> [(a, Int, String)]

_char   = (\(c,w,p) -> c, \f (c,w,p) -> ((f c),w,p))
_weight = (\(c,w,p) -> w, \f (c,w,p) -> (c,(f w),p))
_path   = (\(c,w,p) -> p, \f (c,w,p) -> (c,w,(f p)))

huffmann :: (WeightedQueue pq, Eq a) => (pq a -> pq a) -> [(a, Int)] -> [(a, String)]
huffmann i xs = extract (map fst xs) . toList . i . until done go . initialize $ xs
    where initialize = foldl (\xs cw -> push (leaf xs cw) xs) empty

          go xs = maybe empty id $ do
              (n,xs') <- pop xs
              (n',xs'') <- pop xs'
              return $ push (node xs n n') xs''

          done = (<=1) . size

          extract :: Eq a => [a] -> [(a, Int, String)] -> [(a, String)]
          extract cs xs = map proj . fromJust $ alignBy eq cs xs
              where eq c x = c == get _char x
                    proj x = (get _char x, get _path x)

SolutionList.hs

{-# LANGUAGE TypeFamilies, TupleSections #-}
module SolutionList where
import Solution
import Utils (unless, chunk, get, set, over)

import Data.Function (on)
import Data.List (partition, sortBy)
import Data.Monoid

newtype ListQueue a = LQ { unLQ :: [((a,Int,String), Int)] }

_data = (\(w,r) -> w, \f (w,r) -> (f w, r))
_root = (\(w,r) -> r, \f (w,r) -> (w, f r))

instance WeightedQueue ListQueue where
    type Root ListQueue = ListQueue
    empty = LQ []
    push (LQ t) (LQ xs) = LQ (t ++ xs)
    pop xs = do
        xs' <- unless (null . unLQ) xs
        let (x:wrs) = orderedRoots xs'
        return (x, LQ . concatMap unLQ $ wrs)
        where orderedRoots = decorateSortBy flatten . gatherRoots
              flatten = getSum . mconcat . map extractWeight . unLQ
              extractWeight = Sum . get _weight . get _data
              decorateSortBy f = map snd . sortBy (compare `on` fst)
                . map (\x -> (f x, x))
    size = length . gatherRoots
    leaf xs (c,w) = LQ [updRoot xs ((c,w,""), undefined)]
    node xs l r = LQ $ map (update '0') (unLQ l) ++ map (update '1') (unLQ r)
        where update p = updRoot xs . (,undefined) . over _path (p:) . get _data
    toList = map fst . unLQ

updRoot = (set _root) . (+1) . maximum . (0:) . map (get _root) . unLQ
gatherRoots :: ListQueue a -> [ListQueue a]
gatherRoots = map LQ . chunk (\xs@(x:_) -> partition (eqRoot x) xs) . unLQ
    where eqRoot = (==) `on` get _root

SolutionPQ.hs

{-# LANGUAGE TypeFamilies #-}
module SolutionPQ where
import Solution

import Control.Arrow (first,second)

-- From the package 'pure-priority-queue'
import qualified Data.PurePriorityQueue as PQ

data Tree w a = Node w (Tree w a) (Tree w a) | Leaf w a
weight (Node w _ _) = w
weight (Leaf w _)   = w

newtype Priority a = Pr { unPr :: (PQ.MinMaxQueue Int (Tree Int a))}

instance WeightedQueue Priority where
    type Root Priority = Tree Int
    empty = Pr PQ.empty
    push t pq = Pr $ PQ.insert t (weight t) (unPr pq)
    pop = fmap (second Pr . first fst) . PQ.minView . unPr
    size = PQ.size . unPr
    leaf _ (c,w) = Leaf w c
    node _ l r = Node (weight l + weight r) l r
    toList = concatMap (inOrder "" . fst) . PQ.toAscList . unPr
        where inOrder p (Node _ l r) = inOrder ('0':p) l ++ inOrder ('1':p) r
              inOrder p (Leaf w c)   = [(c,w,reverse p)]

Utils.hs

module Utils where
import Prelude hiding (traverse)
import Control.Monad (mfilter)
import Data.List (unfoldr)
import Data.Traversable (traverse)
import Data.Monoid

-- { List utilities
-- | 'when p a' is 'Just a' if 'a' satisfies 'p' and 'Nothing' otherwise
--   'unless p = when (not . p)
when, unless :: (a -> Bool) -> a -> Maybe a
when p = mfilter p . Just
unless p = when (not . p)

-- | 'chunk g xs = fst g xs : snd (fst g xs : ...)' until the input is null
chunk :: ([a] -> ([a],[a])) -> [a] -> [[a]]
chunk g = unfoldr (fmap g . unless null)

-- | NOTE: This is a cleaner way of implementing 'consume' from
-- <https://github.com/nilthehuman/H-99/blob/master/Lists.hs>
consume f g a = foldl f a . chunk g

-- | 'alignBy eq [r1, r2, ...] xs = [x1, x2, ...]' where 'xi' is the first
-- element of 'xs' such that 'xi `eq` ri'
alignBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe [b]
alignBy eq rs xs = traverse (\r -> firstEqualling r xs) rs
    where firstEqualling r = getFirst . mconcat . map (First . when (eq r))
-- }

-- { Simple lenses, no type hackery. These are just getter/setter pairs.
-- In the following three functions, 'l :: (s -> a, (a -> b) -> (s -> t))'
get l   = fst l
set l v = over l (const v)
over l  = snd l
-- }