text-compression 0.1.0.8 → 0.1.0.9
raw patch · 6 files changed
+363/−414 lines, 6 filesdep −vectordep −vector-algorithmsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: vector, vector-algorithms
API changes (from Hackage documentation)
- Data.BWT.Internal: emptySTBWTVec :: ST s (STBWTVec s a)
- Data.BWT.Internal: instance (Data.Vector.Unboxed.Base.Unbox a, GHC.Classes.Eq a) => GHC.Classes.Eq (Data.BWT.Internal.Suffix a)
- Data.BWT.Internal: instance (Data.Vector.Unboxed.Base.Unbox a, GHC.Classes.Ord a) => GHC.Classes.Ord (Data.BWT.Internal.Suffix a)
- Data.BWT.Internal: instance (GHC.Read.Read a, Data.Vector.Unboxed.Base.Unbox a) => GHC.Read.Read (Data.BWT.Internal.Suffix a)
- Data.BWT.Internal: instance (GHC.Show.Show a, Data.Vector.Unboxed.Base.Unbox a) => GHC.Show.Show (Data.BWT.Internal.Suffix a)
- Data.BWT.Internal: pushSTBWTVec :: STBWTVec s a -> a -> ST s ()
- Data.BWT.Internal: sortVecBWT :: Ord a => Vector (a, Int) -> Vector (a, Int)
- Data.BWT.Internal: sortVecSA :: Ord a => Vector (Int, a) -> Vector (Int, a)
- Data.BWT.Internal: tailsV :: Unbox a => Vector a -> [Vector a]
- Data.BWT.Internal: type BWTVec a = Vector a
- Data.BWT.Internal: type STBWTVec s a = STRef s (BWTVec a)
- Data.RLE.Internal: emptyFSTRLEVecB :: ST s (FSTRLEVecB s a)
- Data.RLE.Internal: emptyFSTRLEVecT :: ST s (FSTRLEVecT s a)
- Data.RLE.Internal: emptySTRLEVecB :: ST s (STRLEVecB s a)
- Data.RLE.Internal: emptySTRLEVecT :: ST s (STRLEVecT s a)
- Data.RLE.Internal: pushFSTRLEVecB :: FSTRLEVecB s (Maybe ByteString) -> Maybe ByteString -> ST s ()
- Data.RLE.Internal: pushFSTRLEVecT :: FSTRLEVecT s (Maybe Text) -> Maybe Text -> ST s ()
- Data.RLE.Internal: pushSTRLEVecB :: STRLEVecB s (Maybe ByteString) -> Maybe ByteString -> ST s ()
- Data.RLE.Internal: pushSTRLEVecT :: STRLEVecT s (Maybe Text) -> Maybe Text -> ST s ()
- Data.RLE.Internal: type FRLEVecB = Vector (Maybe ByteString)
- Data.RLE.Internal: type FRLEVecT = Vector (Maybe Text)
- Data.RLE.Internal: type FSTRLEVecB s a = STRef s FRLEVecB
- Data.RLE.Internal: type FSTRLEVecT s a = STRef s FRLEVecT
- Data.RLE.Internal: type RLEVecB = Vector (Maybe ByteString)
- Data.RLE.Internal: type RLEVecT = Vector (Maybe Text)
- Data.RLE.Internal: type STRLEVecB s a = STRef s RLEVecB
- Data.RLE.Internal: type STRLEVecT s a = STRef s RLEVecT
- Data.RLE.Internal: unconsb2 :: Vector a -> Maybe (a, Vector a, Maybe (Vector a))
- Data.RLE.Internal: unconst2 :: Vector a -> Maybe (a, Vector a, Maybe (Vector a))
- Data.RLE.Internal: vecFromRLEB :: RLEB -> ST s FRLEVecB
- Data.RLE.Internal: vecFromRLET :: RLET -> ST s FRLEVecT
- Data.RLE.Internal: vecToRLEB :: RLEVecB -> ST s RLEVecB
- Data.RLE.Internal: vecToRLET :: RLEVecT -> ST s RLEVecT
+ Data.BWT.Internal: emptySTBWTSeq :: ST s (STBWTSeq s a)
+ Data.BWT.Internal: instance GHC.Classes.Eq a => GHC.Classes.Eq (Data.BWT.Internal.Suffix a)
+ Data.BWT.Internal: instance GHC.Classes.Ord a => GHC.Classes.Ord (Data.BWT.Internal.Suffix a)
+ Data.BWT.Internal: instance GHC.Read.Read a => GHC.Read.Read (Data.BWT.Internal.Suffix a)
+ Data.BWT.Internal: instance GHC.Show.Show a => GHC.Show.Show (Data.BWT.Internal.Suffix a)
+ Data.BWT.Internal: pushSTBWTSeq :: STBWTSeq s a -> a -> ST s ()
+ Data.BWT.Internal: type BWTSeq a = Seq a
+ Data.BWT.Internal: type STBWTSeq s a = STRef s (BWTSeq a)
+ Data.RLE.Internal: emptyFSTRLESeqB :: ST s (FSTRLESeqB s a)
+ Data.RLE.Internal: emptyFSTRLESeqT :: ST s (FSTRLESeqT s a)
+ Data.RLE.Internal: emptySTRLESeqB :: ST s (STRLESeqB s a)
+ Data.RLE.Internal: emptySTRLESeqT :: ST s (STRLESeqT s a)
+ Data.RLE.Internal: pushFSTRLESeqB :: FSTRLESeqB s (Maybe ByteString) -> Maybe ByteString -> ST s ()
+ Data.RLE.Internal: pushFSTRLESeqT :: FSTRLESeqT s (Maybe Text) -> Maybe Text -> ST s ()
+ Data.RLE.Internal: pushSTRLESeqB :: STRLESeqB s (Maybe ByteString) -> Maybe ByteString -> ST s ()
+ Data.RLE.Internal: pushSTRLESeqT :: STRLESeqT s (Maybe Text) -> Maybe Text -> ST s ()
+ Data.RLE.Internal: seqFromRLEB :: RLEB -> ST s FRLESeqB
+ Data.RLE.Internal: seqFromRLET :: RLET -> ST s FRLESeqT
+ Data.RLE.Internal: seqToRLEB :: RLESeqB -> ST s RLESeqB
+ Data.RLE.Internal: seqToRLET :: RLESeqT -> ST s RLESeqT
+ Data.RLE.Internal: type FRLESeqB = Seq (Maybe ByteString)
+ Data.RLE.Internal: type FRLESeqT = Seq (Maybe Text)
+ Data.RLE.Internal: type FSTRLESeqB s a = STRef s FRLESeqB
+ Data.RLE.Internal: type FSTRLESeqT s a = STRef s FRLESeqT
+ Data.RLE.Internal: type RLESeqB = Seq (Maybe ByteString)
+ Data.RLE.Internal: type RLESeqT = Seq (Maybe Text)
+ Data.RLE.Internal: type STRLESeqB s a = STRef s RLESeqB
+ Data.RLE.Internal: type STRLESeqT s a = STRef s RLESeqT
- Data.BWT: toBWT :: (Unbox a, Ord a) => [a] -> BWT a
+ Data.BWT: toBWT :: Ord a => [a] -> BWT a
- Data.BWT.Internal: BWT :: Vector (Maybe a) -> BWT a
+ Data.BWT.Internal: BWT :: Seq (Maybe a) -> BWT a
- Data.BWT.Internal: Suffix :: Int -> Int -> Maybe (Vector a) -> Suffix a
+ Data.BWT.Internal: Suffix :: Int -> Int -> Maybe (Seq a) -> Suffix a
- Data.BWT.Internal: [suffix] :: Suffix a -> Maybe (Vector a)
+ Data.BWT.Internal: [suffix] :: Suffix a -> Maybe (Seq a)
- Data.BWT.Internal: createSuffixArray :: (Unbox a, Ord a) => Vector a -> SuffixArray a
+ Data.BWT.Internal: createSuffixArray :: Ord a => Seq a -> SuffixArray a
- Data.BWT.Internal: magicInverseBWT :: Vector (Maybe a, Int) -> ST s (BWTVec a)
+ Data.BWT.Internal: magicInverseBWT :: Seq (Maybe a, Int) -> ST s (BWTSeq a)
- Data.BWT.Internal: saToBWT :: Unbox a => SuffixArray a -> Vector a -> BWT a
+ Data.BWT.Internal: saToBWT :: SuffixArray a -> Seq a -> Seq (Maybe a)
- Data.BWT.Internal: type SuffixArray a = Vector (Suffix a)
+ Data.BWT.Internal: type SuffixArray a = Seq (Suffix a)
- Data.RLE: bytestringFromRLEB :: RLEB -> Vector (Maybe ByteString)
+ Data.RLE: bytestringFromRLEB :: RLEB -> Seq (Maybe ByteString)
- Data.RLE: bytestringFromRLET :: RLET -> Vector (Maybe ByteString)
+ Data.RLE: bytestringFromRLET :: RLET -> Seq (Maybe ByteString)
- Data.RLE: bytestringToRLEB :: Vector (Maybe ByteString) -> RLEB
+ Data.RLE: bytestringToRLEB :: Seq (Maybe ByteString) -> RLEB
- Data.RLE: bytestringToRLET :: Vector (Maybe ByteString) -> RLET
+ Data.RLE: bytestringToRLET :: Seq (Maybe ByteString) -> RLET
- Data.RLE: textFromRLEB :: RLEB -> Vector (Maybe Text)
+ Data.RLE: textFromRLEB :: RLEB -> Seq (Maybe Text)
- Data.RLE: textFromRLET :: RLET -> Vector (Maybe Text)
+ Data.RLE: textFromRLET :: RLET -> Seq (Maybe Text)
- Data.RLE: textToRLEB :: Vector (Maybe Text) -> RLEB
+ Data.RLE: textToRLEB :: Seq (Maybe Text) -> RLEB
- Data.RLE: textToRLET :: Vector (Maybe Text) -> RLET
+ Data.RLE: textToRLET :: Seq (Maybe Text) -> RLET
- Data.RLE.Internal: RLEB :: Vector (Maybe ByteString) -> RLEB
+ Data.RLE.Internal: RLEB :: Seq (Maybe ByteString) -> RLEB
- Data.RLE.Internal: RLET :: Vector (Maybe Text) -> RLET
+ Data.RLE.Internal: RLET :: Seq (Maybe Text) -> RLET
Files
- CHANGELOG.md +4/−0
- src/Data/BWT.hs +16/−16
- src/Data/BWT/Internal.hs +82/−118
- src/Data/RLE.hs +96/−97
- src/Data/RLE/Internal.hs +158/−174
- text-compression.cabal +7/−9
CHANGELOG.md view
@@ -35,3 +35,7 @@ ## 0.1.0.8 -- 2022-11-11 * Optimized BWT and RLE implementations by switching out sequences with vectors.++## 0.1.0.9 -- 2022-11-12++* Switching back to sequences for maintainability (for now).
src/Data/BWT.hs view
@@ -30,29 +30,28 @@ 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 (Seq(..),fromList,iterateN,length,unstableSortBy,zip) 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 :: (Unbox a,Ord a)- => [a]- -> BWT a-toBWT [] = BWT DVB.empty+toBWT :: Ord a =>+ [a] ->+ BWT a+toBWT [] = BWT DS.Empty toBWT xs = do let saxs = createSuffixArray xss- saToBWT saxs- xss+ BWT (saToBWT saxs+ xss) where- xss = DVU.fromList xs+ xss = DS.fromList xs -- | Helper function for converting a 'ByteString' -- to a 'BWT' 'Word8'.@@ -81,16 +80,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 = sortVecBWT zipped- zipped = DVB.zip bwtt- (DVB.iterateN (DVB.length bwtt) (+1) 0)+ magicsz = DS.unstableSortBy (\(a,b) (c,d) -> sortTB (a,b) (c,d))+ zipped+ zipped = DS.zip bwtt+ (DS.iterateN (DS.length bwtt) (+1) 0) bwtt = (\(BWT t) -> t) bwt -- | Helper function for converting a 'BWT' of 'Word8's
src/Data/BWT/Internal.hs view
@@ -33,28 +33,25 @@ -- 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 Boxed vectors, 'DVB.Vector', and Unboxed vectors, 'DVU.Vector',--- provided by the [vector](https://hackage.haskell.org/package/vector).+-- The implementation of the BWT relies upon sequence provided+-- by the [containers](https://hackage.haskell.org/package/containers). -- -- 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 (when)-import Control.Monad.ST as CMST (ST,runST)+import Control.Monad as CM+import Control.Monad.ST as CMST import Control.Monad.State.Strict() import Data.Foldable as DFold-import Data.List as DL (length,map)+import Data.List as DL import Data.Maybe as DMaybe (fromJust,isNothing)-import Data.Sequence as DS (fromList,(><),null,singleton,zip,sortBy,tails,inits)+import Data.Sequence as DS (Seq(..),empty,findIndexL,fromList,length,index,inits,null,singleton,tails,unstableSortBy,unstableSortOn,zip,(><),(|>),(<|)) import Data.Massiv.Array as DMA import Data.Massiv.Core()-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 Data.STRef as DSTR+import GHC.Generics import Prelude as P @@ -64,19 +61,20 @@ -- the core data inside of the 'SuffixArray' data type. data Suffix a = Suffix { suffixindex :: Int , suffixstartpos :: Int- , suffix :: Maybe (DVU.Vector a)+ , suffix :: Maybe (Seq a) } deriving (Show,Read,Eq,Ord,Generic) -- | The SuffixArray data type.--- Uses 'DVB.Vector' internally.-type SuffixArray a = DVB.Vector (Suffix a)+-- Uses sequence internally.+type SuffixArray a = Seq (Suffix a) -- | The BWT data type.--- Uses 'DVU.Vector' internally.-newtype BWT a = BWT (DVB.Vector (Maybe a))+-- Uses sequence internally.+newtype BWT a = BWT (Seq (Maybe a)) deriving (Eq,Ord,Show,Read,Generic) + -- | The BWTMatrix data type. -- Uses a massiv array internally. type BWTMatrix = DMA.Array BN Ix1 String@@ -87,80 +85,46 @@ {-toBWT functions.-} -- | Computes the Burrows-Wheeler Transform (BWT) using the suffix array--- 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) +-- and the original string (represented as a sequence for performance).+saToBWT :: SuffixArray a ->+ Seq a ->+ Seq (Maybe 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) -- | Computes the corresponding 'SuffixArray' of a given string. Please see [suffix array](https://en.wikipedia.org/wiki/Suffix_array)--- 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+-- 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 where- 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 + xsssuffixes = DS.tails xs+ xsssuffixesf = DS.zip (DS.fromList [1..(DS.length xsssuffixes)])+ xsssuffixes+ xsssuffixesffsorted = DS.unstableSortOn snd xsssuffixesf+ xsssuffixesfff = (\(a,(b,c)) -> (a,b,c))+ <$>+ DS.zip (DS.fromList [1..(DS.length xsssuffixesffsorted)])+ xsssuffixesffsorted {------------------} @@ -178,20 +142,20 @@ compare i1 i2 -- | Abstract BWTSeq type utilizing a sequence.-type BWTVec a = DVB.Vector a+type BWTSeq a = Seq a --- | Abstract data type representing a 'BWTVec' in the (strict) ST monad.-type STBWTVec s a = STRef s (BWTVec a)+-- | Abstract data type representing a BWTSeq in the (strict) ST monad.+type STBWTSeq s a = STRef s (BWTSeq a) --- | State function to push 'BWTVec' data into stack.-pushSTBWTVec :: STBWTVec s a -> a -> ST s ()-pushSTBWTVec s e = do+-- | State function to push BWTString data into stack.+pushSTBWTSeq :: STBWTSeq s a -> a -> ST s ()+pushSTBWTSeq s e = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 e)+ writeSTRef s (s2 DS.|> e) --- | State function to create empty 'STBWTVec' type.-emptySTBWTVec :: ST s (STBWTVec s a)-emptySTBWTVec = newSTRef DVB.empty+-- | State function to create empty STBWTString type.+emptySTBWTSeq :: ST s (STBWTSeq s a)+emptySTBWTSeq = newSTRef DS.empty -- | Abstract BWTCounter and associated state type. type STBWTCounter s a = STRef s Int@@ -205,43 +169,43 @@ emptySTBWTCounter = newSTRef (-1) -- | "Magic" Inverse BWT function.-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+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 bwtcounterstackf <- emptySTBWTCounter bwtcounterstacke <- emptySTBWTCounter- case (DVB.findIndex (\x -> isNothing $ fst x) xs) of- Nothing -> do bwtvecstackr <- readSTRef bwtvecstack- return bwtvecstackr- Just nothingindex -> do let nothingfirst = (DVB.!) xs+ case (DS.findIndexL (\x -> isNothing $ fst x) xs) of+ Nothing -> do bwtseqstackr <- readSTRef bwtseqstack+ return bwtseqstackr+ Just nothingindex -> do let nothingfirst = DS.index xs nothingindex updateSTBWTCounter bwtcounterstacke nothingindex updateSTBWTCounter bwtcounterstackf (snd nothingfirst) iBWT xs- bwtvecstack+ bwtseqstack bwtcounterstackf bwtcounterstacke- bwtvecstackr <- readSTRef bwtvecstack- return bwtvecstackr+ bwtseqstackr <- readSTRef bwtseqstack+ return bwtseqstackr where- iBWT ys bwtvs bwtcsf bwtcse = do+ iBWT ys bwtss bwtcsf bwtcse = do cbwtcsf <- readSTRef bwtcsf cbwtcse <- readSTRef bwtcse CM.when (cbwtcsf /= cbwtcse) $ do - let next = (DVB.!) ys cbwtcsf- pushSTBWTVec bwtvs+ let next = DS.index ys cbwtcsf+ pushSTBWTSeq bwtss (DMaybe.fromJust $ fst next) updateSTBWTCounter bwtcsf (snd next) iBWT ys- bwtvs+ bwtss bwtcsf bwtcse @@ -250,7 +214,7 @@ createBWTMatrix :: String -> BWTMatrix createBWTMatrix t =- DMA.fromList (ParN 0) zippedffff :: DMA.Array BN Ix1 String+ DMA.fromList (ParN 0) zippedffff :: Array BN Ix1 String where zippedffff = DL.map DFold.toList $ DL.map (\(a,b) -> if | isNothing a@@ -266,7 +230,7 @@ ) zippedfff zippedfff = DFold.toList zippedff- zippedff = DS.sortBy (\(a,_) (c,_) -> compare a c)+ zippedff = DS.unstableSortBy (\(a,_) (c,_) -> compare a c) zippedp zippedp = DS.zip suffixesf prefixesf suffixesf = fmap (\x -> if | DS.null x
src/Data/RLE.hs view
@@ -28,11 +28,10 @@ import Data.Char() import Data.Foldable() import Data.Maybe as DMaybe (isNothing,fromJust)+import Data.Sequence as DS (Seq(..)) 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 @@ -68,7 +67,7 @@ textBWTToRLEB :: TextBWT -> RLEB textBWTToRLEB xs =- RLEB (CMST.runST $ vecToRLEB xss)+ RLEB (CMST.runST $ seqToRLEB xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -84,9 +83,9 @@ -- Run-length encoding ('RLEB'). bytestringBWTToRLEB :: BWT Word8 -> RLEB-bytestringBWTToRLEB (BWT (DVB.uncons -> Nothing)) = RLEB DVB.empty-bytestringBWTToRLEB xs =- RLEB (CMST.runST $ vecToRLEB xss)+bytestringBWTToRLEB (BWT DS.Empty) = RLEB DS.Empty+bytestringBWTToRLEB xs =+ RLEB (CMST.runST $ seqToRLEB xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -102,7 +101,7 @@ textBWTToRLET :: TextBWT -> RLET textBWTToRLET xs =- RLET (CMST.runST $ vecToRLET xss)+ RLET (CMST.runST $ seqToRLET xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -119,9 +118,9 @@ -- Run-length encoding ('RLET'). bytestringBWTToRLET :: BWT Word8 -> RLET-bytestringBWTToRLET (BWT (DVB.uncons -> Nothing)) = RLET DVB.empty-bytestringBWTToRLET xs =- RLET (CMST.runST $ vecToRLET xss)+bytestringBWTToRLET (BWT DS.Empty) = RLET DS.Empty+bytestringBWTToRLET xs =+ RLET (CMST.runST $ seqToRLET xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -134,11 +133,11 @@ ((\(BWT t) -> t) xs) -- | Takes a 'Text' and returns the Run-length encoding ('RLEB').-textToRLEB :: DVB.Vector (Maybe Text)+textToRLEB :: Seq (Maybe Text) -> RLEB-textToRLEB (DVB.uncons -> Nothing) = RLEB DVB.empty-textToRLEB xs = - RLEB (CMST.runST $ vecToRLEB xss)+textToRLEB DS.Empty = RLEB DS.Empty+textToRLEB xs = + RLEB (CMST.runST $ seqToRLEB xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -149,26 +148,26 @@ ) xs --- | Takes a 'DVB.Vector' of 'ByteString's and returns the Run-length encoding ('RLEB').-bytestringToRLEB :: DVB.Vector (Maybe ByteString)+-- | Takes a 'Seq' of 'ByteString's and returns the Run-length encoding ('RLEB').+bytestringToRLEB :: Seq (Maybe ByteString) -> RLEB-bytestringToRLEB (DVB.uncons -> Nothing) = RLEB DVB.empty-bytestringToRLEB xs =- RLEB (CMST.runST $ vecToRLEB xs)+bytestringToRLEB DS.Empty = RLEB DS.Empty+bytestringToRLEB xs =+ RLEB (CMST.runST $ seqToRLEB xs) -- | Takes a 'Text' and returns the Run-length encoding (RLE).-textToRLET :: DVB.Vector (Maybe Text)+textToRLET :: Seq (Maybe Text) -> RLET-textToRLET (DVB.uncons -> Nothing) = RLET DVB.empty-textToRLET xs =- RLET (CMST.runST $ vecToRLET xs)+textToRLET DS.Empty = RLET DS.Empty+textToRLET xs =+ RLET (CMST.runST $ seqToRLET xs) -- | Takes a 'ByteString' and returns the Run-length encoding (RLE).-bytestringToRLET :: DVB.Vector (Maybe ByteString)+bytestringToRLET :: Seq (Maybe ByteString) -> RLET-bytestringToRLET (DVB.uncons -> Nothing) = RLET DVB.empty-bytestringToRLET xs =- RLET (CMST.runST $ vecToRLET xss)+bytestringToRLET DS.Empty = RLET DS.Empty+bytestringToRLET xs =+ RLET (CMST.runST $ seqToRLET xss) where xss = fmap (\x -> if | isNothing x -> Nothing@@ -194,17 +193,17 @@ -- back to the original 'ByteString'. bytestringFromBWTFromRLET :: RLET -> ByteString-bytestringFromBWTFromRLET vs = bytestringFromByteStringBWT $+bytestringFromBWTFromRLET xs = bytestringFromByteStringBWT $ BWT $- DVB.map (\x -> if | isNothing x- -> Nothing- | otherwise- -> Just $- DTE.encodeUtf8 $- fromJust x- )- $ - ((\(BWT t) -> t) (textBWTFromRLET vs))+ fmap (\x -> if | isNothing x+ -> Nothing+ | otherwise+ -> Just $+ DTE.encodeUtf8 $+ fromJust x+ )+ $+ ((\(BWT t) -> t) (textBWTFromRLET xs)) -- | Helper function for converting a 'BWT'ed 'RLEB' -- back to the original 'Text'.@@ -222,92 +221,92 @@ -- the 'BWT' of 'Text's. textBWTFromRLET :: RLET -> BWT Text-textBWTFromRLET (RLET (DVB.uncons -> Nothing)) = BWT DVB.empty-textBWTFromRLET vs = - BWT (CMST.runST $ vecFromRLET vs)+textBWTFromRLET (RLET DS.Empty) = BWT DS.Empty+textBWTFromRLET xs = + BWT (CMST.runST $ seqFromRLET xs) -- | Takes a 'RLET' and returns -- the 'BWT' of 'ByteString's. bytestringBWTFromRLET :: RLET -> BWT ByteString-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)+bytestringBWTFromRLET (RLET DS.Empty) = BWT DS.Empty+bytestringBWTFromRLET xs = do+ let originalbwtb = CMST.runST $ seqFromRLET xs+ BWT (fmap (\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 (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)+textBWTFromRLEB (RLEB DS.Empty) = BWT DS.Empty+textBWTFromRLEB xs = do+ let originalbwtt = CMST.runST $ seqFromRLEB xs+ BWT (fmap (\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 (DVB.uncons -> Nothing)) = BWT DVB.empty-bytestringBWTFromRLEB vs =- BWT (CMST.runST $ vecFromRLEB vs)+bytestringBWTFromRLEB (RLEB DS.Empty) = BWT DS.Empty+bytestringBWTFromRLEB xs =+ BWT (CMST.runST $ seqFromRLEB xs) -- | Takes a 'RLEB' and returns--- the original 'DVB.Vector' of 'Text's.+-- the original 'Seq' of 'Text's. textFromRLEB :: RLEB- -> 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+ -> 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 -- | Takes a 'RLEB' and returns--- the original 'DVB.Vector' of 'ByteString's.+-- the original 'Seq' of 'ByteString's. bytestringFromRLEB :: RLEB- -> DVB.Vector (Maybe ByteString)-bytestringFromRLEB (RLEB (DVB.uncons -> Nothing)) = DVB.empty-bytestringFromRLEB vs =- CMST.runST $ vecFromRLEB vs+ -> Seq (Maybe ByteString)+bytestringFromRLEB (RLEB DS.Empty) = DS.Empty+bytestringFromRLEB xs = do+ CMST.runST $ seqFromRLEB xs -- | Takes a 'RLET' and returns--- the original 'DVB.Vector' of 'Text's.+-- the original 'Seq' of 'Text's. textFromRLET :: RLET- -> DVB.Vector (Maybe Text)-textFromRLET (RLET (DVB.uncons -> Nothing)) = DVB.empty-textFromRLET vs =- CMST.runST $ vecFromRLET vs+ -> Seq (Maybe Text)+textFromRLET (RLET DS.Empty) = DS.Empty+textFromRLET xs = do+ CMST.runST $ seqFromRLET xs -- | Takes a 'RLET' and returns--- the original 'DVB.Vector' of 'ByteString's.+-- the original 'Seq' of 'ByteString's. bytestringFromRLET :: RLET- -> 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+ -> 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 {---------------------}
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 'vecToRLEB', 'vecToRLET', 'vecFromRLEB', and 'vecFromRLET'.+-- and the Inverse RLE implementations, namely 'seqToRLEB', 'seqToRLET', 'seqFromRLEB', and 'seqFromRLET'. ----- The RLE implementations rely heavily upon 'DVB.Vector' provided by the [vector](https://hackage.haskell.org/package/vector) library,+-- The RLE implementations rely heavily upon 'Seq' provided by the [containers](https://hackage.haskell.org/package/containers), -- '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 (Seq(..),empty,(|>))+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 (DVB.Vector (Maybe ByteString))+newtype RLEB = RLEB (Seq (Maybe ByteString)) deriving (Eq,Ord,Show,Read,Generic) -- | Basic RLE ('Text') data type.-newtype RLET = RLET (DVB.Vector (Maybe Text))+newtype RLET = RLET (Seq (Maybe Text)) deriving (Eq,Ord,Show,Read,Generic) {-------------------}@@ -71,24 +71,24 @@ {-toRLE (ByteString) functions.-} --- | Abstract 'RLEVecB' type utilizing a sequence.-type RLEVecB = DVB.Vector (Maybe ByteString)+-- | Abstract 'RLESeqB' type utilizing a sequence.+type RLESeqB = Seq (Maybe ByteString) --- | Abstract data type representing a 'RLEVecB' in the (strict) ST monad.-type STRLEVecB s a = STRef s RLEVecB+-- | Abstract data type representing a 'RLESeqB' in the (strict) ST monad.+type STRLESeqB s a = STRef s RLESeqB --- | State function to push 'RLEVecB' data into stack.-pushSTRLEVecB :: STRLEVecB s (Maybe ByteString) -> Maybe ByteString -> ST s ()-pushSTRLEVecB s Nothing = do+-- | State function to push 'RLESeqB' data into stack.+pushSTRLESeqB :: STRLESeqB s (Maybe ByteString) -> Maybe ByteString -> ST s ()+pushSTRLESeqB s Nothing = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 Nothing)-pushSTRLEVecB s (Just e) = do+ writeSTRef s (s2 DS.|> Nothing)+pushSTRLESeqB s (Just e) = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 (Just e))+ writeSTRef s (s2 DS.|> Just e) --- | State function to create empty 'STRLEVecB' type.-emptySTRLEVecB :: ST s (STRLEVecB s a)-emptySTRLEVecB = newSTRef DVB.empty+-- | State function to create empty 'STRLESeqB' type.+emptySTRLESeqB :: ST s (STRLESeqB s a)+emptySTRLESeqB = newSTRef DS.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.-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+seqToRLEB :: RLESeqB+ -> ST s RLESeqB+seqToRLEB DS.Empty = do+ brleseqstackempty <- emptySTRLESeqB+ brleseqstackemptyr <- readSTRef brleseqstackempty+ return brleseqstackemptyr+seqToRLEB (x DS.:<| xs) = do+ brleseqstack <- emptySTRLESeqB brlecounterstack <- emptySTRLECounterB brletempstack <- emptySTRLETempB updateSTRLECounterB brlecounterstack 1 updateSTRLETempB brletempstack- v- iRLEB vs- brlevecstack+ x+ iRLEB xs+ brleseqstack brlecounterstack brletempstack- brlevecstackr <- readSTRef brlevecstack- return brlevecstackr+ brleseqstackr <- readSTRef brleseqstack+ return brleseqstackr where- iRLEB (DVB.uncons -> Nothing) brless brlecs brlets = do+ iRLEB DS.Empty brless brlecs brlets = do cbrlecs <- readSTRef brlecs cbrlets <- readSTRef brlets- pushSTRLEVecB brless+ pushSTRLESeqB brless (Just $ BSC8.pack $ show cbrlecs)- pushSTRLEVecB brless+ pushSTRLESeqB brless cbrlets pure ()- iRLEB (DVB.uncons -> Just (y,ys)) brless brlecs brlets = do+ iRLEB (y DS.:<| ys) brless brlecs brlets = do cbrlecs <- readSTRef brlecs cbrlets <- readSTRef brlets if | isNothing y- -> do pushSTRLEVecB brless+ -> do pushSTRLESeqB brless (Just $ BSC8.pack $ show cbrlecs)- pushSTRLEVecB brless+ pushSTRLESeqB brless cbrlets - pushSTRLEVecB brless+ pushSTRLESeqB brless (Just $ BSC8.pack $ show (1 :: Int))- pushSTRLEVecB brless+ pushSTRLESeqB brless Nothing updateSTRLETempB brlets Nothing @@ -184,11 +184,11 @@ brlecs brlets | otherwise- -> do pushSTRLEVecB brless+ -> do pushSTRLESeqB brless (Just $ BSC8.pack $ show cbrlecs)- pushSTRLEVecB brless+ pushSTRLESeqB brless cbrlets updateSTRLECounterB brlecs 1@@ -204,24 +204,24 @@ {-toRLE (Text) functions.-} --- | Abstract 'RLEVecT' type utilizing a sequence.-type RLEVecT = DVB.Vector (Maybe Text)+-- | Abstract 'RLESeqT' type utilizing a sequence.+type RLESeqT = Seq (Maybe Text) --- | Abstract data type representing a 'RLEVecT' in the (strict) ST monad.-type STRLEVecT s a = STRef s RLEVecT+-- | Abstract data type representing a 'RLESeqT' in the (strict) ST monad.+type STRLESeqT s a = STRef s RLESeqT --- | State function to push 'RLEVecT' data into stack.-pushSTRLEVecT :: STRLEVecT s (Maybe Text) -> (Maybe Text) -> ST s ()-pushSTRLEVecT s Nothing = do+-- | State function to push 'RLESeqT' data into stack.+pushSTRLESeqT :: STRLESeqT s (Maybe Text) -> (Maybe Text) -> ST s ()+pushSTRLESeqT s Nothing = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 Nothing)-pushSTRLEVecT s (Just e) = do+ writeSTRef s (s2 DS.|> Nothing)+pushSTRLESeqT s (Just e) = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 (Just e))+ writeSTRef s (s2 DS.|> Just e) --- | State function to create empty 'STRLEVecT' type.-emptySTRLEVecT :: ST s (STRLEVecT s a)-emptySTRLEVecT = newSTRef DVB.empty+-- | State function to create empty 'STRLESeqT' type.+emptySTRLESeqT :: ST s (STRLESeqT s a)+emptySTRLESeqT = newSTRef DS.empty -- | Abstract 'STRLETempT' state type. type STRLETempT s a = STRef s (Maybe Text)@@ -247,52 +247,52 @@ emptySTRLECounterT = newSTRef (-1) -- | Strict state monad function.-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+seqToRLET :: RLESeqT ->+ ST s RLESeqT+seqToRLET DS.Empty = do+ trleseqstackempty <- emptySTRLESeqT+ trleseqstackemptyr <- readSTRef trleseqstackempty+ return trleseqstackemptyr+seqToRLET (x DS.:<| xs) = do+ trleseqstack <- emptySTRLESeqT trlecounterstack <- emptySTRLECounterT trletempstack <- emptySTRLETempT updateSTRLECounterT trlecounterstack 1 updateSTRLETempT trletempstack- v- iRLET vs- trlevecstack+ x+ iRLET xs+ trleseqstack trlecounterstack trletempstack- trlevecstackr <- readSTRef trlevecstack- return trlevecstackr+ trleseqstackr <- readSTRef trleseqstack+ return trleseqstackr where- iRLET (DVB.uncons -> Nothing) trless trlecs trlets = do+ iRLET DS.Empty trless trlecs trlets = do ctrlecs <- readSTRef trlecs ctrlets <- readSTRef trlets- pushSTRLEVecT trless+ pushSTRLESeqT trless (Just $ DText.pack $ show ctrlecs)- pushSTRLEVecT trless+ pushSTRLESeqT trless ctrlets pure ()- iRLET (DVB.uncons -> Just (y,ys)) trless trlecs trlets = do+ iRLET (y DS.:<| ys) trless trlecs trlets = do ctrlecs <- readSTRef trlecs ctrlets <- readSTRef trlets if | isNothing y- -> do pushSTRLEVecT trless+ -> do pushSTRLESeqT trless (Just $ DText.pack $ show ctrlecs)- pushSTRLEVecT trless+ pushSTRLESeqT trless ctrlets- pushSTRLEVecT trless+ pushSTRLESeqT trless (Just $ DText.pack $ show (1 :: Int))- pushSTRLEVecT trless+ pushSTRLESeqT trless Nothing updateSTRLETempT trlets Nothing@@ -317,11 +317,11 @@ trlecs trlets | otherwise- -> do pushSTRLEVecT trless+ -> do pushSTRLESeqT trless (Just $ DText.pack $ show ctrlecs)- pushSTRLEVecT trless+ pushSTRLESeqT trless ctrlets updateSTRLECounterT trlecs 1@@ -337,69 +337,59 @@ {-fromRLE (ByteString) functions.-} --- | '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 'FRLEVecB' type utilizing a sequence.-type FRLEVecB = DVB.Vector (Maybe ByteString)+-- | Abstract 'FRLESeqB' type utilizing a sequence.+type FRLESeqB = Seq (Maybe ByteString) --- | Abstract data type representing a 'FRLEVecB' in the (strict) ST monad.-type FSTRLEVecB s a = STRef s FRLEVecB+-- | Abstract data type representing a 'FRLESeqB' in the (strict) ST monad.+type FSTRLESeqB s a = STRef s FRLESeqB --- | State function to push 'FRLEVecB' data into stack.-pushFSTRLEVecB :: FSTRLEVecB s (Maybe ByteString) -> (Maybe ByteString) -> ST s ()-pushFSTRLEVecB s Nothing = do+-- | State function to push 'FRLESeqB' data into stack.+pushFSTRLESeqB :: FSTRLESeqB s (Maybe ByteString) -> (Maybe ByteString) -> ST s ()+pushFSTRLESeqB s Nothing = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 Nothing)-pushFSTRLEVecB s (Just e) = do+ writeSTRef s (s2 DS.|> Nothing)+pushFSTRLESeqB s (Just e) = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 (Just e))+ writeSTRef s (s2 DS.|> Just e) --- | State function to create empty 'FSTRLEVecB' type.-emptyFSTRLEVecB :: ST s (FSTRLEVecB s a)-emptyFSTRLEVecB = newSTRef DVB.empty+-- | State function to create empty 'FSTRLESeqB' type.+emptyFSTRLESeqB :: ST s (FSTRLESeqB s a)+emptyFSTRLESeqB = newSTRef DS.empty -- | Strict state monad function.-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+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 where- iFRLEB (unconsb2 -> Just (y1,y2,Nothing)) fbrless =+ iFRLEB (y1 DS.:<| y2 DS.:<| DS.Empty) fbrless = if | isJust y1 &&- isNothing (DVB.head y2)- -> do pushFSTRLEVecB fbrless+ isNothing y2+ -> do pushFSTRLESeqB fbrless Nothing pure () | otherwise -> do let y1' = read $ BSC8.unpack $ fromJust y1 :: Int- let y2' = fromJust $- DVB.head y2+ let y2' = fromJust y2 CM.replicateM_ y1'- (pushFSTRLEVecB fbrless+ (pushFSTRLESeqB fbrless (Just y2')) pure () - iFRLEB (unconsb2 -> Just (y1,y2,Just ys)) fbrless =+ iFRLEB (y1 DS.:<| y2 DS.:<| ys) fbrless = if | isJust y1 &&- isNothing (DVB.head y2)- -> do pushFSTRLEVecB fbrless+ isNothing y2+ -> do pushFSTRLESeqB fbrless Nothing iFRLEB ys fbrless@@ -407,82 +397,74 @@ -> do let y1' = read $ BSC8.unpack $ fromJust y1 :: Int- let y2' = fromJust $- DVB.head y2+ let y2' = fromJust y2 CM.replicateM_ y1'- (pushFSTRLEVecB fbrless+ (pushFSTRLESeqB fbrless (Just y2')) iFRLEB ys- fbrless+ fbrless + iFRLEB (DSI.Seq EmptyT) _ = pure ()+ iFRLEB (DSI.Seq (Single _)) _ = pure ()+ iFRLEB (DSI.Seq (Deep _ _ _ _)) _ = pure () {---------------------------------} {-fromRLE (Text) functions.-} --- | '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 'FRLEVecT' type utilizing a sequence.-type FRLEVecT = DVB.Vector (Maybe Text)+-- | Abstract 'FRLESeqT' type utilizing a sequence.+type FRLESeqT = Seq (Maybe Text) --- | Abstract data type representing a 'FRLEVecT' in the (strict) ST monad.-type FSTRLEVecT s a = STRef s FRLEVecT+-- | Abstract data type representing a 'FRLESeqT' in the (strict) ST monad.+type FSTRLESeqT s a = STRef s FRLESeqT --- | State function to push 'FSTRLEVecT' data into stack.-pushFSTRLEVecT :: FSTRLEVecT s (Maybe Text) -> (Maybe Text) -> ST s ()-pushFSTRLEVecT s Nothing = do+-- | State function to push 'FSTRLESeqT' data into stack.+pushFSTRLESeqT :: FSTRLESeqT s (Maybe Text) -> (Maybe Text) -> ST s ()+pushFSTRLESeqT s Nothing = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 Nothing)-pushFSTRLEVecT s (Just e) = do+ writeSTRef s (s2 DS.|> Nothing)+pushFSTRLESeqT s (Just e) = do s2 <- readSTRef s- writeSTRef s (DVB.snoc s2 (Just e))+ writeSTRef s (s2 DS.|> Just e) --- | State function to create empty 'FSTRLEVecT' type.-emptyFSTRLEVecT :: ST s (FSTRLEVecT s a)-emptyFSTRLEVecT = newSTRef DVB.empty+-- | State function to create empty 'FSTRLESeqT' type.+emptyFSTRLESeqT :: ST s (FSTRLESeqT s a)+emptyFSTRLESeqT = newSTRef DS.empty -- | Strict state monad function.-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 =+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 = if | isJust y1 &&- isNothing (DVB.head y2)- -> do pushFSTRLEVecT ftrless+ isNothing y2+ -> do pushFSTRLESeqT ftrless Nothing pure () | otherwise -> do let y1' = read $ DText.unpack $ fromJust y1 :: Int- let y2' = fromJust $- DVB.head y2+ let y2' = fromJust y2 CM.replicateM_ y1'- (pushFSTRLEVecT ftrless+ (pushFSTRLESeqT ftrless (Just y2')) pure ()- iFRLET (unconst2 -> Just (y1,y2,Just ys)) ftrless =+ iFRLET (y1 DS.:<| y2 DS.:<| ys) ftrless = if | isJust y1 &&- isNothing (DVB.head y2)- -> do pushFSTRLEVecT ftrless+ isNothing y2+ -> do pushFSTRLESeqT ftrless Nothing iFRLET ys ftrless@@ -490,12 +472,14 @@ -> do let y1' = read $ DText.unpack $ fromJust y1 :: Int- let y2' = fromJust $- DVB.head y2+ let y2' = fromJust y2 CM.replicateM_ y1'- (pushFSTRLEVecT ftrless+ (pushFSTRLESeqT 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.8+version: 0.1.0.9 -- A short (one-line) description of the package. synopsis: A text compression library.@@ -76,14 +76,12 @@ -- 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,- vector >= 0.13.0 && < 0.14,- vector-algorithms >= 0.9.0 && < 0.10+ 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 -- Directories containing source files. hs-source-dirs: src