text-compression 0.1.0.7 → 0.1.0.8
raw patch · 6 files changed
+424/−358 lines, 6 filesdep +vectordep +vector-algorithms
Dependencies added: vector, vector-algorithms
Files
- CHANGELOG.md +4/−0
- src/Data/BWT.hs +15/−14
- src/Data/BWT/Internal.hs +118/−80
- src/Data/RLE.hs +104/−99
- src/Data/RLE/Internal.hs +174/−158
- text-compression.cabal +9/−7
CHANGELOG.md view
@@ -31,3 +31,7 @@ ## 0.1.0.7 -- 2022-11-07 * Added Run-length encoding (RLE) implementation.++## 0.1.0.8 -- 2022-11-11++* Optimized BWT and RLE implementations by switching out sequences with vectors.
src/Data/BWT.hs view
@@ -30,28 +30,29 @@ import Control.Monad.State.Strict() import Data.ByteString as BS (ByteString,concat,pack,unpack) import Data.Foldable as DFold (toList)-import Data.Sequence as DS import Data.STRef() import Data.Text (Text) import Data.Text.Encoding as DTE (decodeUtf8,encodeUtf8)+import Data.Vector as DVB (empty,iterateN,length,zip)+import Data.Vector.Unboxed as DVU (Unbox,fromList) import Data.Word (Word8)-import GHC.Generics(Generic)+import GHC.Generics (Generic) {-toBWT Function(s)-} -- | Takes a String and returns the Burrows-Wheeler Transform (BWT). -- Implemented via a 'SuffixArray'.-toBWT :: Ord a =>- [a] ->- BWT a-toBWT [] = DS.Empty+toBWT :: (Unbox a,Ord a)+ => [a]+ -> BWT a+toBWT [] = BWT DVB.empty toBWT xs = do let saxs = createSuffixArray xss saToBWT saxs xss where- xss = DS.fromList xs+ xss = DVU.fromList xs -- | Helper function for converting a 'ByteString' -- to a 'BWT' 'Word8'.@@ -80,17 +81,17 @@ -- This function utilizes the state monad (strict) in order -- to implement the [Magic](https://www.youtube.com/watch?v=QwSsppKrCj4) Inverse BWT algorithm by backtracking -- indices starting with the (__Nothing__,_) entry.-fromBWT :: Ord a =>- BWT a ->- [a]+fromBWT :: Ord a+ => BWT a+ -> [a] fromBWT bwt = do let originall = CMST.runST $ magicInverseBWT magicsz DFold.toList originall where- magicsz = DS.sortBy (\(a,b) (c,d) -> sortTB (a,b) (c,d))- zipped- zipped = DS.zip bwt- (DS.iterateN (DS.length bwt) (+1) 0)+ magicsz = sortVecBWT zipped+ zipped = DVB.zip bwtt+ (DVB.iterateN (DVB.length bwtt) (+1) 0)+ bwtt = (\(BWT t) -> t) bwt -- | Helper function for converting a 'BWT' of 'Word8's -- to a 'ByteString'.
src/Data/BWT/Internal.hs view
@@ -33,25 +33,28 @@ -- Various data structures and custom data types to describe the Burrows-Wheeler Transform (BWT) -- and the Inverse BWT. ----- The implementation of the BWT relies upon sequence provided--- by the [containers](https://hackage.haskell.org/package/containers).+-- The implementation of the BWT relies upon Boxed vectors, 'DVB.Vector', and Unboxed vectors, 'DVU.Vector',+-- provided by the [vector](https://hackage.haskell.org/package/vector). -- -- The internal 'BWTMatrix' data type relies upon the [massiv](https://hackage.haskell.org/package/massiv) package. module Data.BWT.Internal where -import Control.Monad as CM-import Control.Monad.ST as CMST+import Control.Monad as CM (when)+import Control.Monad.ST as CMST (ST,runST) import Control.Monad.State.Strict() import Data.Foldable as DFold-import Data.List as DL+import Data.List as DL (length,map) import Data.Maybe as DMaybe (fromJust,isNothing)-import Data.Sequence as DS+import Data.Sequence as DS (fromList,(><),null,singleton,zip,sortBy,tails,inits) import Data.Massiv.Array as DMA import Data.Massiv.Core()-import Data.STRef as DSTR-import GHC.Generics+import Data.STRef as DSTR (STRef,newSTRef,readSTRef,writeSTRef)+import Data.Vector as DVB (Vector,empty,findIndex,fromList,iterateN,map,snoc,thaw,unsafeFreeze,zip,uncons,(!))+import Data.Vector.Algorithms.Tim as DVAT (sortBy)+import Data.Vector.Unboxed as DVU (Vector,empty,null,tail,uncons,(!))+import GHC.Generics (Generic) import Prelude as P @@ -61,17 +64,18 @@ -- the core data inside of the 'SuffixArray' data type. data Suffix a = Suffix { suffixindex :: Int , suffixstartpos :: Int- , suffix :: Maybe (Seq a)+ , suffix :: Maybe (DVU.Vector a) } deriving (Show,Read,Eq,Ord,Generic) -- | The SuffixArray data type.--- Uses sequence internally.-type SuffixArray a = Seq (Suffix a)+-- Uses 'DVB.Vector' internally.+type SuffixArray a = DVB.Vector (Suffix a) -- | The BWT data type.--- Uses sequence internally.-type BWT a = Seq (Maybe a)+-- Uses 'DVU.Vector' internally.+newtype BWT a = BWT (DVB.Vector (Maybe a))+ deriving (Eq,Ord,Show,Read,Generic) -- | The BWTMatrix data type. -- Uses a massiv array internally.@@ -83,46 +87,80 @@ {-toBWT functions.-} -- | Computes the Burrows-Wheeler Transform (BWT) using the suffix array--- and the original string (represented as a sequence for performance).-saToBWT :: SuffixArray a ->- Seq a ->- BWT a-saToBWT DS.Empty _ = DS.Empty-saToBWT (y DS.:<| ys) t =- if | suffixstartpos y /= 1- -> (Just $ DS.index t (suffixstartpos y - 1 - 1))- DS.<| (saToBWT ys t) - | otherwise- -> Nothing- DS.<| (saToBWT ys t)+-- and the original string (represented as a 'DVB.Vector' for performance).+saToBWT :: Unbox a+ => SuffixArray a+ -> DVU.Vector a+ -> BWT a+saToBWT (DVB.uncons -> Nothing) _ = BWT DVB.empty+saToBWT vs t =+ BWT+ (DVB.map (\v -> if | suffixstartpos v /= 1+ -> Just $+ (DVU.!) t (suffixstartpos v - 1 - 1)+ | otherwise+ -> Nothing+ )+ vs) +-- | 'DVU.Vector' based implementation of the+-- well-known tails function in the List library.+tailsV :: Unbox a+ => DVU.Vector a+ -> [DVU.Vector a]+tailsV (DVU.uncons -> Nothing) = [DVU.empty]+tailsV vs =+ vs : (tailsV (DVU.tail vs))++-- | Custom sort function for 'DVB.Vector's+-- used in the 'createSuffixArray' function.+sortVecSA :: Ord a+ => DVB.Vector (Int,a)+ -> DVB.Vector (Int,a)+sortVecSA vs =+ CMST.runST+ (do mv <- DVB.thaw vs+ DVAT.sortBy (\(_,b) (_,d) -> compare b d) mv+ DVB.unsafeFreeze mv)++-- | Custom sort function for 'DVB.Vector's+-- used in the fromBWT function.+sortVecBWT :: Ord a+ => DVB.Vector (a,Int)+ -> DVB.Vector (a,Int)+sortVecBWT vs =+ CMST.runST+ (do mv <- DVB.thaw vs+ DVAT.sortBy (\(a,b) (c,d) -> sortTB (a,b) (c,d)) mv+ DVB.unsafeFreeze mv) + -- | Computes the corresponding 'SuffixArray' of a given string. Please see [suffix array](https://en.wikipedia.org/wiki/Suffix_array)--- for more information. -createSuffixArray :: Ord a =>- Seq a ->- SuffixArray a-createSuffixArray xs =- fmap (\(a,b,c) -> if | not $ DS.null c- -> Suffix { suffixindex = a- , suffixstartpos = b- , suffix = Just c- }- | otherwise- -> Suffix { suffixindex = a- , suffixstartpos = b- , suffix = Nothing- }- )- xsssuffixesfff+-- for more information.+createSuffixArray :: (Unbox a,Ord a)+ => DVU.Vector a + -> SuffixArray a+createSuffixArray vs =+ DVB.map (\(a,b,c) -> if | not $ DVU.null c+ -> Suffix { suffixindex = a+ , suffixstartpos = b+ , suffix = Just c+ }+ | otherwise+ -> Suffix { suffixindex = a+ , suffixstartpos = b+ , suffix = Nothing+ }+ )+ vssuffixesfff where- xsssuffixes = DS.tails xs- xsssuffixesf = DS.zip (DS.fromList [1..(DS.length xsssuffixes)])- xsssuffixes- xsssuffixesffsorted = DS.sortOn snd xsssuffixesf- xsssuffixesfff = (\(a,(b,c)) -> (a,b,c))- <$>- DS.zip (DS.fromList [1..(DS.length xsssuffixesffsorted)])- xsssuffixesffsorted+ vssuffixes = tailsV vs+ vssuffixesf = DVB.zip (DVB.iterateN (DL.length vssuffixes) (+1) 1 :: DVB.Vector Int)+ (DVB.fromList vssuffixes)+ vssuffixesffsorted = sortVecSA vssuffixesf+ vssuffixesfff = (\(a,(b,c)) -> (a,b,c))+ <$>+ DVB.zip (DVB.iterateN (DL.length vssuffixesffsorted) (+1) 1 :: DVB.Vector Int)+ vssuffixesffsorted {------------------} @@ -140,20 +178,20 @@ compare i1 i2 -- | Abstract BWTSeq type utilizing a sequence.-type BWTSeq a = Seq a+type BWTVec a = DVB.Vector a --- | Abstract data type representing a BWTSeq in the (strict) ST monad.-type STBWTSeq s a = STRef s (BWTSeq a)+-- | Abstract data type representing a 'BWTVec' in the (strict) ST monad.+type STBWTVec s a = STRef s (BWTVec a) --- | State function to push BWTString data into stack.-pushSTBWTSeq :: STBWTSeq s a -> a -> ST s ()-pushSTBWTSeq s e = do+-- | State function to push 'BWTVec' data into stack.+pushSTBWTVec :: STBWTVec s a -> a -> ST s ()+pushSTBWTVec s e = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> e)+ writeSTRef s (DVB.snoc s2 e) --- | State function to create empty STBWTString type.-emptySTBWTSeq :: ST s (STBWTSeq s a)-emptySTBWTSeq = newSTRef DS.empty+-- | State function to create empty 'STBWTVec' type.+emptySTBWTVec :: ST s (STBWTVec s a)+emptySTBWTVec = newSTRef DVB.empty -- | Abstract BWTCounter and associated state type. type STBWTCounter s a = STRef s Int@@ -167,43 +205,43 @@ emptySTBWTCounter = newSTRef (-1) -- | "Magic" Inverse BWT function.-magicInverseBWT :: Seq (Maybe a,Int) ->- ST s (BWTSeq a)-magicInverseBWT DS.Empty = do- bwtseqstackempty <- emptySTBWTSeq- bwtseqstackemptyr <- readSTRef bwtseqstackempty- return bwtseqstackemptyr-magicInverseBWT xs = do- bwtseqstack <- emptySTBWTSeq+magicInverseBWT :: DVB.Vector (Maybe a,Int) ->+ ST s (BWTVec a)+magicInverseBWT (DVB.uncons -> Nothing) = do+ bwtvecstackempty <- emptySTBWTVec+ bwtvecstackemptyr <- readSTRef bwtvecstackempty+ return bwtvecstackemptyr+magicInverseBWT xs = do+ bwtvecstack <- emptySTBWTVec bwtcounterstackf <- emptySTBWTCounter bwtcounterstacke <- emptySTBWTCounter- case (DS.findIndexL (\x -> isNothing $ fst x) xs) of- Nothing -> do bwtseqstackr <- readSTRef bwtseqstack- return bwtseqstackr- Just nothingindex -> do let nothingfirst = DS.index xs+ case (DVB.findIndex (\x -> isNothing $ fst x) xs) of+ Nothing -> do bwtvecstackr <- readSTRef bwtvecstack+ return bwtvecstackr+ Just nothingindex -> do let nothingfirst = (DVB.!) xs nothingindex updateSTBWTCounter bwtcounterstacke nothingindex updateSTBWTCounter bwtcounterstackf (snd nothingfirst) iBWT xs- bwtseqstack+ bwtvecstack bwtcounterstackf bwtcounterstacke- bwtseqstackr <- readSTRef bwtseqstack- return bwtseqstackr+ bwtvecstackr <- readSTRef bwtvecstack+ return bwtvecstackr where- iBWT ys bwtss bwtcsf bwtcse = do+ iBWT ys bwtvs bwtcsf bwtcse = do cbwtcsf <- readSTRef bwtcsf cbwtcse <- readSTRef bwtcse CM.when (cbwtcsf /= cbwtcse) $ do - let next = DS.index ys cbwtcsf- pushSTBWTSeq bwtss+ let next = (DVB.!) ys cbwtcsf+ pushSTBWTVec bwtvs (DMaybe.fromJust $ fst next) updateSTBWTCounter bwtcsf (snd next) iBWT ys- bwtss+ bwtvs bwtcsf bwtcse @@ -212,7 +250,7 @@ createBWTMatrix :: String -> BWTMatrix createBWTMatrix t =- DMA.fromList (ParN 0) zippedffff :: Array BN Ix1 String+ DMA.fromList (ParN 0) zippedffff :: DMA.Array BN Ix1 String where zippedffff = DL.map DFold.toList $ DL.map (\(a,b) -> if | isNothing a
src/Data/RLE.hs view
@@ -28,10 +28,11 @@ import Data.Char() import Data.Foldable() import Data.Maybe as DMaybe (isNothing,fromJust)-import Data.Sequence as DS import Data.STRef() import Data.Text as DText import Data.Text.Encoding as DTE (decodeUtf8,encodeUtf8)+import Data.Vector as DVB (Vector,empty,map,uncons)+import Data.Vector.Unboxed() import Data.Word (Word8) import Prelude as P @@ -67,7 +68,7 @@ textBWTToRLEB :: TextBWT -> RLEB textBWTToRLEB xs =- RLEB (CMST.runST $ seqToRLEB xss)+ RLEB (CMST.runST $ vecToRLEB xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -76,15 +77,16 @@ BS.singleton $ fromJust x )- ((\(TextBWT t) -> t) xs)+ ((\(BWT t) -> t) $+ ((\(TextBWT t) -> t) xs)) -- | Take a 'BWT' of 'Word8's and generate the -- Run-length encoding ('RLEB'). bytestringBWTToRLEB :: BWT Word8 -> RLEB-bytestringBWTToRLEB DS.Empty = RLEB DS.Empty-bytestringBWTToRLEB xs =- RLEB (CMST.runST $ seqToRLEB xss)+bytestringBWTToRLEB (BWT (DVB.uncons -> Nothing)) = RLEB DVB.empty+bytestringBWTToRLEB xs =+ RLEB (CMST.runST $ vecToRLEB xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -93,14 +95,14 @@ BS.singleton $ fromJust x )- xs+ ((\(BWT t) -> t) xs) -- | Take a 'BWT' of 'Word8's and generate the -- Run-length encoding ('RLEB'). textBWTToRLET :: TextBWT -> RLET textBWTToRLET xs =- RLET (CMST.runST $ seqToRLET xss)+ RLET (CMST.runST $ vecToRLET xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -110,15 +112,16 @@ BS.singleton $ fromJust x )- ((\(TextBWT t) -> t) xs)+ ((\(BWT t) -> t) $+ ((\(TextBWT t) -> t) xs)) -- | Take a 'BWT' of 'Word8's and generate the -- Run-length encoding ('RLET'). bytestringBWTToRLET :: BWT Word8 -> RLET-bytestringBWTToRLET DS.Empty = RLET DS.Empty-bytestringBWTToRLET xs =- RLET (CMST.runST $ seqToRLET xss)+bytestringBWTToRLET (BWT (DVB.uncons -> Nothing)) = RLET DVB.empty+bytestringBWTToRLET xs =+ RLET (CMST.runST $ vecToRLET xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -128,14 +131,14 @@ BS.singleton $ fromJust x )- xs+ ((\(BWT t) -> t) xs) -- | Takes a 'Text' and returns the Run-length encoding ('RLEB').-textToRLEB :: Seq (Maybe Text)+textToRLEB :: DVB.Vector (Maybe Text) -> RLEB-textToRLEB DS.Empty = RLEB DS.Empty-textToRLEB xs = - RLEB (CMST.runST $ seqToRLEB xss)+textToRLEB (DVB.uncons -> Nothing) = RLEB DVB.empty+textToRLEB xs = + RLEB (CMST.runST $ vecToRLEB xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -146,26 +149,26 @@ ) xs --- | Takes a 'Seq' of 'ByteString's and returns the Run-length encoding ('RLEB').-bytestringToRLEB :: Seq (Maybe ByteString)+-- | Takes a 'DVB.Vector' of 'ByteString's and returns the Run-length encoding ('RLEB').+bytestringToRLEB :: DVB.Vector (Maybe ByteString) -> RLEB-bytestringToRLEB DS.Empty = RLEB DS.Empty-bytestringToRLEB xs =- RLEB (CMST.runST $ seqToRLEB xs)+bytestringToRLEB (DVB.uncons -> Nothing) = RLEB DVB.empty+bytestringToRLEB xs =+ RLEB (CMST.runST $ vecToRLEB xs) -- | Takes a 'Text' and returns the Run-length encoding (RLE).-textToRLET :: Seq (Maybe Text)+textToRLET :: DVB.Vector (Maybe Text) -> RLET-textToRLET DS.Empty = RLET DS.Empty-textToRLET xs =- RLET (CMST.runST $ seqToRLET xs)+textToRLET (DVB.uncons -> Nothing) = RLET DVB.empty+textToRLET xs =+ RLET (CMST.runST $ vecToRLET xs) -- | Takes a 'ByteString' and returns the Run-length encoding (RLE).-bytestringToRLET :: Seq (Maybe ByteString)+bytestringToRLET :: DVB.Vector (Maybe ByteString) -> RLET-bytestringToRLET DS.Empty = RLET DS.Empty-bytestringToRLET xs =- RLET (CMST.runST $ seqToRLET xss)+bytestringToRLET (DVB.uncons -> Nothing) = RLET DVB.empty+bytestringToRLET xs =+ RLET (CMST.runST $ vecToRLET xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -191,15 +194,17 @@ -- back to the original 'ByteString'. bytestringFromBWTFromRLET :: RLET -> ByteString-bytestringFromBWTFromRLET = bytestringFromByteStringBWT . fmap (\x -> if | isNothing x- -> Nothing- | otherwise- -> Just $- DTE.encodeUtf8 $- fromJust x- )- .- textBWTFromRLET+bytestringFromBWTFromRLET vs = bytestringFromByteStringBWT $+ BWT $+ DVB.map (\x -> if | isNothing x+ -> Nothing+ | otherwise+ -> Just $+ DTE.encodeUtf8 $+ fromJust x+ )+ $ + ((\(BWT t) -> t) (textBWTFromRLET vs)) -- | Helper function for converting a 'BWT'ed 'RLEB' -- back to the original 'Text'.@@ -217,92 +222,92 @@ -- the 'BWT' of 'Text's. textBWTFromRLET :: RLET -> BWT Text-textBWTFromRLET (RLET DS.Empty) = DS.Empty-textBWTFromRLET xs = - CMST.runST $ seqFromRLET xs+textBWTFromRLET (RLET (DVB.uncons -> Nothing)) = BWT DVB.empty+textBWTFromRLET vs = + BWT (CMST.runST $ vecFromRLET vs) -- | Takes a 'RLET' and returns -- the 'BWT' of 'ByteString's. bytestringBWTFromRLET :: RLET -> BWT ByteString-bytestringBWTFromRLET (RLET DS.Empty) = DS.Empty-bytestringBWTFromRLET xs = do- let originalbwtb = CMST.runST $ seqFromRLET xs- fmap (\x -> if | isNothing x- -> Nothing- | otherwise- -> Just $- DTE.encodeUtf8 $- fromJust x - ) originalbwtb+bytestringBWTFromRLET (RLET (DVB.uncons -> Nothing)) = BWT DVB.empty+bytestringBWTFromRLET vs = do+ let originalbwtb = CMST.runST $ vecFromRLET vs+ BWT (DVB.map (\x -> if | isNothing x+ -> Nothing+ | otherwise+ -> Just $+ DTE.encodeUtf8 $+ fromJust x + ) originalbwtb) -- | Takes a 'RLEB' and returns -- the 'BWT' of 'Text's. textBWTFromRLEB :: RLEB -> BWT Text-textBWTFromRLEB (RLEB DS.Empty) = DS.Empty-textBWTFromRLEB xs = do- let originalbwtt = CMST.runST $ seqFromRLEB xs- fmap (\x -> if | isNothing x- -> Nothing- | otherwise- -> Just $- DTE.decodeUtf8 $- fromJust x- ) originalbwtt+textBWTFromRLEB (RLEB (DVB.uncons -> Nothing)) = BWT DVB.empty+textBWTFromRLEB vs = do+ let originalbwtt = CMST.runST $ vecFromRLEB vs+ BWT (DVB.map (\x -> if | isNothing x+ -> Nothing+ | otherwise+ -> Just $+ DTE.decodeUtf8 $+ fromJust x+ ) originalbwtt) -- | Take a 'RLEB' and returns -- the 'BWT' of 'ByteString's. bytestringBWTFromRLEB :: RLEB -> BWT ByteString-bytestringBWTFromRLEB (RLEB DS.Empty) = DS.Empty-bytestringBWTFromRLEB xs =- CMST.runST $ seqFromRLEB xs+bytestringBWTFromRLEB (RLEB (DVB.uncons -> Nothing)) = BWT DVB.empty+bytestringBWTFromRLEB vs =+ BWT (CMST.runST $ vecFromRLEB vs) -- | Takes a 'RLEB' and returns--- the original 'Seq' of 'Text's.+-- the original 'DVB.Vector' of 'Text's. textFromRLEB :: RLEB- -> Seq (Maybe Text)-textFromRLEB (RLEB DS.Empty) = DS.Empty-textFromRLEB xs = do- let originalt = CMST.runST $ seqFromRLEB xs- fmap (\x -> if | isNothing x- -> Nothing- | otherwise- -> Just $- DTE.decodeUtf8 $- fromJust x- ) originalt+ -> DVB.Vector (Maybe Text)+textFromRLEB (RLEB (DVB.uncons -> Nothing)) = DVB.empty+textFromRLEB vs = do+ let originalt = CMST.runST $ vecFromRLEB vs+ DVB.map (\x -> if | isNothing x+ -> Nothing+ | otherwise+ -> Just $+ DTE.decodeUtf8 $+ fromJust x+ ) originalt -- | Takes a 'RLEB' and returns--- the original 'Seq' of 'ByteString's.+-- the original 'DVB.Vector' of 'ByteString's. bytestringFromRLEB :: RLEB- -> Seq (Maybe ByteString)-bytestringFromRLEB (RLEB DS.Empty) = DS.Empty-bytestringFromRLEB xs = do- CMST.runST $ seqFromRLEB xs+ -> DVB.Vector (Maybe ByteString)+bytestringFromRLEB (RLEB (DVB.uncons -> Nothing)) = DVB.empty+bytestringFromRLEB vs =+ CMST.runST $ vecFromRLEB vs -- | Takes a 'RLET' and returns--- the original 'Seq' of 'Text's.+-- the original 'DVB.Vector' of 'Text's. textFromRLET :: RLET- -> Seq (Maybe Text)-textFromRLET (RLET DS.Empty) = DS.Empty-textFromRLET xs = do- CMST.runST $ seqFromRLET xs+ -> DVB.Vector (Maybe Text)+textFromRLET (RLET (DVB.uncons -> Nothing)) = DVB.empty+textFromRLET vs =+ CMST.runST $ vecFromRLET vs -- | Takes a 'RLET' and returns--- the original 'Seq' of 'ByteString's.+-- the original 'DVB.Vector' of 'ByteString's. bytestringFromRLET :: RLET- -> Seq (Maybe ByteString)-bytestringFromRLET (RLET DS.Empty) = DS.Empty-bytestringFromRLET xs = do- let originalb = CMST.runST $ seqFromRLET xs- fmap (\x -> if | isNothing x- -> Nothing- | otherwise- -> Just $ - DTE.encodeUtf8 $- fromJust x- ) originalb+ -> DVB.Vector (Maybe ByteString)+bytestringFromRLET (RLET (DVB.uncons -> Nothing)) = DVB.empty+bytestringFromRLET vs = do+ let originalb = CMST.runST $ vecFromRLET vs+ DVB.map (\x -> if | isNothing x+ -> Nothing+ | otherwise+ -> Just $+ DTE.encodeUtf8 $+ fromJust x+ ) originalb {---------------------}
src/Data/RLE/Internal.hs view
@@ -31,9 +31,9 @@ -- = Description -- -- Various data structures and custom data types to describe the Run-length encoding (RLE)--- and the Inverse RLE implementations, namely 'seqToRLEB', 'seqToRLET', 'seqFromRLEB', and 'seqFromRLET'.+-- and the Inverse RLE implementations, namely 'vecToRLEB', 'vecToRLET', 'vecFromRLEB', and 'vecFromRLET'. ----- The RLE implementations rely heavily upon 'Seq' provided by the [containers](https://hackage.haskell.org/package/containers),+-- The RLE implementations rely heavily upon 'DVB.Vector' provided by the [vector](https://hackage.haskell.org/package/vector) library, -- 'STRef' and associated functions in the [stref](https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-STRef.html) library, -- and 'runST' in the [Control.Monad.ST](https://hackage.haskell.org/package/base-4.17.0.0/docs/Control-Monad-ST.html) library. @@ -48,10 +48,10 @@ import Data.ByteString.Internal() import Data.List() import Data.Maybe as DMaybe (fromJust,isJust,isNothing)-import Data.Sequence as DS-import Data.Sequence.Internal as DSI import Data.STRef as DSTR import Data.Text as DText+import Data.Vector as DVB+import Data.Vector.Unboxed() import GHC.Generics (Generic) import Prelude as P @@ -59,11 +59,11 @@ {-Base level types.-} -- | Basic RLE ('ByteString') data type.-newtype RLEB = RLEB (Seq (Maybe ByteString))+newtype RLEB = RLEB (DVB.Vector (Maybe ByteString)) deriving (Eq,Ord,Show,Read,Generic) -- | Basic RLE ('Text') data type.-newtype RLET = RLET (Seq (Maybe Text))+newtype RLET = RLET (DVB.Vector (Maybe Text)) deriving (Eq,Ord,Show,Read,Generic) {-------------------}@@ -71,24 +71,24 @@ {-toRLE (ByteString) functions.-} --- | Abstract 'RLESeqB' type utilizing a sequence.-type RLESeqB = Seq (Maybe ByteString)+-- | Abstract 'RLEVecB' type utilizing a sequence.+type RLEVecB = DVB.Vector (Maybe ByteString) --- | Abstract data type representing a 'RLESeqB' in the (strict) ST monad.-type STRLESeqB s a = STRef s RLESeqB+-- | Abstract data type representing a 'RLEVecB' in the (strict) ST monad.+type STRLEVecB s a = STRef s RLEVecB --- | State function to push 'RLESeqB' data into stack.-pushSTRLESeqB :: STRLESeqB s (Maybe ByteString) -> Maybe ByteString -> ST s ()-pushSTRLESeqB s Nothing = do+-- | State function to push 'RLEVecB' data into stack.+pushSTRLEVecB :: STRLEVecB s (Maybe ByteString) -> Maybe ByteString -> ST s ()+pushSTRLEVecB s Nothing = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Nothing)-pushSTRLESeqB s (Just e) = do+ writeSTRef s (DVB.snoc s2 Nothing)+pushSTRLEVecB s (Just e) = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Just e)+ writeSTRef s (DVB.snoc s2 (Just e)) --- | State function to create empty 'STRLESeqB' type.-emptySTRLESeqB :: ST s (STRLESeqB s a)-emptySTRLESeqB = newSTRef DS.empty+-- | State function to create empty 'STRLEVecB' type.+emptySTRLEVecB :: ST s (STRLEVecB s a)+emptySTRLEVecB = newSTRef DVB.empty -- | Abstract 'STRLETempB' and associated state type. type STRLETempB s a = STRef s (Maybe ByteString)@@ -114,52 +114,52 @@ emptySTRLECounterB = newSTRef (-1) -- | Strict state monad function.-seqToRLEB :: RLESeqB- -> ST s RLESeqB-seqToRLEB DS.Empty = do- brleseqstackempty <- emptySTRLESeqB- brleseqstackemptyr <- readSTRef brleseqstackempty- return brleseqstackemptyr-seqToRLEB (x DS.:<| xs) = do- brleseqstack <- emptySTRLESeqB+vecToRLEB :: RLEVecB+ -> ST s RLEVecB+vecToRLEB (DVB.uncons -> Nothing) = do+ brlevecstackempty <- emptySTRLEVecB+ brlevecstackemptyr <- readSTRef brlevecstackempty+ return brlevecstackemptyr+vecToRLEB (DVB.uncons -> Just (v,vs)) = do+ brlevecstack <- emptySTRLEVecB brlecounterstack <- emptySTRLECounterB brletempstack <- emptySTRLETempB updateSTRLECounterB brlecounterstack 1 updateSTRLETempB brletempstack- x- iRLEB xs- brleseqstack+ v+ iRLEB vs+ brlevecstack brlecounterstack brletempstack- brleseqstackr <- readSTRef brleseqstack- return brleseqstackr+ brlevecstackr <- readSTRef brlevecstack+ return brlevecstackr where- iRLEB DS.Empty brless brlecs brlets = do+ iRLEB (DVB.uncons -> Nothing) brless brlecs brlets = do cbrlecs <- readSTRef brlecs cbrlets <- readSTRef brlets- pushSTRLESeqB brless+ pushSTRLEVecB brless (Just $ BSC8.pack $ show cbrlecs)- pushSTRLESeqB brless+ pushSTRLEVecB brless cbrlets pure ()- iRLEB (y DS.:<| ys) brless brlecs brlets = do+ iRLEB (DVB.uncons -> Just (y,ys)) brless brlecs brlets = do cbrlecs <- readSTRef brlecs cbrlets <- readSTRef brlets if | isNothing y- -> do pushSTRLESeqB brless+ -> do pushSTRLEVecB brless (Just $ BSC8.pack $ show cbrlecs)- pushSTRLESeqB brless+ pushSTRLEVecB brless cbrlets - pushSTRLESeqB brless+ pushSTRLEVecB brless (Just $ BSC8.pack $ show (1 :: Int))- pushSTRLESeqB brless+ pushSTRLEVecB brless Nothing updateSTRLETempB brlets Nothing @@ -184,11 +184,11 @@ brlecs brlets | otherwise- -> do pushSTRLESeqB brless+ -> do pushSTRLEVecB brless (Just $ BSC8.pack $ show cbrlecs)- pushSTRLESeqB brless+ pushSTRLEVecB brless cbrlets updateSTRLECounterB brlecs 1@@ -204,24 +204,24 @@ {-toRLE (Text) functions.-} --- | Abstract 'RLESeqT' type utilizing a sequence.-type RLESeqT = Seq (Maybe Text)+-- | Abstract 'RLEVecT' type utilizing a sequence.+type RLEVecT = DVB.Vector (Maybe Text) --- | Abstract data type representing a 'RLESeqT' in the (strict) ST monad.-type STRLESeqT s a = STRef s RLESeqT+-- | Abstract data type representing a 'RLEVecT' in the (strict) ST monad.+type STRLEVecT s a = STRef s RLEVecT --- | State function to push 'RLESeqT' data into stack.-pushSTRLESeqT :: STRLESeqT s (Maybe Text) -> (Maybe Text) -> ST s ()-pushSTRLESeqT s Nothing = do+-- | State function to push 'RLEVecT' data into stack.+pushSTRLEVecT :: STRLEVecT s (Maybe Text) -> (Maybe Text) -> ST s ()+pushSTRLEVecT s Nothing = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Nothing)-pushSTRLESeqT s (Just e) = do+ writeSTRef s (DVB.snoc s2 Nothing)+pushSTRLEVecT s (Just e) = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Just e)+ writeSTRef s (DVB.snoc s2 (Just e)) --- | State function to create empty 'STRLESeqT' type.-emptySTRLESeqT :: ST s (STRLESeqT s a)-emptySTRLESeqT = newSTRef DS.empty+-- | State function to create empty 'STRLEVecT' type.+emptySTRLEVecT :: ST s (STRLEVecT s a)+emptySTRLEVecT = newSTRef DVB.empty -- | Abstract 'STRLETempT' state type. type STRLETempT s a = STRef s (Maybe Text)@@ -247,52 +247,52 @@ emptySTRLECounterT = newSTRef (-1) -- | Strict state monad function.-seqToRLET :: RLESeqT ->- ST s RLESeqT-seqToRLET DS.Empty = do- trleseqstackempty <- emptySTRLESeqT- trleseqstackemptyr <- readSTRef trleseqstackempty- return trleseqstackemptyr-seqToRLET (x DS.:<| xs) = do- trleseqstack <- emptySTRLESeqT+vecToRLET :: RLEVecT ->+ ST s RLEVecT+vecToRLET (DVB.uncons -> Nothing) = do+ trlevecstackempty <- emptySTRLEVecT+ trlevecstackemptyr <- readSTRef trlevecstackempty+ return trlevecstackemptyr+vecToRLET (DVB.uncons -> Just (v,vs)) = do+ trlevecstack <- emptySTRLEVecT trlecounterstack <- emptySTRLECounterT trletempstack <- emptySTRLETempT updateSTRLECounterT trlecounterstack 1 updateSTRLETempT trletempstack- x- iRLET xs- trleseqstack+ v+ iRLET vs+ trlevecstack trlecounterstack trletempstack- trleseqstackr <- readSTRef trleseqstack- return trleseqstackr+ trlevecstackr <- readSTRef trlevecstack+ return trlevecstackr where- iRLET DS.Empty trless trlecs trlets = do+ iRLET (DVB.uncons -> Nothing) trless trlecs trlets = do ctrlecs <- readSTRef trlecs ctrlets <- readSTRef trlets- pushSTRLESeqT trless+ pushSTRLEVecT trless (Just $ DText.pack $ show ctrlecs)- pushSTRLESeqT trless+ pushSTRLEVecT trless ctrlets pure ()- iRLET (y DS.:<| ys) trless trlecs trlets = do+ iRLET (DVB.uncons -> Just (y,ys)) trless trlecs trlets = do ctrlecs <- readSTRef trlecs ctrlets <- readSTRef trlets if | isNothing y- -> do pushSTRLESeqT trless+ -> do pushSTRLEVecT trless (Just $ DText.pack $ show ctrlecs)- pushSTRLESeqT trless+ pushSTRLEVecT trless ctrlets- pushSTRLESeqT trless+ pushSTRLEVecT trless (Just $ DText.pack $ show (1 :: Int))- pushSTRLESeqT trless+ pushSTRLEVecT trless Nothing updateSTRLETempT trlets Nothing@@ -317,11 +317,11 @@ trlecs trlets | otherwise- -> do pushSTRLESeqT trless+ -> do pushSTRLEVecT trless (Just $ DText.pack $ show ctrlecs)- pushSTRLESeqT trless+ pushSTRLEVecT trless ctrlets updateSTRLECounterT trlecs 1@@ -337,59 +337,69 @@ {-fromRLE (ByteString) functions.-} --- | Abstract 'FRLESeqB' type utilizing a sequence.-type FRLESeqB = Seq (Maybe ByteString)+-- | 'DVB.Vector' auxilary function+-- to pattern match on first two elements+-- of a vector.+unconsb2 :: DVB.Vector a -> Maybe (a,DVB.Vector a,Maybe (DVB.Vector a))+unconsb2 v = if | DVB.length v < 3+ -> Just (DVB.unsafeHead v,DVB.drop 1 v,Nothing)+ | otherwise+ -> Just (DVB.unsafeHead v,DVB.drop 1 v,Just $ DVB.drop 2 v) --- | Abstract data type representing a 'FRLESeqB' in the (strict) ST monad.-type FSTRLESeqB s a = STRef s FRLESeqB+-- | Abstract 'FRLEVecB' type utilizing a sequence.+type FRLEVecB = DVB.Vector (Maybe ByteString) --- | State function to push 'FRLESeqB' data into stack.-pushFSTRLESeqB :: FSTRLESeqB s (Maybe ByteString) -> (Maybe ByteString) -> ST s ()-pushFSTRLESeqB s Nothing = do+-- | Abstract data type representing a 'FRLEVecB' in the (strict) ST monad.+type FSTRLEVecB s a = STRef s FRLEVecB++-- | State function to push 'FRLEVecB' data into stack.+pushFSTRLEVecB :: FSTRLEVecB s (Maybe ByteString) -> (Maybe ByteString) -> ST s ()+pushFSTRLEVecB s Nothing = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Nothing)-pushFSTRLESeqB s (Just e) = do+ writeSTRef s (DVB.snoc s2 Nothing)+pushFSTRLEVecB s (Just e) = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Just e)+ writeSTRef s (DVB.snoc s2 (Just e)) --- | State function to create empty 'FSTRLESeqB' type.-emptyFSTRLESeqB :: ST s (FSTRLESeqB s a)-emptyFSTRLESeqB = newSTRef DS.empty+-- | State function to create empty 'FSTRLEVecB' type.+emptyFSTRLEVecB :: ST s (FSTRLEVecB s a)+emptyFSTRLEVecB = newSTRef DVB.empty -- | Strict state monad function.-seqFromRLEB :: RLEB- -> ST s FRLESeqB-seqFromRLEB (RLEB DS.Empty) = do- fbrleseqstackempty <- emptyFSTRLESeqB- fbrleseqstackemptyr <- readSTRef fbrleseqstackempty- return fbrleseqstackemptyr-seqFromRLEB xs = do- fbrleseqstack <- emptySTRLESeqB- let rlebseq = (\(RLEB b) -> b) xs- iFRLEB rlebseq- fbrleseqstack- fbrleseqstackr <- readSTRef fbrleseqstack- return fbrleseqstackr+vecFromRLEB :: RLEB+ -> ST s FRLEVecB+vecFromRLEB (RLEB (DVB.uncons -> Nothing)) = do+ fbrlevecstackempty <- emptyFSTRLEVecB+ fbrlevecstackemptyr <- readSTRef fbrlevecstackempty+ return fbrlevecstackemptyr+vecFromRLEB vs = do+ fbrlevecstack <- emptySTRLEVecB+ let rlebvec = (\(RLEB b) -> b) vs+ iFRLEB rlebvec+ fbrlevecstack+ fbrlevecstackr <- readSTRef fbrlevecstack+ return fbrlevecstackr where- iFRLEB (y1 DS.:<| y2 DS.:<| DS.Empty) fbrless =+ iFRLEB (unconsb2 -> Just (y1,y2,Nothing)) fbrless = if | isJust y1 &&- isNothing y2- -> do pushFSTRLESeqB fbrless+ isNothing (DVB.head y2)+ -> do pushFSTRLEVecB fbrless Nothing pure () | otherwise -> do let y1' = read $ BSC8.unpack $ fromJust y1 :: Int- let y2' = fromJust y2+ let y2' = fromJust $+ DVB.head y2 CM.replicateM_ y1'- (pushFSTRLESeqB fbrless+ (pushFSTRLEVecB fbrless (Just y2')) pure () - iFRLEB (y1 DS.:<| y2 DS.:<| ys) fbrless =+ iFRLEB (unconsb2 -> Just (y1,y2,Just ys)) fbrless = if | isJust y1 &&- isNothing y2- -> do pushFSTRLESeqB fbrless+ isNothing (DVB.head y2)+ -> do pushFSTRLEVecB fbrless Nothing iFRLEB ys fbrless@@ -397,74 +407,82 @@ -> do let y1' = read $ BSC8.unpack $ fromJust y1 :: Int- let y2' = fromJust y2+ let y2' = fromJust $+ DVB.head y2 CM.replicateM_ y1'- (pushFSTRLESeqB fbrless+ (pushFSTRLEVecB fbrless (Just y2')) iFRLEB ys- fbrless - iFRLEB (DSI.Seq EmptyT) _ = pure ()- iFRLEB (DSI.Seq (Single _)) _ = pure ()- iFRLEB (DSI.Seq (Deep _ _ _ _)) _ = pure ()+ fbrless {---------------------------------} {-fromRLE (Text) functions.-} --- | Abstract 'FRLESeqT' type utilizing a sequence.-type FRLESeqT = Seq (Maybe Text)+-- | 'DVB.Vector' auxilary function+-- to pattern match on first two elements+-- of a vector.+unconst2 :: DVB.Vector a -> Maybe (a,DVB.Vector a, Maybe (DVB.Vector a))+unconst2 v = if | DVB.length v < 3+ -> Just (DVB.unsafeHead v,DVB.drop 1 v,Nothing)+ | otherwise+ -> Just (DVB.unsafeHead v, DVB.drop 1 v,Just $ DVB.drop 2 v) --- | Abstract data type representing a 'FRLESeqT' in the (strict) ST monad.-type FSTRLESeqT s a = STRef s FRLESeqT+-- | Abstract 'FRLEVecT' type utilizing a sequence.+type FRLEVecT = DVB.Vector (Maybe Text) --- | State function to push 'FSTRLESeqT' data into stack.-pushFSTRLESeqT :: FSTRLESeqT s (Maybe Text) -> (Maybe Text) -> ST s ()-pushFSTRLESeqT s Nothing = do+-- | Abstract data type representing a 'FRLEVecT' in the (strict) ST monad.+type FSTRLEVecT s a = STRef s FRLEVecT++-- | State function to push 'FSTRLEVecT' data into stack.+pushFSTRLEVecT :: FSTRLEVecT s (Maybe Text) -> (Maybe Text) -> ST s ()+pushFSTRLEVecT s Nothing = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Nothing)-pushFSTRLESeqT s (Just e) = do+ writeSTRef s (DVB.snoc s2 Nothing)+pushFSTRLEVecT s (Just e) = do s2 <- readSTRef s- writeSTRef s (s2 DS.|> Just e)+ writeSTRef s (DVB.snoc s2 (Just e)) --- | State function to create empty 'FSTRLESeqT' type.-emptyFSTRLESeqT :: ST s (FSTRLESeqT s a)-emptyFSTRLESeqT = newSTRef DS.empty+-- | State function to create empty 'FSTRLEVecT' type.+emptyFSTRLEVecT :: ST s (FSTRLEVecT s a)+emptyFSTRLEVecT = newSTRef DVB.empty -- | Strict state monad function.-seqFromRLET :: RLET ->- ST s FRLESeqT-seqFromRLET (RLET DS.Empty) = do- ftrleseqstackempty <- emptyFSTRLESeqT- ftrleseqstackemptyr <- readSTRef ftrleseqstackempty- return ftrleseqstackemptyr-seqFromRLET xs = do- ftrleseqstack <- emptySTRLESeqT- let rletseq = (\(RLET t) -> t) xs- iFRLET rletseq- ftrleseqstack- ftrleseqstackr <- readSTRef ftrleseqstack- return ftrleseqstackr- where- iFRLET (y1 DS.:<| y2 DS.:<| DS.Empty) ftrless =+vecFromRLET :: RLET ->+ ST s FRLEVecT+vecFromRLET (RLET (DVB.uncons -> Nothing)) = do+ ftrlevecstackempty <- emptyFSTRLEVecT+ ftrlevecstackemptyr <- readSTRef ftrlevecstackempty+ return ftrlevecstackemptyr+vecFromRLET vs = do+ ftrlevecstack <- emptySTRLEVecT+ let rletvec = (\(RLET t) -> t) vs+ iFRLET rletvec+ ftrlevecstack+ ftrlevecstackr <- readSTRef ftrlevecstack+ return ftrlevecstackr+ where + iFRLET (unconst2 -> Just (y1,y2,Nothing)) ftrless = if | isJust y1 &&- isNothing y2- -> do pushFSTRLESeqT ftrless+ isNothing (DVB.head y2)+ -> do pushFSTRLEVecT ftrless Nothing pure () | otherwise -> do let y1' = read $ DText.unpack $ fromJust y1 :: Int- let y2' = fromJust y2+ let y2' = fromJust $+ DVB.head y2 CM.replicateM_ y1'- (pushFSTRLESeqT ftrless+ (pushFSTRLEVecT ftrless (Just y2')) pure ()- iFRLET (y1 DS.:<| y2 DS.:<| ys) ftrless =+ iFRLET (unconst2 -> Just (y1,y2,Just ys)) ftrless = if | isJust y1 &&- isNothing y2- -> do pushFSTRLESeqT ftrless+ isNothing (DVB.head y2)+ -> do pushFSTRLEVecT ftrless Nothing iFRLET ys ftrless@@ -472,14 +490,12 @@ -> do let y1' = read $ DText.unpack $ fromJust y1 :: Int- let y2' = fromJust y2+ let y2' = fromJust $+ DVB.head y2 CM.replicateM_ y1'- (pushFSTRLESeqT ftrless+ (pushFSTRLEVecT ftrless (Just y2')) iFRLET ys ftrless- iFRLET (DSI.Seq EmptyT) _ = pure ()- iFRLET (DSI.Seq (Single _)) _ = pure ()- iFRLET (DSI.Seq (Deep _ _ _ _)) _ = pure () {---------------------------}
text-compression.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.7+version: 0.1.0.8 -- A short (one-line) description of the package. synopsis: A text compression library.@@ -76,12 +76,14 @@ -- other-extensions: -- Other library packages from which modules are imported.- build-depends: base ^>=4.16.3.0,- bytestring >= 0.11.3 && < 0.12,- containers >= 0.6.5 && < 0.7,- massiv >= 1.0.2 && < 1.1,- mtl >= 2.2.2 && < 2.3,- text >= 1.2.5 && < 1.3+ build-depends: base ^>=4.16.3.0, + bytestring >= 0.11.3 && < 0.12,+ containers >= 0.6.5 && < 0.7,+ massiv >= 1.0.2 && < 1.1,+ mtl >= 2.2.2 && < 2.3,+ text >= 1.2.5 && < 1.3,+ vector >= 0.13.0 && < 0.14,+ vector-algorithms >= 0.9.0 && < 0.10 -- Directories containing source files. hs-source-dirs: src