huffman coding haskell

huffman-coding.cabal

cabal-version:      3.0
name:               huffman-coding
version:            0.1.0.0
author:             Jonathan Strickland
maintainer:         djanatyn@gmail.com
build-type:         Simple

common warnings
    ghc-options: -Wall

library
    import:           warnings
    exposed-modules:  Huffman
    build-depends:    base ^>=4.16.3.0
    hs-source-dirs:   .
    default-language: GHC2021

Huffman.hs

-- |
-- Haskell implementation of huffman coding lossless compression.
--
-- - <https://engineering.purdue.edu/ece264/17au/hw/HW13?alt=huffman>
module Huffman (Tree (..)) where

import Data.List (group, sort)

-- | Huffman coding tree.
data Tree a where
  Leaf :: a -> Tree a
  Branch :: (Tree a) -> (Tree a) -> Tree a
  deriving (Show)

-- | Frequency of letter occurence in a string.
data Frequency a where
  Frequency :: {char :: a, count :: Int} -> Frequency a
  deriving (Show, Eq)

-- | Sort frequencies by their count.
instance Eq a => Ord (Frequency a) where
  f1 `compare` f2 = count f1 `compare` count f2

-- | Sum frequencies of characters within a tree.
sumCount :: Tree (Frequency a) -> Int
sumCount (Leaf a) = count a
sumCount (Branch a b) = sumCount a + sumCount b

-- | Combine trees by comparing their summed character frequencies.
instance Semigroup (Tree (Frequency a)) where
  a <> b
    | sumCount a == sumCount b = Branch a b
    | sumCount a > sumCount b = Branch b a
    | sumCount a < sumCount b = Branch a b
    | otherwise = error "failed"

-- | Calculate frequency of letters.
frequencies :: String -> [Frequency Char]
frequencies = map (\c -> Frequency {char = head c, count = length c}) . group . sort

-- | Create a Huffman coding tree from a string.
buildTree :: String -> Tree (Frequency Char)
buildTree input = foldl1 (<>) (fmap Leaf . sort $ frequencies input)

main :: IO ()
main = print $ buildTree "go go gophers"