diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/src/Data/FMIndex.hs b/src/Data/FMIndex.hs --- a/src/Data/FMIndex.hs +++ b/src/Data/FMIndex.hs @@ -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 + +{--------------------} diff --git a/src/Data/FMIndex/Internal.hs b/src/Data/FMIndex/Internal.hs --- a/src/Data/FMIndex/Internal.hs +++ b/src/Data/FMIndex/Internal.hs @@ -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 + +{--------------------------} diff --git a/text-compression.cabal b/text-compression.cabal --- a/text-compression.cabal +++ b/text-compression.cabal @@ -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.