2015-07に記述,LZ78の実装.無駄が多い上にシリアライズに気を配ってないため,大抵の場合逆にサイズが増える

LZ78.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified Data.ByteString.Char8 as S
import qualified Data.IntMap           as I
import           Data.List
import qualified Data.Map              as M
import           Data.Maybe            ()
import           Data.Monoid           ()
import           System.Environment

main :: IO ()
main = do
  (mode : _) <- getArgs
  case mode of
    "-e" -> do
      putStrLn . show . encode =<< S.getContents
    "-d" -> do
      S.putStrLn . decode . read =<< getContents

type LZ78Word = (Int, Char)
type LZ78Dictionary = M.Map S.ByteString Int

encode :: S.ByteString -> [LZ78Word]
encode bs = reverse $ readWords bs (M.fromList [("", 0)]) []
  where readWords "" _ stash = stash
        readWords rest dict stash = let (w, newRest, newDict) = scanWord rest dict
                                    in readWords newRest newDict (w : stash)

scanWord :: S.ByteString -> LZ78Dictionary -> (LZ78Word, S.ByteString, LZ78Dictionary)
scanWord sb dict = next $ min 128 $ S.length sb
  where next i = let (pre, suf) = S.splitAt i sb
                 in case M.lookup pre dict of
                 Just wordIndex -> newResult wordIndex pre suf
                 Nothing -> next (i - 1)
        newResult wordIndex pre "" = ((wordIndex, S.last pre), "", updateDict pre)
        newResult wordIndex pre suf = ((wordIndex, S.head suf), S.tail suf, updateDict (pre `S.snoc` S.head suf))
        updateDict newWord = M.insert newWord (M.size dict) dict

type LZ78DecodeDictionary = I.IntMap S.ByteString

decode :: [LZ78Word] -> S.ByteString
decode ws = S.concat . reverse . snd $ foldl' withDict (I.fromList [(0, "")], []) ws
  where withDict (dict, bs) (i, w) = let nw = ((dict I.! i) `S.snoc` w)
                                     in (insertNewWord nw dict, nw : bs)
        insertNewWord w dict = I.insert (I.size dict) w dict