compressed (empty) → 0.1
raw patch · 6 files changed
+609/−0 lines, 6 filesdep +basedep +comonaddep +containerssetup-changed
Dependencies added: base, comonad, containers, fingertree, hashable, keys, pointed, reducers, semigroupoids, semigroups, unordered-containers
Files
- Data/Compressed/Internal/LZ78.hs +230/−0
- Data/Compressed/LZ78.hs +35/−0
- Data/Compressed/RunLengthEncoding.hs +267/−0
- LICENSE +30/−0
- Setup.lhs +7/−0
- compressed.cabal +40/−0
+ Data/Compressed/Internal/LZ78.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE TypeFamilies, BangPatterns, ParallelListComp #-} +-----------------------------------------------------------------------------+-- |+-- Module : Data.Generator.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.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.Generator+import Data.Foldable+import Data.Function (on)+import Data.Functor+import Data.Key as Key+import Data.Pointed+import Text.Read+import Control.Comonad+import Data.Hashable+import Data.Monoid (Monoid(..))+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+ extend f t@(Token i _) = Token i (f t)+ duplicate t@(Token i _) = Token i t++instance Comonad Token where+ extract (Token _ a) = a++instance Hashable a => Hashable (Token a) where+ hash (Token i a) = hashWithSalt i 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 ++-- | 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 = extract <$> encode + [ Entry (i,j) (f a) + | Entry i f <- decode (entries fs)+ , Entry j a <- decode (entries as) + ]+ 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 = extract <$> encode + [ Entry (i,j) b + | Entry i a <- decode (entries as)+ , Entry j b <- decode (entries (k a))+ ]++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 Entry i a = Entry !i a++instance Functor (Entry i) where+ fmap f (Entry i a) = Entry i (f a)++instance Extend (Entry i) where+ extend f e@(Entry i _) = Entry i (f e)+ duplicate e@(Entry i _) = Entry i e++instance Comonad (Entry i) where+ 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+ hash (Entry i _) = hash i+ hashWithSalt n (Entry i _) = hashWithSalt n i+
+ 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
+ Data/Compressed/RunLengthEncoding.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeOperators, FlexibleInstances, FlexibleContexts, BangPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Compressed.RunLengthEncoding+-- Copyright : (c) Edward Kmett 2009+-- 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.Monoid+import Data.Hashable+import Data.Function (on)+import Data.Functor.Bind+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+ duplicate r@(Run i _) = Run i r+ extend f r@(Run i _) = Run i (f r)++instance Comonad Run where+ 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 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 + [ Run (n * m) (f a)+ | Run n f <- toList fs+ , Run m a <- toList as+ ]+ 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+ hash = hash . toList+ 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 r of+ Run _ a :< _ -> Just a+ EmptyL -> Nothing + where (l,r) = split (\n -> getCount n > i) xs++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 _ <? xs = xs+ Run n a <? xs = Run n a <| xs+ 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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2009-2011 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ compressed.cabal view
@@ -0,0 +1,40 @@+name: compressed+category: Data, Compression, MapReduce+version: 0.1+license: BSD3+cabal-version: >= 1.6+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: experimental+homepage: http://github.com/ekmett/compressed/+copyright: Copyright (C) 2011 Edward A. Kmett+synopsis: Compressed generators and reducers+description: Compressed generators and reducers+build-type: Simple++source-repository head+ type: git+ location: git://github.com/ekmett/compressed.git++library++ build-depends: + base >= 4 && < 5,+ containers >= 0.3 && < 0.5,+ fingertree >= 0.0.1 && < 0.1,+ hashable >= 1.1.2.1 && < 1.2,+ unordered-containers >= 0.1.4 && < 0.2,+ semigroups >= 0.7.1 && < 0.8,+ semigroupoids >= 1.2.2.4 && < 1.3,+ comonad >= 1.1.1 && < 1.2,+ pointed >= 2.0 && < 2.1,+ keys >= 2.0 && < 2.1,+ reducers >= 0.1 && < 0.2++ exposed-modules:+ Data.Compressed.LZ78+ Data.Compressed.RunLengthEncoding+ Data.Compressed.Internal.LZ78++ ghc-options: -Wall