Lossless Data Compressions

Run-length encoding

http://en.wikipedia.org/wiki/Run-length_encoding

One of the easiest encoding method to write.

An implementatin in Haskell:

import Data.List (group)
main = do
  print $ runlength "AAAAABBCBADDDDDDDD"

runlength = concatMap f . group
  where
    f xs@(x:_) = x : show (length xs)

"A5B2C1B1A1D8"

Huffman coding

http://en.wikipedia.org/wiki/Huffman_coding

An implementatin in Haskell:

import Data.List (group, sort, sortBy)
import Data.Function (on)
import Data.Map (fromList, lookup)
import Data.Maybe (fromJust)
import Prelude hiding (lookup)

main = print $ huffman "AAAAABBCBADDDDDDDD"

huffman s = flip concatMap s $ fromJust . flip lookup (huffmanMap s)

huffmanMap s =
  let x = map head . sortBy (compare `on` length) . group . sort $ s in
      fromList $ zipWith ((,)) x (bits $ length x)
bits :: Int -> [[Int]]
bits length = (take length $ repeat 1) : reverse (take (length - 1) $ iterate (1 :) [0])

[1,0,1,0,1,0,1,0,1,0,1,1,0,1,1,0,1,1,1,1,1,1,0,1,0,0,0,0,0,0,0,0,0]

BPE: Byte Pair Encoding

http://en.wikipedia.org/wiki/Byte_pair_encoding

import Data.List (group, sort, sortBy, (\\))
import Data.Function (on)
import qualified Data.Map as M
import Data.Map (insert, empty, notMember)
import Data.Maybe (fromJust)
import Safe (fromJustDef)

main = do
  let orig = "ABCDCDABCDCDE"
  print orig
  let (encoded, table) = bpe orig
  print (encoded, table)
  print $ bpeDecode encoded table

bpe xs = bpe' xs empty
bpe' xs table =
  let x = head $ sortBy (flip compare `on` length) $ group $ sort $ zipWith ((,)) xs (tail xs) in
      if length x == 1
         then (xs, table)
         else let (a, b) = head x
                  new = pickupOther xs table in
                  bpe' (replace2 xs a b new) (insert new (a, b) table)

bpeDecode xs table = concatMap (replace (expand (M.map (\(a, b) -> [a, b]) table))) xs
  where
    replace :: M.Map Char String -> Char -> String
    replace expandedTable c = maybe [c] id $ M.lookup c expandedTable
    expand :: M.Map Char String -> M.Map Char String
    expand table = M.map (concatMap f) table
      where
        f :: Char -> String
        f c = maybe [c] (concatMap f) $ M.lookup c table

pickupOther xs table =
  head $ filter (flip notMember table) $ ['Z', 'Y'..'A'] \\ xs

replace2 (a:[]) _ _ _ = [a]
replace2 (a:b:xs) c d e
  | a == c && b == d = e : replace2 xs c d e
  | otherwise = a : replace2 (b : xs) c d e

• "ABCDCDABCDCDE"
• ("WWE",fromList [('W',('X','Z')),('X',('Y','Z')),('Y',('A','B')),('Z',('C','D'))])
• "ABCDCDABCDCDE"