text-compression 0.1.0.16 → 0.1.0.17

raw patch · 4 files changed

+474/−16 lines, 4 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• src/Data/FMIndex.hs +90/−12
• src/Data/FMIndex/Internal.hs +379/−3
• text-compression.cabal +1/−1

@@ -68,3 +68,7 @@  * Added FM-index count operation and updated FM-index example text. * Added contents to all internal modules.++## 0.1.0.17 -- 2022-12-02++* Added FM-index locate operation.

@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiWayIf    #-}-{-# LANGUAGE ViewPatterns  #-}-{-# LANGUAGE Strict        #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE Strict            #-}   -- |@@ -28,11 +29,18 @@ -- -- There are various other lower-level functions for interacting with the FMIndex implementation on 'ByteString' and 'Text' as well. ----- = Operations+-- = Operation: Count ----- The count operation is supported by the 'countFMIndexB' function for 'ByteString's--- and the 'countFMIndexT' function for 'Text'.+-- The count operation on 'ByteString', 'bytestringFMIndexCount', is implemented using the 'countFMIndexB' function. --+-- The count operation on 'Text', 'textFMIndexCount', is implemented using the 'countFMIndexT' function.+--+-- = Operation: Locate+--+-- The locate operation on 'ByteString', 'bytestringFMIndexLocate', is implemented using the 'locateFMIndexB' function.+--+-- The locate operation on 'Text', 'textFMIndexLocate', is implemented using the 'locateFMIndexT' function.+-- -- = Internal -- -- @"Data.FMIndex.Internal"@ contains efficient and stateful implementations of the FMIndex and Inverse FMIndex algorithms.@@ -66,7 +74,10 @@                       bytestringFromFMIndexT,                       -- * Count operations                       bytestringFMIndexCount,-                      textFMIndexCount+                      textFMIndexCount,+                      -- * Locate operations+                      bytestringFMIndexLocate,+                      textFMIndexLocate                     ) where  import Data.BWT@@ -77,11 +88,11 @@ import Control.Monad.ST as CMST import Control.Monad.State.Strict() import Data.ByteString as BS-import Data.ByteString.Char8 as BSC8 (singleton,unpack)+import Data.ByteString.Char8 as BSC8 (singleton,uncons,unpack) import Data.Char() import Data.Foldable() import Data.Maybe as DMaybe (isNothing,fromJust)-import Data.Sequence as DS (Seq(..),ViewL(..),fromList,viewl)+import Data.Sequence as DS (Seq(..),ViewL(..),fromList,index,viewl) import Data.STRef() import Data.Text as DText import Data.Text.Encoding as DTE (decodeUtf8,encodeUtf8)@@ -502,7 +513,9 @@ bytestringFMIndexCount :: ByteString                        -> ByteString                        -> CIntB-bytestringFMIndexCount pat input = do+bytestringFMIndexCount (BSC8.uncons -> Nothing) _                        = Nothing+bytestringFMIndexCount _                        (BSC8.uncons -> Nothing) = Nothing+bytestringFMIndexCount pat                      input                    = do   let bytestringfmindex = bytestringToBWTToFMIndexB input   let patternf          = fmap (BSC8.singleton) $                           DS.fromList           $@@ -517,12 +530,77 @@ textFMIndexCount :: Text                  -> Text                  -> CIntT+textFMIndexCount ""  _     = Nothing+textFMIndexCount _   ""    = Nothing textFMIndexCount pat input = do   let textfmindex = textToBWTToFMIndexT input   let patternf    = fmap (DText.singleton) $-                    DS.fromList           $+                    DS.fromList            $                     DText.unpack pat   runST $ countFMIndexT patternf                         textfmindex  {-------------------}+++{-Locate operations.-}++-- | Takes a pattern ('ByteString')+-- and an input 'ByteString'+-- and returns the indexe(s) of occurences of the pattern+-- in the input 'ByteString'.+-- The output is not sorted.+bytestringFMIndexLocate :: ByteString+                        -> ByteString+                        -> LIntB+bytestringFMIndexLocate (BSC8.uncons -> Nothing) _                        = DS.Empty+bytestringFMIndexLocate _                        (BSC8.uncons -> Nothing) = DS.Empty+bytestringFMIndexLocate pat                      input                    = do+  let bytestringsa      = createSuffixArray   $+                          fmap (BS.singleton) $+                          DS.fromList         $ +                          BS.unpack input+  let bytestringfmindex = bytestringToBWTToFMIndexB input+  let patternf          = fmap (BSC8.singleton) $+                          DS.fromList           $+                          BSC8.unpack pat+  let indices           = runST $ locateFMIndexB patternf+                                                 bytestringfmindex+  fmap (\x -> if | isNothing x+                 -> Nothing+                 | otherwise+                 -> Just           $+                    suffixstartpos $+                    DS.index bytestringsa ((fromJust x) - 1)+       ) indices++-- | Takes a pattern ('Text')+-- and an input 'Text'+-- and returns the indexe(s) of occurences of the pattern+-- in the input 'Text'.+-- The output is not sorted.+textFMIndexLocate :: Text+                  -> Text+                  -> LIntT+textFMIndexLocate ""  _     = DS.Empty+textFMIndexLocate _   ""    = DS.Empty+textFMIndexLocate pat input = do+  let textsa      = createSuffixArray      $+                    fmap (DText.singleton) $+                    DS.fromList            $+                    DText.unpack input+  let textfmindex = textToBWTToFMIndexT input+  let patternf    = fmap (DText.singleton) $+                    DS.fromList            $+                    DText.unpack pat+  let indices     = runST $ locateFMIndexT patternf+                                           textfmindex+  fmap (\x -> if | isNothing x+                 -> Nothing+                 | otherwise+                 -> Just           $+                    suffixstartpos $+                    DS.index textsa ((fromJust x) - 1)+       ) indices++{--------------------}

@@ -35,7 +35,7 @@ -- [Full-text Minute-space index (FM-index)](https://en.wikipedia.org/wiki/FM-index) -- and the Inverse FM-index implementations, namely 'seqToOccCKB', 'seqToOccCKT', 'seqToCcB', 'seqToCcT', 'seqFromFMIndexB', and 'seqFromFMIndexT'. ----- The FM-index implementations rely heavily upon 'Seq' provided by the [containers](https://hackage.haskell.org/package/containers),+-- The FM-index implementations rely heavily upon 'Seq' provided by the [containers](https://hackage.haskell.org/package/containers) 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. --@@ -216,7 +216,39 @@                                STCCurrentEndT,                                updateSTCCurrentEndT,                                emptySTCCurrentEndT,-                               countFMIndexT       +                               countFMIndexT,+                               -- * Locate (ByteString) operation+                               PBLPat,+                               LIntB,+                               STLBoolB,+                               updateSTLBoolB,+                               emptySTLBoolB,+                               STLCounterB,+                               updateSTLCounterB,+                               emptySTLCounterB,+                               STLCurrentStartB,+                               updateSTLCurrentStartB,+                               emptySTLCurrentStartB,+                               STLCurrentEndB,+                               updateSTLCurrentEndB,+                               emptySTLCurrentEndB,+                               locateFMIndexB,+                               -- * Locate (Text) operation+                               PTLPat,+                               LIntT,+                               STLBoolT,+                               updateSTLBoolT,+                               emptySTLBoolT,+                               STLCounterT,+                               updateSTLCounterT,+                               emptySTLCounterT,+                               STLCurrentStartT,+                               updateSTLCurrentStartT,+                               emptySTLCurrentStartT,+                               STLCurrentEndT,+                               updateSTLCurrentEndT,+                               emptySTLCurrentEndT,+                               locateFMIndexT                              ) where  import Data.BWT.Internal()@@ -231,7 +263,7 @@ import Data.Foldable() import Data.List() import Data.Maybe()-import Data.Sequence as DS (Seq(..),ViewL(..),ViewR(..),empty,findIndexL,index,length,(|>))+import Data.Sequence as DS (Seq(..),ViewL(..),ViewR(..),empty,findIndexL,fromList,index,length,(|>)) import Data.Sequence.Internal as DSI import Data.STRef as DSTR import Data.Text as DText hiding (count)@@ -1130,3 +1162,347 @@                                                                    tcce  {-------------------------------}+++{-Locate (ByteString) operation.-}++-- | Abstract 'PBLPat' type utilizing a 'Seq'.+type PBLPat = Seq ByteString++-- | Abstract 'LIntB' type utilizing an 'Int'.+type LIntB = Seq (Maybe Int)++-- | Abstract 'STLBoolB' type utilizing a 'Bool'.+type STLBoolB s a = STRef s Bool++-- | State function to update 'STLBoolB' in the (strict) ST monad.+updateSTLBoolB :: STLBoolB s Bool+               -> Bool+               -> ST s ()+updateSTLBoolB s e = writeSTRef s e++-- | State function to create empty 'STLBoolB' type.+emptySTLBoolB :: ST s (STLBoolB s Bool)+emptySTLBoolB = newSTRef False++-- | Abstract data type representing a 'STLCounterB' in the (strict) ST monad.+type STLCounterB s a = STRef s Int++-- | State function to update 'STLCounterB'+updateSTLCounterB :: STLCounterB s Int+                  -> Int+                  -> ST s ()+updateSTLCounterB s e = writeSTRef s e++-- | State function to create empty 'STLCounterB' type.+emptySTLCounterB :: ST s (STLCounterB s Int)+emptySTLCounterB = newSTRef 0++-- | Abstract 'STLCurrentStartB' type utilizing a 'Seq'.+type STLCurrentStartB s a = STRef s Int++-- | State function to update 'STLCurrentStartB'.+updateSTLCurrentStartB :: STLCurrentStartB s Int+                       -> Int+                       -> ST s ()+updateSTLCurrentStartB s e = writeSTRef s e++-- | State function to create empty 'STLCurrentStartB' type.+emptySTLCurrentStartB :: ST s (STLCurrentStartB s Int)+emptySTLCurrentStartB = newSTRef (-1)++-- | Abstract 'STLCurrentEndB' type utilizing a 'Seq'.+type STLCurrentEndB s a = STRef s Int++-- | State function to update 'STLCurrentEndB'.+updateSTLCurrentEndB :: STLCurrentEndB s Int+                     -> Int+                     -> ST s ()+updateSTLCurrentEndB s e = writeSTRef s e++-- | State function to create empty 'STLCurrentEndB' type.+emptySTLCurrentEndB :: ST s (STCCurrentEndB s Int)+emptySTLCurrentEndB = newSTRef (-1)++-- | Locate operation on a 'FMIndexB'.+-- This operation takes a pattern ('Seq' 'ByteString')+-- and returns the indexe(s) of occurences of that pattern+-- in the original text T [credit](https://en.wikipedia.org/wiki/FM-index).+locateFMIndexB :: PBLPat+               -> FMIndexB+               -> ST s LIntB+locateFMIndexB DS.Empty _                              = return DS.Empty+locateFMIndexB _        (FMIndexB (CcB DS.Empty,_))    = return DS.Empty+locateFMIndexB _        (FMIndexB (_,OccCKB DS.Empty)) = return DS.Empty +locateFMIndexB xs       ys                             = do+  blcounter      <- emptySTLCounterB+  blbool         <- emptySTLBoolB+  blcurrentstart <- emptySTLCurrentStartB+  blcurrentend   <- emptySTLCurrentEndB+  iLB xs+      ys+      blcounter+      blbool+      blcurrentstart+      blcurrentend+  cblcurrentstart <- readSTRef blcurrentstart+  cblcurrentend   <- readSTRef blcurrentend+  cblbool         <- readSTRef blbool+  let indexes = if | (cblcurrentstart == (-1) && cblcurrentend == (-1)) ||+                     ((cblcurrentend - cblcurrentstart) + 1) == 0       ||+                     cblbool+                   -> DS.Empty+                   | otherwise+                   -> fmap Just   $+                      DS.fromList $+                      [cblcurrentstart..cblcurrentend]+  return indexes+    where+      iLB DS.Empty      _  _   _   _    _    = pure ()+      iLB (as DS.:|> a) bs blc blb blcs blce = do+        let ccbbs = (\(CcB b) -> b) $+                    (\(a,_) -> a)   $+                    (\(FMIndexB b) -> b) bs+        let coccckbs = (\(OccCKB b) -> b) $+                       (\(_,b) -> b)      $+                       (\(FMIndexB b) -> b) bs+        cblc <- readSTRef blc+        cblcs <- readSTRef blcs+        cblce <- readSTRef blce+        if | cblcs > cblce+           -> do updateSTLBoolB blb+                                True+                 pure ()+           | otherwise+           -> if | cblc == 0+                 -> do case DS.findIndexL (\(_,d) -> d == Just a) ccbbs of+                         Nothing     -> pure ()+                         Just bindex -> do if | bindex == (DS.length ccbbs) - 1+                                              -> do let istart = (fst $ DS.index ccbbs bindex) + 1+                                                    let iend   = case viewl coccckbs of+                                                                   EmptyL      -> (-1)+                                                                   (x DS.:< _) -> DS.length $+                                                                                  snd x+                                                    updateSTLCurrentStartB blcs+                                                                           istart+                                                    updateSTLCurrentEndB blce+                                                                         iend+                                                    updateSTLCounterB blc+                                                                      1+                                                    iLB as+                                                        bs+                                                        blc+                                                        blb+                                                        blcs+                                                        blce+                                              | otherwise+                                              -> do let istart = (fst $ DS.index ccbbs bindex) + 1+                                                    let iend   = fst $ DS.index ccbbs (bindex + 1)+                                                    updateSTLCurrentStartB blcs+                                                                           istart+                                                    updateSTLCurrentEndB blce+                                                                         iend+                                                    updateSTLCounterB blc+                                                                      1+                                                    iLB as+                                                        bs+                                                        blc+                                                        blb+                                                        blcs+                                                        blce+                 | otherwise+                 -> do case DS.findIndexL (\(_,d) -> d == Just a) ccbbs of+                         Nothing     -> pure ()+                         Just bindex -> do case DS.findIndexL (\(e,_) -> e == Just a) coccckbs of+                                             Nothing     -> pure ()+                                             Just cindex -> do let istart = (fst $ DS.index ccbbs bindex)                               ++                                                                            ((\(_,b,_) -> b) $+                                                                             DS.index (snd $ DS.index coccckbs cindex) (cblcs - 1 - 1)) ++                                                                            1+                                                               let iend   = (fst $ DS.index ccbbs bindex) ++                                                                            ((\(_,b,_) -> b) $+                                                                             DS.index (snd $ DS.index coccckbs cindex) (cblce - 1))+                                                               updateSTLCurrentStartB blcs+                                                                                      istart+                                                               updateSTLCurrentEndB blce+                                                                                    iend+                                                               iLB as+                                                                   bs+                                                                   blc+                                                                   blb+                                                                   blcs+                                                                   blce++{--------------------------------}+++{-Locate (Text) operation.-}++-- | Abstract 'PTLPat' type utilizing a 'Seq'.+type PTLPat = Seq Text++-- | Abstract 'LIntT' type utilizing an 'Int'.+type LIntT = Seq (Maybe Int)++-- | Abstract 'STLBoolT' type utilizing a 'Bool'.+type STLBoolT s a = STRef s Bool++-- | State function to update 'STLBoolT' in the (strict) ST monad.+updateSTLBoolT :: STLBoolT s Bool+               -> Bool+               -> ST s ()+updateSTLBoolT s e = writeSTRef s e++-- | State function to create empty 'STLBoolT' type.+emptySTLBoolT :: ST s (STLBoolT s Bool)+emptySTLBoolT = newSTRef False++-- | Abstract data type representing a 'STLCounterT' in the (strict) ST monad.+type STLCounterT s a = STRef s Int++-- | State function to update 'STLCounterT'+updateSTLCounterT :: STLCounterT s Int+                  -> Int+                  -> ST s ()+updateSTLCounterT s e = writeSTRef s e++-- | State function to create empty 'STLCounterT' type.+emptySTLCounterT :: ST s (STLCounterT s Int)+emptySTLCounterT = newSTRef 0++-- | Abstract 'STLCurrentStartT' type utilizing a 'Seq'.+type STLCurrentStartT s a = STRef s Int++-- | State function to update 'STLCurrentStartT'.+updateSTLCurrentStartT :: STLCurrentStartT s Int+                       -> Int+                       -> ST s ()+updateSTLCurrentStartT s e = writeSTRef s e++-- | State function to create empty 'STLCurrentStartT' type.+emptySTLCurrentStartT :: ST s (STLCurrentStartT s Int)+emptySTLCurrentStartT = newSTRef (-1)++-- | Abstract 'STLCurrentEndT' type utilizing a 'Seq'.+type STLCurrentEndT s a = STRef s Int++-- | State function to update 'STLCurrentEndT'.+updateSTLCurrentEndT :: STLCurrentEndT s Int+                     -> Int+                     -> ST s ()+updateSTLCurrentEndT s e = writeSTRef s e++-- | State function to create empty 'STLCurrentEndT' type.+emptySTLCurrentEndT :: ST s (STLCurrentEndT s Int)+emptySTLCurrentEndT = newSTRef (-1)++-- | Locate operation on a 'FMIndexT'.+-- This operation takes a pattern ('Seq' 'Text')+-- and returns the indexe(s) of occurences of that pattern+-- in the original text T [credit](https://en.wikipedia.org/wiki/FM-index).+locateFMIndexT :: PTLPat+               -> FMIndexT+               -> ST s LIntT+locateFMIndexT DS.Empty _                              = return DS.Empty+locateFMIndexT _        (FMIndexT (CcT DS.Empty,_))    = return DS.Empty+locateFMIndexT _        (FMIndexT (_,OccCKT DS.Empty)) = return DS.Empty+locateFMIndexT xs       ys                             = do+  tlcounter      <- emptySTLCounterT+  tlbool         <- emptySTLBoolT+  tlcurrentstart <- emptySTLCurrentStartT+  tlcurrentend   <- emptySTLCurrentEndT+  iLT xs+      ys+      tlcounter+      tlbool+      tlcurrentstart+      tlcurrentend+  ctlcurrentstart <- readSTRef tlcurrentstart+  ctlcurrentend   <- readSTRef tlcurrentend+  ctlbool         <- readSTRef tlbool+  let indexes = if | (ctlcurrentstart == (-1) && ctlcurrentend == (-1)) ||+                     ((ctlcurrentend - ctlcurrentstart) + 1) == 0       ||+                     ctlbool+                   -> DS.Empty+                   | otherwise+                   -> fmap Just   $+                      DS.fromList $+                      [ctlcurrentstart..ctlcurrentend]+  return indexes+    where+      iLT DS.Empty      _  _   _   _    _    = pure ()+      iLT (as DS.:|> a) bs tlc tlb tlcs tlce = do+        let cctbs = (\(CcT t) -> t) $+                    (\(a,_) -> a)   $+                    (\(FMIndexT t) -> t) bs+        let coccckts = (\(OccCKT t) -> t) $+                       (\(_,b) -> b)      $+                       (\(FMIndexT t) -> t) bs+        ctlc <- readSTRef tlc+        ctlcs <- readSTRef tlcs+        ctlce <- readSTRef tlce+        if | ctlcs > ctlce+           -> do updateSTLBoolT tlb+                                True+                 pure ()+           | otherwise+           -> if | ctlc == 0+                 -> do case DS.findIndexL (\(_,d) -> d == Just a) cctbs of+                         Nothing     -> pure ()+                         Just bindex -> do if | bindex == (DS.length cctbs) - 1+                                              -> do let istart = (fst $ DS.index cctbs bindex) + 1+                                                    let iend   = case viewl coccckts of+                                                                   EmptyL      -> (-1)+                                                                   (x DS.:< _) -> DS.length $+                                                                                  snd x+                                                    updateSTLCurrentStartT tlcs+                                                                           istart+                                                    updateSTLCurrentEndT tlce+                                                                         iend+                                                    updateSTLCounterT tlc+                                                                      1+                                                    iLT as+                                                        bs+                                                        tlc+                                                        tlb+                                                        tlcs+                                                        tlce+                                              | otherwise+                                              -> do let istart = (fst $ DS.index cctbs bindex) + 1+                                                    let iend   = fst $ DS.index cctbs (bindex + 1)+                                                    updateSTLCurrentStartT tlcs+                                                                           istart+                                                    updateSTLCurrentEndT tlce+                                                                         iend+                                                    updateSTLCounterT tlc+                                                                      1+                                                    iLT as+                                                        bs+                                                        tlc+                                                        tlb+                                                        tlcs+                                                        tlce+                 | otherwise+                 -> do case DS.findIndexL (\(_,d) -> d == Just a) cctbs of+                         Nothing     -> pure ()+                         Just bindex -> do case DS.findIndexL (\(e,_) -> e == Just a) coccckts of+                                             Nothing     -> pure ()+                                             Just cindex -> do let istart = (fst $ DS.index cctbs bindex)                               ++                                                                            ((\(_,b,_) -> b) $+                                                                             DS.index (snd $ DS.index coccckts cindex) (ctlcs - 1 - 1)) ++                                                                            1+                                                               let iend   = (fst $ DS.index cctbs bindex) ++                                                                            ((\(_,b,_) -> b) $+                                                                             DS.index (snd $ DS.index coccckts cindex) (ctlce - 1))+                                                               updateSTCCurrentStartT tlcs+                                                                                      istart+                                                               updateSTCCurrentEndT tlce+                                                                                    iend+                                                               iLT as+                                                                   bs+                                                                   tlc+                                                                   tlb+                                                                   tlcs+                                                                   tlce++{--------------------------}

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.1.0.16+version:            0.1.0.17  -- A short (one-line) description of the package. synopsis:           A text compression library.