packages feed

compressed 3.0.0.1 → 3.0.1

raw patch · 13 files changed

+632/−551 lines, 13 filesdep ~comonaddep ~keysdep ~pointedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: comonad, keys, pointed, reducers, semigroupoids, semigroups

API changes (from Hackage documentation)

Files

+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,13 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#
.travis.yml view
@@ -1,1 +1,8 @@ language: haskell+notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313compressed\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ CHANGELOG.markdown view
@@ -0,0 +1,6 @@+3.0.1+-----+* Refactored the build system+* IRC buildbot notification+* Started the CHANGELOG+* Added `README.markdown`
− Data/Compressed/Internal/LZ78.hs 
@@ -1,235 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ParallelListComp #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Generator.LZ78--- Copyright   :  (c) Edward Kmett 2009-2012--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  non-portable (type families)------ Compression algorithms are all about exploiting redundancy. When applying--- an expensive 'Reducer' to a redundant source, it may be better to--- extract the structural redundancy that is present. 'LZ78' is a compression--- algorithm that does so, without requiring the dictionary to be populated--- with all of the possible values of a data type unlike its later--- refinement LZW, and which has fewer comparison reqirements during encoding--- than its earlier counterpart LZ77.--------------------------------------------------------------------------------module Data.Compressed.Internal.LZ78-    (-    -- * Lempel-Ziv 78-      Token(..)-    , LZ78(..)-    -- * Encoding-    , encode    -- /O(n)/-    , encodeOrd -- /O(n log n)/-    , encodeEq  -- /O(n^2)/-    -- * Decoding (reduce)-    , decode-    -- * Recoding-    , recode    -- /O(n)/-    , recodeOrd -- /O(n log n)/-    , recodeEq  -- /O(n^2)/-    -- * Unsafe (exposes internal structure)-    , Entry(..)-    , entries-    ) where--import Control.Applicative-import qualified Data.Sequence as Seq-import Data.Sequence ((|>))-import qualified Data.Map as Map-import qualified Data.HashMap.Lazy as HashMap-import qualified Data.List as List-import Data.Functor.Extend-import Data.Generator-import Data.Function (on)-import Data.Key as Key-import Data.Foldable-import Data.Traversable-import Data.Semigroup-import Data.Pointed-import Text.Read-import Control.Comonad-import Data.Hashable-import Data.Semigroup.Reducer (Reducer(..), Count(..))--data Token a = Token {-# UNPACK #-} !Int a deriving (Eq, Ord)--instance Functor Token where-  fmap f (Token i a) = Token i (f a)--instance Foldable Token where-  foldMap f (Token _ a) = f a--instance Traversable Token where-  traverse f (Token i a) = Token i <$> f a--instance Extend Token where-  extended = extend--instance Comonad Token where-  extend f t@(Token i _) = Token i (f t)-  duplicate t@(Token i _) = Token i t-  extract (Token _ a) = a--instance Hashable a => Hashable (Token a) where-  hashWithSalt s (Token i a) = s `hashWithSalt` i `hashWithSalt` a---- | An LZ78 compressed 'Generator'.-data LZ78 a-  = Cons {-# UNPACK #-} !(Token a) (LZ78 a)-  | Nil--instance Show a => Show (LZ78 a) where-  showsPrec d xs = showParen (d > 10) $-    showString "encode " . showsPrec 11 (toList xs)--instance Eq a => Eq (LZ78 a) where-  (==) = (==) `on` decode--instance Ord a => Ord (LZ78 a) where-  compare = compare `on` decode--instance (Read a, Hashable a, Eq a) => Read (LZ78 a) where-  readPrec = parens $ prec 10 $ do-    Ident "encode" <- lexP-    encode <$> step readPrec--instance Generator (LZ78 a) where-  type Elem (LZ78 a) = a-  mapTo = go (Seq.singleton mempty) where-    go _ _ m Nil = m-    go s f m (Cons (Token w c) ws) = m `mappend` go (s |> v) f v ws where-      v = Seq.index s w `mappend`  unit (f c)--instance Functor LZ78 where-  fmap f (Cons (Token i a) as) = Cons (Token i (f a)) (fmap f as)-  fmap _ Nil = Nil-  a <$ xs = go 0 (getCount (reduce xs)) where-     go !_ 0 = Nil-     go k  n | n > k = Cons (Token k a) (go (k + 1) (n - k - 1))-             | otherwise = Cons (Token (n - 1) a) Nil--instance Pointed LZ78 where-  point a = Cons (Token 0 a) Nil--instance Foldable LZ78 where-  foldMap f = unwrapMonoid . mapReduce f-  fold      = unwrapMonoid . reduce---- | /O(n)/ Construct an LZ78-compressed 'Generator' using a 'HashMap' internally.-encode :: (Hashable a, Eq a) => [a] -> LZ78 a-encode = go HashMap.empty 1 0 where-  go _ _ _ [] = Nil-  go _ _ p [c] = Cons (Token p c) Nil-  go d f p (c:cs) = let t = Token p c in case HashMap.lookup t d of-    Just p' -> go d f p' cs-    Nothing -> Cons t (go (HashMap.insert t f d) (succ f) 0 cs)---- | /O(n log n)/ Contruct an LZ78-compressed 'Generator' using a 'Map' internally.-encodeOrd :: Ord a => [a] -> LZ78 a-encodeOrd = go Map.empty 1 0 where-  go _ _ _ [] = Nil-  go _ _ p [c] = Cons (Token p c) Nil-  go d f p (c:cs) = let t = Token p c in case Map.lookup t d of-    Just p' -> go d f p' cs-    Nothing -> Cons t (go (Map.insert t f d) (succ f) 0 cs)---- | /O(n^2)/ Contruct an LZ78-compressed 'Generator' using a list internally, requires an instance of Eq,--- less efficient than encode.-encodeEq :: Eq a => [a] -> LZ78 a-encodeEq = go [] 1 0 where-  go _ _ _ [] = Nil-  go _ _ p [c] = Cons (Token p c) Nil-  go d f p (c:cs) = let t = Token p c in case List.lookup t d of-    Just p' -> go d f p' cs-    Nothing -> Cons t (go ((t, f):d) (succ f) 0 cs)---- | A type-constrained 'reduce' operation-decode :: LZ78 a -> [a]-decode = reduce---- | /O(n)/. Recompress with 'Hashable'-recode :: (Eq a, Hashable a) => LZ78 a -> LZ78 a-recode = encode . decode---- | /O(n log n)/. Recompress with 'Ord'-recodeOrd :: Ord a => LZ78 a -> LZ78 a-recodeOrd = encodeOrd . decode---- | /O(n^2)/. Recompress with 'Eq'-recodeEq :: Eq a => LZ78 a -> LZ78 a-recodeEq = encodeEq . decode--data Entry i a = Entry !i a deriving (Show,Read)--instance Functor (Entry i) where-  fmap f (Entry i a) = Entry i (f a)--instance Extend (Entry i) where-  extended = extend--instance Comonad (Entry i) where-  extend f e@(Entry i _) = Entry i (f e)-  duplicate e@(Entry i _) = Entry i e-  extract (Entry _ a) = a--instance Eq i => Eq (Entry i a) where-  Entry i _ == Entry j _ = i == j--instance Ord i => Ord (Entry i a) where-  compare (Entry i _) (Entry j _) = compare i j--instance Hashable i => Hashable (Entry i a) where-  hashWithSalt n (Entry i _) = hashWithSalt n i---- | exposes internal structure-entries :: LZ78 a -> LZ78 (Entry Int a)-entries = go 0 where-  go k (Cons (Token i t) xs) = Cons (Token i (Entry k t)) $ (go $! k + 1) xs-  go _ Nil = Nil--instance Applicative LZ78 where-  pure a = Cons (Token 0 a) Nil-  fs <*> as = fmap extract $ encode $ do-    Entry i f <- decode (entries fs)-    Entry j a <- decode (entries as)-    return $ Entry (i,j) (f a)-  as *> bs = fmap extract $ encode $ Prelude.concat $ replicate (reduceWith getCount as)  $  decode (entries bs)-  as <* bs = fmap extract $ encode $ Prelude.concat $ replicate (reduceWith getCount bs) <$> decode (entries as)--instance Monad LZ78 where-  return a = Cons (Token 0 a) Nil-  (>>) = (*>)-  as >>= k = fmap extract $ encode $ do-    Entry i a <- decode (entries as)-    Entry j b <- decode (entries (k a))-    return $ Entry (i,j) b--instance Adjustable LZ78 where-  adjust f i = fmap extract . encode . adjust (Entry (-1) . f . extract) i . decode . entries--type instance Key LZ78 = Int--instance Lookup LZ78 where-  lookup i xs = Key.lookup i (decode xs)--instance Indexable LZ78 where-  index xs i = index (decode xs) i--instance FoldableWithKey LZ78 where-  foldMapWithKey f xs = foldMapWithKey f (decode xs)--instance Zip LZ78 where-  zipWith f as bs = extract <$> encode-    [ Entry (i,j) (f a b)-    | Entry i a <- decode (entries as)-    | Entry j b <- decode (entries bs)-    ]--
− Data/Compressed/LZ78.hs 
@@ -1,35 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Compressed.LZ78--- Copyright   :  (c) Edward Kmett 2009-2011--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  non-portable (type families)------ Compression algorithms are all about exploiting redundancy. When applying--- an expensive 'Reducer' to a redundant source, it may be better to --- extract the structural redundancy that is present. 'LZ78' is a compression--- algorithm that does so, without requiring the dictionary to be populated--- with all of the possible values of a data type unlike its later --- refinement LZW, and which has fewer comparison reqirements during encoding--- than its earlier counterpart LZ77. --------------------------------------------------------------------------------module Data.Compressed.LZ78 -    ( -    -- * Lempel-Ziv 78 -      LZ78-    -- * Encoding-    , encode    -- /O(n)/-    , encodeOrd -- /O(n log n)/-    , encodeEq  -- /O(n^2)/-    -- * Decoding (reduce)-    , decode-    -- * Recoding-    , recode    -- /O(n)/-    , recodeOrd -- /O(n log n)/-    , recodeEq  -- /O(n^2)/-    ) where--import Data.Compressed.Internal.LZ78
− Data/Compressed/RunLengthEncoding.hs 
@@ -1,273 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Compressed.RunLengthEncoding--- Copyright   :  (c) Edward Kmett 2009-2012--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Compression algorithms are all about exploiting redundancy. When applying--- an expensive 'Reducer' to a redundant source, it may be better to --- extract the structural redundancy that is present. Run length encoding--- can do so for long runs of identical inputs.-------------------------------------------------------------------------------module Data.Compressed.RunLengthEncoding-    ( RLE(..)-    , Run-    , runLength-    , decode-    , encode-    , recode-    , toRuns-    , fromRuns-    ) where--import Data.Foldable-import Data.Semigroup-import Data.Semigroup.Reducer-import Data.Semigroup.Foldable-import Data.Hashable-import Data.Function (on)-import Data.Functor.Bind-import Data.Functor.Extend-import Control.Comonad-import Data.FingerTree (FingerTree,(|>),(<|),ViewL(..),ViewR(..),(><),viewl,viewr, Measured(..), split)-import qualified Data.FingerTree as F-import Data.Generator-import Data.Pointed-import Data.Key-import Control.Applicative---- | A single run with a strict length-data Run a = Run {-# UNPACK #-} !Int a deriving (Eq,Show)--runLength :: Run a -> Int-runLength (Run n _) = n---- lexicographical order-instance Ord a => Ord (Run a) where-  compare (Run n a) (Run m b) = case compare a b of-    LT -> LT-    GT -> GT-    EQ -> compare n m--instance Extend Run where-  extended = extend--instance Comonad Run where-  duplicate r@(Run i _) = Run i r-  extend f r@(Run i _) = Run i (f r)-  extract (Run _ a) = a--instance Functor Run where-  fmap f (Run n a) = Run n (f a)-  a <$ Run n _ = Run n a--instance Pointed Run where-  point = Run 1--instance Apply Run where-  Run n f <.> Run m a = Run (n * m) (f a)-  Run n _  .> Run m a = Run (n * m) a-  Run n a <.  Run m _ = Run (n * m) a--instance ComonadApply Run where-  Run n f <@> Run m a = Run (n * m) (f a)-  Run n _  @> Run m a = Run (n * m) a-  Run n a <@  Run m _ = Run (n * m) a--instance Applicative Run where-  pure = Run 1-  Run n f <*> Run m a = Run (n * m) (f a)-  Run n _  *> Run m a = Run (n * m) a-  Run n a <*  Run m _ = Run (n * m) a--instance Bind Run where-  Run n a >>- f = case f a of-    Run m b -> Run (n * m) b- -instance Monad Run where-  return = Run 1-  Run n _ >> Run m b = Run (n * m) b-  Run n a >>= f = case f a of-    Run m b -> Run (n * m) b--instance Foldable Run where-  foldMap k (Run y0 x0) = f (k x0) y0 where-    f x y-      | even y = f (x `mappend` x) (y `quot` 2)-      | y == 1 = x-      | otherwise = g (x `mappend` x) ((y - 1) `quot` 2) x-    g x y z-      | even y = g (x `mappend` x) (y `quot` 2) z-      | y == 1 = x `mappend` z-      | otherwise = g (x `mappend` x) ((y - 1) `quot` 2) (x `mappend` z)-  {-# INLINE foldMap #-}--instance Foldable1 Run where-  foldMap1 k (Run y0 x0) = f (k x0) y0 where-    f x y-      | even y = f (x <> x) (y `quot` 2)-      | y == 1 = x-      | otherwise = g (x <> x) ((y - 1) `quot` 2) x-    g x y z-      | even y = g (x <> x) (y `quot` 2) z-      | y == 1 = x <> z-      | otherwise = g (x <> x) ((y - 1) `quot` 2) (x <> z)-  {-# INLINE foldMap1 #-}--instance Measured Count (Run a) where-  measure (Run n _) = Count n---- | A 'Generator' which supports efficient 'mapReduce' operations over run-length encoded data.-newtype RLE a = RLE { getRLE :: FingerTree Count (Run a) } --toRuns :: RLE a -> [Run a]-toRuns = toList . getRLE--fromRuns :: [Run a] -> RLE a-fromRuns = RLE . F.fromList --instance Eq a => Semigroup (RLE a) where-  RLE l <> RLE r = go (viewr l) (viewl r) where-    go EmptyR  _ = RLE r-    go _  EmptyL = RLE l-    go (l' :> Run m a) (Run n b :< r')-      | a == b     = RLE ((l' |> Run (m+n) a) >< r')-      | otherwise  = RLE (l >< r)--instance Functor RLE where-  fmap f = RLE . F.fmap' (fmap f) . getRLE--instance Pointed RLE where-  point = RLE . F.singleton . pure--instance Apply RLE where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Applicative RLE where-  pure = RLE . F.singleton . pure-  RLE fs <*> RLE as = RLE $ F.fromList $ do-    Run n f <- toList fs-    Run m a <- toList as-    return $ Run (n * m) (f a)-  RLE as <* RLE bs = RLE $ F.fmap' (\(Run n a) -> Run (n * m) a) as where-    m = reduceWith getCount bs-  RLE as *> RLE bs = RLE $ mconcat $ replicate (reduceWith getCount as) bs--instance Bind RLE where-  (>>-) = (>>=)--instance Monad RLE where-  return = RLE . F.singleton . pure -  (>>) = (*>)-  RLE xs >>= f = RLE $ mconcat [ mconcat $ replicate n (getRLE (f a)) | Run n a <- toList xs ]- -instance Eq a => Reducer a (RLE a) where-  unit = pure-  cons a (RLE r) = case viewl r of-    EmptyL -> pure a-    Run n b :< r' -      | a == b    -> RLE (Run (n+1) a <| r')-      | otherwise -> RLE (Run 1     a <| r )-  snoc (RLE l) a = case viewr l of-    EmptyR -> pure a-    l' :> Run n b -      | a == b    -> RLE (l' |> Run (n+1) b)-      | otherwise -> RLE (l  |> Run 1 a   )--instance Eq a => Monoid (RLE a) where-  mempty = RLE mempty-  mappend = (<>)--instance Foldable RLE where-  foldMap f = foldMap (foldMap f) . getRLE--instance Generator (RLE a) where-  type Elem (RLE a) = a-  mapReduce f = foldMap (unit . f)--instance Hashable a => Hashable (RLE a) where-  hashWithSalt n = hashWithSalt n . toList--instance Eq a => Eq (RLE a) where-  (==) = (==) `on` toList  -- todo stride through aligning--instance Zip RLE where-  zipWith f (RLE xs0) (RLE ys0) = RLE $ case toList xs0 of-    [] -> mempty-    (Run n0 a0:as0) -> case toList ys0 of -      [] -> mempty-      (Run m0 b0:bs0) -> go n0 a0 as0 m0 b0 bs0 -    where-      go !n !a !as !m !b !bs = case compare n m of -        LT -> Run n (f a b) <| case as of-          [] -> mempty-          (Run n' a':as') -> go n' a' as' (m - n) b bs-        EQ -> Run n (f a b) <| case as of-          [] -> mempty-          (Run n' a':as') -> case bs of-             [] -> mempty-             (Run m' b':bs') -> go n' a' as' m' b' bs'-        GT -> Run m (f a b) <| case bs of-          [] -> mempty-          (Run m' b':bs') -> go (n - m) a as m' b' bs'-          -type instance Key RLE = Int--instance Lookup RLE where-  lookup i (RLE xs) -    | i < 0 = Nothing-    | otherwise = case viewl $ snd $ split (\n -> getCount n > i) xs of-      Run _ a :< _ -> Just a-      EmptyL       -> Nothing --instance Adjustable RLE where-  adjust f i (RLE xs) = RLE $ case viewl r of-    EmptyL -> xs-    Run n a :< r' -> -      let -        k = i - getCount (measure l)-        infixr 4 <?-        Run 0 _ <? ys = ys-        Run m b <? ys = Run m b <| ys-     in l >< (Run k a <? Run 1 (f a) <? Run (n - k - 1) a <? r')-    where -      (l,r) = split (\n -> getCount n > i) xs---encode :: (Generator c, Eq (Elem c)) => c -> RLE (Elem c)-encode = reduce-{-# RULES "encode/recode"     encode = recode #-}-{-# RULES "encode/encodeList" encode = encodeList #-}--decode :: RLE a -> [a]-decode = reduce--recode :: Eq a => RLE a -> RLE a-recode (RLE xs0) = case toList xs0 of -  [] -> RLE mempty-  (Run n0 a0:as0) -> RLE $ go n0 a0 as0-  where-    go n a [] = F.singleton (Run n a)-    go n a (Run m b:bs)-      | a == b = go (n + m) a bs-      | otherwise = Run n a <| go m b bs--encodeList :: Eq a => [a] -> RLE a-encodeList []       = RLE mempty-encodeList (a0:as0) = RLE $ go 1 a0 as0-  where-    go n a [] = F.singleton (Run n a)-    go n a (b:bs) -      | a == b    = go (n + 1) a bs-      | otherwise = Run n a <| go 1 b bs
+ README.markdown view
@@ -0,0 +1,16 @@+compressed+==========++[![Build Status](https://secure.travis-ci.org/ekmett/compressed.png?branch=master)](http://travis-ci.org/ekmett/compressed)++This package provides compressed data structures for LZ78 and run length encoding. Their primary benefit is that if you go+to decompress them you can decompress them in an arbitrary `Monoid`.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
compressed.cabal view
@@ -1,6 +1,6 @@ name:          compressed category:      Data, Compression, MapReduce-version:       3.0.0.1+version:       3.0.1 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -13,7 +13,13 @@ synopsis:      Compressed containers and reducers description:   Compressed containers and reducers build-type:    Simple-extra-source-files: .travis.yml+extra-source-files:+  .ghci+  .gitignore+  .vim.custom+  .travis.yml+  CHANGELOG.markdown+  README.markdown  source-repository head   type: git@@ -27,12 +33,12 @@     fingertree             >= 0.0.1    && < 0.1,     hashable               >= 1.1.2.1  && < 1.3,     unordered-containers   >= 0.2.1    && < 0.3,-    semigroups             >= 0.8.3.1  && < 0.9,-    semigroupoids          >= 3.0      && < 3.1,-    comonad                >= 3.0      && < 3.1,-    pointed                >= 3.0      && < 3.1,-    keys                   >= 3.0      && < 3.1,-    reducers               >= 3.0      && < 3.1+    semigroups             >= 0.8.3.1,+    semigroupoids          >= 3,+    comonad                >= 3,+    pointed                >= 3,+    keys                   >= 3,+    reducers               >= 3    exposed-modules:     Data.Compressed.LZ78@@ -40,3 +46,4 @@     Data.Compressed.Internal.LZ78    ghc-options: -Wall+  hs-source-dirs: src
+ src/Data/Compressed/Internal/LZ78.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ParallelListComp #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generator.LZ78+-- Copyright   :  (c) Edward Kmett 2009-2012+-- License     :  BSD-style+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (type families)+--+-- Compression algorithms are all about exploiting redundancy. When applying+-- an expensive 'Reducer' to a redundant source, it may be better to+-- extract the structural redundancy that is present. 'LZ78' is a compression+-- algorithm that does so, without requiring the dictionary to be populated+-- with all of the possible values of a data type unlike its later+-- refinement LZW, and which has fewer comparison reqirements during encoding+-- than its earlier counterpart LZ77.+-----------------------------------------------------------------------------++module Data.Compressed.Internal.LZ78+    (+    -- * Lempel-Ziv 78+      Token(..)+    , LZ78(..)+    -- * Encoding+    , encode    -- /O(n)/+    , encodeOrd -- /O(n log n)/+    , encodeEq  -- /O(n^2)/+    -- * Decoding (reduce)+    , decode+    -- * Recoding+    , recode    -- /O(n)/+    , recodeOrd -- /O(n log n)/+    , recodeEq  -- /O(n^2)/+    -- * Unsafe (exposes internal structure)+    , Entry(..)+    , entries+    ) where++import Control.Applicative+import qualified Data.Sequence as Seq+import Data.Sequence ((|>))+import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.List as List+import Data.Functor.Extend+import Data.Generator+import Data.Function (on)+import Data.Key as Key+import Data.Foldable+import Data.Traversable+import Data.Semigroup+import Data.Pointed+import Text.Read+import Control.Comonad+import Data.Hashable+import Data.Semigroup.Reducer (Reducer(..), Count(..))++data Token a = Token {-# UNPACK #-} !Int a deriving (Eq, Ord)++instance Functor Token where+  fmap f (Token i a) = Token i (f a)++instance Foldable Token where+  foldMap f (Token _ a) = f a++instance Traversable Token where+  traverse f (Token i a) = Token i <$> f a++instance Extend Token where+  extended = extend++instance Comonad Token where+  extend f t@(Token i _) = Token i (f t)+  duplicate t@(Token i _) = Token i t+  extract (Token _ a) = a++instance Hashable a => Hashable (Token a) where+  hashWithSalt s (Token i a) = s `hashWithSalt` i `hashWithSalt` a++-- | An LZ78 compressed 'Generator'.+data LZ78 a+  = Cons {-# UNPACK #-} !(Token a) (LZ78 a)+  | Nil++instance Show a => Show (LZ78 a) where+  showsPrec d xs = showParen (d > 10) $+    showString "encode " . showsPrec 11 (toList xs)++instance Eq a => Eq (LZ78 a) where+  (==) = (==) `on` decode++instance Ord a => Ord (LZ78 a) where+  compare = compare `on` decode++instance (Read a, Hashable a, Eq a) => Read (LZ78 a) where+  readPrec = parens $ prec 10 $ do+    Ident "encode" <- lexP+    encode <$> step readPrec++instance Generator (LZ78 a) where+  type Elem (LZ78 a) = a+  mapTo = go (Seq.singleton mempty) where+    go _ _ m Nil = m+    go s f m (Cons (Token w c) ws) = m `mappend` go (s |> v) f v ws where+      v = Seq.index s w `mappend`  unit (f c)++instance Functor LZ78 where+  fmap f (Cons (Token i a) as) = Cons (Token i (f a)) (fmap f as)+  fmap _ Nil = Nil+  a <$ xs = go 0 (getCount (reduce xs)) where+     go !_ 0 = Nil+     go k  n | n > k = Cons (Token k a) (go (k + 1) (n - k - 1))+             | otherwise = Cons (Token (n - 1) a) Nil++instance Pointed LZ78 where+  point a = Cons (Token 0 a) Nil++instance Foldable LZ78 where+  foldMap f = unwrapMonoid . mapReduce f+  fold      = unwrapMonoid . reduce++-- | /O(n)/ Construct an LZ78-compressed 'Generator' using a 'HashMap' internally.+encode :: (Hashable a, Eq a) => [a] -> LZ78 a+encode = go HashMap.empty 1 0 where+  go _ _ _ [] = Nil+  go _ _ p [c] = Cons (Token p c) Nil+  go d f p (c:cs) = let t = Token p c in case HashMap.lookup t d of+    Just p' -> go d f p' cs+    Nothing -> Cons t (go (HashMap.insert t f d) (succ f) 0 cs)++-- | /O(n log n)/ Contruct an LZ78-compressed 'Generator' using a 'Map' internally.+encodeOrd :: Ord a => [a] -> LZ78 a+encodeOrd = go Map.empty 1 0 where+  go _ _ _ [] = Nil+  go _ _ p [c] = Cons (Token p c) Nil+  go d f p (c:cs) = let t = Token p c in case Map.lookup t d of+    Just p' -> go d f p' cs+    Nothing -> Cons t (go (Map.insert t f d) (succ f) 0 cs)++-- | /O(n^2)/ Contruct an LZ78-compressed 'Generator' using a list internally, requires an instance of Eq,+-- less efficient than encode.+encodeEq :: Eq a => [a] -> LZ78 a+encodeEq = go [] 1 0 where+  go _ _ _ [] = Nil+  go _ _ p [c] = Cons (Token p c) Nil+  go d f p (c:cs) = let t = Token p c in case List.lookup t d of+    Just p' -> go d f p' cs+    Nothing -> Cons t (go ((t, f):d) (succ f) 0 cs)++-- | A type-constrained 'reduce' operation+decode :: LZ78 a -> [a]+decode = reduce++-- | /O(n)/. Recompress with 'Hashable'+recode :: (Eq a, Hashable a) => LZ78 a -> LZ78 a+recode = encode . decode++-- | /O(n log n)/. Recompress with 'Ord'+recodeOrd :: Ord a => LZ78 a -> LZ78 a+recodeOrd = encodeOrd . decode++-- | /O(n^2)/. Recompress with 'Eq'+recodeEq :: Eq a => LZ78 a -> LZ78 a+recodeEq = encodeEq . decode++data Entry i a = Entry !i a deriving (Show,Read)++instance Functor (Entry i) where+  fmap f (Entry i a) = Entry i (f a)++instance Extend (Entry i) where+  extended = extend++instance Comonad (Entry i) where+  extend f e@(Entry i _) = Entry i (f e)+  duplicate e@(Entry i _) = Entry i e+  extract (Entry _ a) = a++instance Eq i => Eq (Entry i a) where+  Entry i _ == Entry j _ = i == j++instance Ord i => Ord (Entry i a) where+  compare (Entry i _) (Entry j _) = compare i j++instance Hashable i => Hashable (Entry i a) where+  hashWithSalt n (Entry i _) = hashWithSalt n i++-- | exposes internal structure+entries :: LZ78 a -> LZ78 (Entry Int a)+entries = go 0 where+  go k (Cons (Token i t) xs) = Cons (Token i (Entry k t)) $ (go $! k + 1) xs+  go _ Nil = Nil++instance Applicative LZ78 where+  pure a = Cons (Token 0 a) Nil+  fs <*> as = fmap extract $ encode $ do+    Entry i f <- decode (entries fs)+    Entry j a <- decode (entries as)+    return $ Entry (i,j) (f a)+  as *> bs = fmap extract $ encode $ Prelude.concat $ replicate (reduceWith getCount as)  $  decode (entries bs)+  as <* bs = fmap extract $ encode $ Prelude.concat $ replicate (reduceWith getCount bs) <$> decode (entries as)++instance Monad LZ78 where+  return a = Cons (Token 0 a) Nil+  (>>) = (*>)+  as >>= k = fmap extract $ encode $ do+    Entry i a <- decode (entries as)+    Entry j b <- decode (entries (k a))+    return $ Entry (i,j) b++instance Adjustable LZ78 where+  adjust f i = fmap extract . encode . adjust (Entry (-1) . f . extract) i . decode . entries++type instance Key LZ78 = Int++instance Lookup LZ78 where+  lookup i xs = Key.lookup i (decode xs)++instance Indexable LZ78 where+  index xs i = index (decode xs) i++instance FoldableWithKey LZ78 where+  foldMapWithKey f xs = foldMapWithKey f (decode xs)++instance Zip LZ78 where+  zipWith f as bs = extract <$> encode+    [ Entry (i,j) (f a b)+    | Entry i a <- decode (entries as)+    | Entry j b <- decode (entries bs)+    ]++
+ src/Data/Compressed/LZ78.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Compressed.LZ78+-- Copyright   :  (c) Edward Kmett 2009-2011+-- License     :  BSD-style+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (type families)+--+-- Compression algorithms are all about exploiting redundancy. When applying+-- an expensive 'Reducer' to a redundant source, it may be better to +-- extract the structural redundancy that is present. 'LZ78' is a compression+-- algorithm that does so, without requiring the dictionary to be populated+-- with all of the possible values of a data type unlike its later +-- refinement LZW, and which has fewer comparison reqirements during encoding+-- than its earlier counterpart LZ77. +-----------------------------------------------------------------------------++module Data.Compressed.LZ78 +    ( +    -- * Lempel-Ziv 78 +      LZ78+    -- * Encoding+    , encode    -- /O(n)/+    , encodeOrd -- /O(n log n)/+    , encodeEq  -- /O(n^2)/+    -- * Decoding (reduce)+    , decode+    -- * Recoding+    , recode    -- /O(n)/+    , recodeOrd -- /O(n log n)/+    , recodeEq  -- /O(n^2)/+    ) where++import Data.Compressed.Internal.LZ78
+ src/Data/Compressed/RunLengthEncoding.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Compressed.RunLengthEncoding+-- Copyright   :  (c) Edward Kmett 2009-2012+-- License     :  BSD-style+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Compression algorithms are all about exploiting redundancy. When applying+-- an expensive 'Reducer' to a redundant source, it may be better to +-- extract the structural redundancy that is present. Run length encoding+-- can do so for long runs of identical inputs.+-----------------------------------------------------------------------------+module Data.Compressed.RunLengthEncoding+    ( RLE(..)+    , Run+    , runLength+    , decode+    , encode+    , recode+    , toRuns+    , fromRuns+    ) where++import Data.Foldable+import Data.Semigroup+import Data.Semigroup.Reducer+import Data.Semigroup.Foldable+import Data.Hashable+import Data.Function (on)+import Data.Functor.Bind+import Data.Functor.Extend+import Control.Comonad+import Data.FingerTree (FingerTree,(|>),(<|),ViewL(..),ViewR(..),(><),viewl,viewr, Measured(..), split)+import qualified Data.FingerTree as F+import Data.Generator+import Data.Pointed+import Data.Key+import Control.Applicative++-- | A single run with a strict length+data Run a = Run {-# UNPACK #-} !Int a deriving (Eq,Show)++runLength :: Run a -> Int+runLength (Run n _) = n++-- lexicographical order+instance Ord a => Ord (Run a) where+  compare (Run n a) (Run m b) = case compare a b of+    LT -> LT+    GT -> GT+    EQ -> compare n m++instance Extend Run where+  extended = extend++instance Comonad Run where+  duplicate r@(Run i _) = Run i r+  extend f r@(Run i _) = Run i (f r)+  extract (Run _ a) = a++instance Functor Run where+  fmap f (Run n a) = Run n (f a)+  a <$ Run n _ = Run n a++instance Pointed Run where+  point = Run 1++instance Apply Run where+  Run n f <.> Run m a = Run (n * m) (f a)+  Run n _  .> Run m a = Run (n * m) a+  Run n a <.  Run m _ = Run (n * m) a++instance ComonadApply Run where+  Run n f <@> Run m a = Run (n * m) (f a)+  Run n _  @> Run m a = Run (n * m) a+  Run n a <@  Run m _ = Run (n * m) a++instance Applicative Run where+  pure = Run 1+  Run n f <*> Run m a = Run (n * m) (f a)+  Run n _  *> Run m a = Run (n * m) a+  Run n a <*  Run m _ = Run (n * m) a++instance Bind Run where+  Run n a >>- f = case f a of+    Run m b -> Run (n * m) b+ +instance Monad Run where+  return = Run 1+  Run n _ >> Run m b = Run (n * m) b+  Run n a >>= f = case f a of+    Run m b -> Run (n * m) b++instance Foldable Run where+  foldMap k (Run y0 x0) = f (k x0) y0 where+    f x y+      | even y = f (x `mappend` x) (y `quot` 2)+      | y == 1 = x+      | otherwise = g (x `mappend` x) ((y - 1) `quot` 2) x+    g x y z+      | even y = g (x `mappend` x) (y `quot` 2) z+      | y == 1 = x `mappend` z+      | otherwise = g (x `mappend` x) ((y - 1) `quot` 2) (x `mappend` z)+  {-# INLINE foldMap #-}++instance Foldable1 Run where+  foldMap1 k (Run y0 x0) = f (k x0) y0 where+    f x y+      | even y = f (x <> x) (y `quot` 2)+      | y == 1 = x+      | otherwise = g (x <> x) ((y - 1) `quot` 2) x+    g x y z+      | even y = g (x <> x) (y `quot` 2) z+      | y == 1 = x <> z+      | otherwise = g (x <> x) ((y - 1) `quot` 2) (x <> z)+  {-# INLINE foldMap1 #-}++instance Measured Count (Run a) where+  measure (Run n _) = Count n++-- | A 'Generator' which supports efficient 'mapReduce' operations over run-length encoded data.+newtype RLE a = RLE { getRLE :: FingerTree Count (Run a) } ++toRuns :: RLE a -> [Run a]+toRuns = toList . getRLE++fromRuns :: [Run a] -> RLE a+fromRuns = RLE . F.fromList ++instance Eq a => Semigroup (RLE a) where+  RLE l <> RLE r = go (viewr l) (viewl r) where+    go EmptyR  _ = RLE r+    go _  EmptyL = RLE l+    go (l' :> Run m a) (Run n b :< r')+      | a == b     = RLE ((l' |> Run (m+n) a) >< r')+      | otherwise  = RLE (l >< r)++instance Functor RLE where+  fmap f = RLE . F.fmap' (fmap f) . getRLE++instance Pointed RLE where+  point = RLE . F.singleton . pure++instance Apply RLE where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Applicative RLE where+  pure = RLE . F.singleton . pure+  RLE fs <*> RLE as = RLE $ F.fromList $ do+    Run n f <- toList fs+    Run m a <- toList as+    return $ Run (n * m) (f a)+  RLE as <* RLE bs = RLE $ F.fmap' (\(Run n a) -> Run (n * m) a) as where+    m = reduceWith getCount bs+  RLE as *> RLE bs = RLE $ mconcat $ replicate (reduceWith getCount as) bs++instance Bind RLE where+  (>>-) = (>>=)++instance Monad RLE where+  return = RLE . F.singleton . pure +  (>>) = (*>)+  RLE xs >>= f = RLE $ mconcat [ mconcat $ replicate n (getRLE (f a)) | Run n a <- toList xs ]+ +instance Eq a => Reducer a (RLE a) where+  unit = pure+  cons a (RLE r) = case viewl r of+    EmptyL -> pure a+    Run n b :< r' +      | a == b    -> RLE (Run (n+1) a <| r')+      | otherwise -> RLE (Run 1     a <| r )+  snoc (RLE l) a = case viewr l of+    EmptyR -> pure a+    l' :> Run n b +      | a == b    -> RLE (l' |> Run (n+1) b)+      | otherwise -> RLE (l  |> Run 1 a   )++instance Eq a => Monoid (RLE a) where+  mempty = RLE mempty+  mappend = (<>)++instance Foldable RLE where+  foldMap f = foldMap (foldMap f) . getRLE++instance Generator (RLE a) where+  type Elem (RLE a) = a+  mapReduce f = foldMap (unit . f)++instance Hashable a => Hashable (RLE a) where+  hashWithSalt n = hashWithSalt n . toList++instance Eq a => Eq (RLE a) where+  (==) = (==) `on` toList  -- todo stride through aligning++instance Zip RLE where+  zipWith f (RLE xs0) (RLE ys0) = RLE $ case toList xs0 of+    [] -> mempty+    (Run n0 a0:as0) -> case toList ys0 of +      [] -> mempty+      (Run m0 b0:bs0) -> go n0 a0 as0 m0 b0 bs0 +    where+      go !n !a !as !m !b !bs = case compare n m of +        LT -> Run n (f a b) <| case as of+          [] -> mempty+          (Run n' a':as') -> go n' a' as' (m - n) b bs+        EQ -> Run n (f a b) <| case as of+          [] -> mempty+          (Run n' a':as') -> case bs of+             [] -> mempty+             (Run m' b':bs') -> go n' a' as' m' b' bs'+        GT -> Run m (f a b) <| case bs of+          [] -> mempty+          (Run m' b':bs') -> go (n - m) a as m' b' bs'+          +type instance Key RLE = Int++instance Lookup RLE where+  lookup i (RLE xs) +    | i < 0 = Nothing+    | otherwise = case viewl $ snd $ split (\n -> getCount n > i) xs of+      Run _ a :< _ -> Just a+      EmptyL       -> Nothing ++instance Adjustable RLE where+  adjust f i (RLE xs) = RLE $ case viewl r of+    EmptyL -> xs+    Run n a :< r' -> +      let +        k = i - getCount (measure l)+        infixr 4 <?+        Run 0 _ <? ys = ys+        Run m b <? ys = Run m b <| ys+     in l >< (Run k a <? Run 1 (f a) <? Run (n - k - 1) a <? r')+    where +      (l,r) = split (\n -> getCount n > i) xs+++encode :: (Generator c, Eq (Elem c)) => c -> RLE (Elem c)+encode = reduce+{-# RULES "encode/recode"     encode = recode #-}+{-# RULES "encode/encodeList" encode = encodeList #-}++decode :: RLE a -> [a]+decode = reduce++recode :: Eq a => RLE a -> RLE a+recode (RLE xs0) = case toList xs0 of +  [] -> RLE mempty+  (Run n0 a0:as0) -> RLE $ go n0 a0 as0+  where+    go n a [] = F.singleton (Run n a)+    go n a (Run m b:bs)+      | a == b = go (n + m) a bs+      | otherwise = Run n a <| go m b bs++encodeList :: Eq a => [a] -> RLE a+encodeList []       = RLE mempty+encodeList (a0:as0) = RLE $ go 1 a0 as0+  where+    go n a [] = F.singleton (Run n a)+    go n a (b:bs) +      | a == b    = go (n + 1) a bs+      | otherwise = Run n a <| go 1 b bs