AhoCorasick (empty) → 0.0.1
raw patch · 6 files changed
+489/−0 lines, 6 filesdep +arraydep +basedep +hashablesetup-changed
Dependencies added: array, base, hashable, mtl, unordered-containers
Files
- AhoCorasick.cabal +40/−0
- LICENSE +30/−0
- README.md +55/−0
- Setup.hs +5/−0
- Text/AhoCorasick.hs +305/−0
- Text/AhoCorasick/Internal/Deque.hs +54/−0
+ AhoCorasick.cabal view
@@ -0,0 +1,40 @@+name: AhoCorasick+version: 0.0.1+license: BSD3+license-file: LICENSE+category: Text+copyright: Sergey S Lymar (c) 2012+author: Sergey S Lymar <sergey.lymar@gmail.com>+maintainer: Sergey S Lymar <sergey.lymar@gmail.com>+stability: experimental+tested-with: GHC == 7.0.3+synopsis: Aho-Corasick string matching algorithm+cabal-version: >= 1.8+homepage: http://github.com/lymar/AhoCorasick+bug-reports: http://github.com/lymar/AhoCorasick/issues+build-type: Simple+description:+ Aho-Corasick string matching algorithm.+ .+ See homepage for examples of usage: <http://github.com/lymar/AhoCorasick>++extra-source-files:+ README.md++library+ exposed-modules:+ Text.AhoCorasick++ other-modules:+ Text.AhoCorasick.Internal.Deque++ build-depends:+ base == 4.*+ ,unordered-containers+ ,hashable+ ,array+ ,mtl++source-repository head+ type: git+ location: http://github.com/lymar/AhoCorasick
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Sergey S Lymar++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,55 @@+# AhoCorasick++[Aho-Corasick](http://en.wikipedia.org/wiki/Aho%E2%80%93Corasick_string_matching_algorithm) string matching algorithm.++## Installation++ cabal update+ cabal install AhoCorasick++## Examples++#### Simplest example++```haskell+example1 = mapM_ print $ findAll simpleSM "ushers" where+ simpleSM = makeSimpleStateMachine ["he","she","his","hers"]+```++```+Position {pIndex = 1, pLength = 3, pVal = "she"}+Position {pIndex = 2, pLength = 2, pVal = "he"}+Position {pIndex = 2, pLength = 4, pVal = "hers"}+```++#### With data++```haskell+example2 = mapM_ print $ findAll sm "ushers" where+ sm = makeStateMachine [("he",0),("she",1),("his",2),("hers",3)]+```++```+Position {pIndex = 1, pLength = 3, pVal = 1}+Position {pIndex = 2, pLength = 2, pVal = 0}+Position {pIndex = 2, pLength = 4, pVal = 3}+```++#### Step-by-step state machine evaluation++```haskell+example3 = mapM_ print $ next sm "ushers" where+ sm = makeSimpleStateMachine ["he","she","his","hers"]+ next _ [] = []+ next sm (s:n) = let (SMStepRes match nextSM) = stateMachineStep sm s in+ (s, match) : next nextSM n+```++```+(u,[])+(s,[])+(h,[])+(e,[(3,"she"),(2,"he")])+(r,[])+(s,[(4,"hers")])+```
+ Setup.hs view
@@ -0,0 +1,5 @@+#! /usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain+
+ Text/AhoCorasick.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, ExistentialQuantification #-}+-- Module: Text.Hastache+-- Copyright: Sergey S Lymar (c) 2012+-- License: BSD3+-- Maintainer: Sergey S Lymar <sergey.lymar@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Aho-Corasick string matching algorithm++{- | Aho-Corasick string matching algorithm++Simplest example:++@+example1 = mapM_ print $ findAll simpleSM \"ushers\" where+ simpleSM = makeSimpleStateMachine [\"he\",\"she\",\"his\",\"hers\"]+@++@+Position {pIndex = 1, pLength = 3, pVal = \"she\"}+Position {pIndex = 2, pLength = 2, pVal = \"he\"}+Position {pIndex = 2, pLength = 4, pVal = \"hers\"}+@++With data:++@+example2 = mapM_ print $ findAll sm \"ushers\" where+ sm = makeStateMachine [(\"he\",0),(\"she\",1),(\"his\",2),(\"hers\",3)]+@++@+Position {pIndex = 1, pLength = 3, pVal = 1}+Position {pIndex = 2, pLength = 2, pVal = 0}+Position {pIndex = 2, pLength = 4, pVal = 3}+@++Step-by-step state machine evaluation:++@+example3 = mapM_ print $ next sm \"ushers\" where+ sm = makeSimpleStateMachine [\"he\",\"she\",\"his\",\"hers\"]+ next _ [] = []+ next sm (s:n) = let (SMStepRes match nextSM) = stateMachineStep sm s in+ (s, match) : next nextSM n+@++@+('u',[])+('s',[])+('h',[])+('e',[(3,\"she\"),(2,\"he\")])+('r',[])+('s',[(4,\"hers\")])+@+-}+module Text.AhoCorasick (+ makeStateMachine+ , makeSimpleStateMachine+ , findAll+ , Position(..)+ , stateMachineStep+ , KeyLength+ , SMStepRes(..)+ , resetStateMachine+ ) where++import Control.Monad.State.Lazy (execStateT, get, put)+import Control.Monad.ST.Strict (ST, runST)+import Control.Monad.Trans (lift)+import Data.Array.IArray (Array, array, (!))+import Data.Hashable (Hashable)+import Data.Maybe (fromJust)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef, modifySTRef)+import qualified Data.HashMap.Strict as M++import Text.AhoCorasick.Internal.Deque (mkDQ, pushBack, popFront, dqLength, DQ)++data (Eq keySymb, Hashable keySymb) => TNode keySymb s = + TNode {+ tnId :: Int+ , tnLinks :: M.HashMap keySymb (STRef s (TNode keySymb s))+ , tnFail :: Maybe (STRef s (TNode keySymb s))+ , tnValuesIds :: [Int]+ }++type KeyLength = Int++data (Eq keySymb, Hashable keySymb) => TTree keySymb val s = + TTree {+ ttRoot :: STRef s (TNode keySymb s)+ , ttLastId :: STRef s Int+ , ttValues :: DQ (KeyLength, val) s+ }++type NodeIndex = Int++data (Eq keySymb, Hashable keySymb) => SMElem keySymb = + SMElem {+ smeLinks :: M.HashMap keySymb NodeIndex+ , smeFail :: NodeIndex+ , smeValuesIds :: [Int]+ }+ +data (Eq keySymb, Hashable keySymb) => StateMachine keySymb val = + StateMachine {+ smStates :: Array NodeIndex (SMElem keySymb)+ , smValues :: Array Int (KeyLength, val)+ , smState :: Int+ }++data (Eq keySymb, Hashable keySymb) => SMStepRes keySymb val = + SMStepRes {+ smsrMatch :: [(KeyLength, val)]+ , smsrNextSM :: StateMachine keySymb val+ }++data Position val =+ Position {+ pIndex :: Int+ , pLength :: Int+ , pVal :: val+ }++instance (Eq keySymb, Hashable keySymb, Show keySymb) => + Show (SMElem keySymb) where+ show (SMElem l f v) = concat ["SMElem {smeLinks = ", show l,+ ", smeFail = ", show f,", smeValuesIds = ", show v, "}"]++instance (Eq keySymb, Hashable keySymb, Show keySymb, Show val) => + Show (StateMachine keySymb val) where+ show (StateMachine st vals state) = concat [+ "StateMachine {smStates = ", show st,+ ", smValues = ", show vals, ", smState = ", show state,"}"]++instance (Eq keySymb, Hashable keySymb, Show keySymb, Show val) => + Show (SMStepRes keySymb val) where+ show (SMStepRes f n) = concat [+ "StateMachineStepRes {smsrFound = ", show f,+ ", smsrNewSM = ", show n,"}"]++instance (Show val) => Show (Position val) where+ show (Position i l v) = concat [+ "Position {pIndex = ", show i,+ ", pLength = ", show l,+ ", pVal = ", show v,"}"]++x ~> f = f x+infixl 9 ~>++rootNodeId :: Int+rootNodeId = 0++initNewTTree :: (Eq keySymb, Hashable keySymb) => ST s (TTree keySymb a s)+initNewTTree = do+ root <- newSTRef $ TNode rootNodeId M.empty Nothing []+ lid <- newSTRef rootNodeId+ kw <- mkDQ+ return $ TTree root lid kw+ +mkNewTNode :: (Eq keySymb, Hashable keySymb) => + TTree keySymb a s -> ST s (TNode keySymb s)+mkNewTNode tree = do+ modifySTRef lid (+1)+ lv <- readSTRef lid+ return $ TNode lv M.empty Nothing []+ where+ lid = ttLastId tree++addKeyVal :: forall val s keySymb. (Eq keySymb, Hashable keySymb) => + TTree keySymb val s -> [keySymb] -> val -> ST s ()+addKeyVal tree key val = addSymb (ttRoot tree) key+ where+ addSymb :: STRef s (TNode keySymb s) -> [keySymb] -> ST s ()+ addSymb node [] = do+ vi <- dqLength (ttValues tree)+ pushBack (ttValues tree) (length key, val)+ modifySTRef node (\r -> r { tnValuesIds = [vi] })+ addSymb node (c:nc) = do+ n <- readSTRef node+ let nlnks = tnLinks n+ case M.lookup c nlnks of+ Just tn -> addSymb tn nc+ Nothing -> do+ nnd <- mkNewTNode tree+ refNewN <- newSTRef nnd+ writeSTRef node (n {tnLinks = M.insert c refNewN nlnks})+ addSymb refNewN nc++findFailures :: (Eq keySymb, Hashable keySymb) => TTree keySymb val s -> ST s ()+findFailures tree = do+ modifySTRef root (\n -> n {tnFail = Just root})+ dq <- mkDQ+ pushBack dq root+ procAll dq+ where+ root = ttRoot tree+ procAll dq = do+ n <- popFront dq+ case n of+ Nothing -> return ()+ Just node -> do+ procNode dq node+ procAll dq+ procNode dq nodeRef = do+ node <- readSTRef nodeRef+ mapM_ (\(symb, link) -> do+ pushBack dq link+ fRef <- findParentFail link (tnFail node) symb+ f <- readSTRef fRef+ modifySTRef link (\n -> n {tnFail = Just fRef, + tnValuesIds = (tnValuesIds n) ++ (tnValuesIds f)})+ ) $ tnLinks node ~> M.toList+ return ()+ findParentFail link (Just cfRef) symb = do+ cf <- readSTRef cfRef+ case (M.lookup symb (tnLinks cf), cfRef == root) of+ (Just nl, _) -> if nl == link+ then return root+ else return nl+ (Nothing, True) -> return root+ _ -> findParentFail link (tnFail cf) symb++convertToStateMachine :: forall val s keySymb. (Eq keySymb, Hashable keySymb) => + TTree keySymb val s -> + ST s (StateMachine keySymb val)+convertToStateMachine tree = do+ size <- readSTRef $ ttLastId tree+ nds <- execStateT (convertNode $ ttRoot tree) []+ + vlsSize <- dqLength $ ttValues tree+ vls <- mapM (\i -> do+ k <- popFront (ttValues tree)+ return (i,fromJust k)+ ) [0..(vlsSize-1)]+ + StateMachine (array (0, size) nds) (array (0, vlsSize-1) vls) rootNodeId+ ~> return+ where+ convertNode node = do+ (n,l,fail) <- lift $ do+ n <- readSTRef node+ l <- tnLinks n ~> convertLinks+ fail <- tnFail n ~> fromJust ~> readSTRef >>= return . tnId+ return (n,l,fail)+ v <- get+ put $ (tnId n, SMElem l fail (tnValuesIds n)) : v+ M.toList (tnLinks n) ~> map snd ~> mapM_ convertNode++ convertLinks :: M.HashMap keySymb (STRef s (TNode keySymb s)) ->+ ST s (M.HashMap keySymb Int)+ convertLinks lnksMap = do+ nl <- mapM (\(symb, link) -> do+ l <- readSTRef link+ return $ (symb, tnId l)+ ) $ M.toList lnksMap+ return $ M.fromList nl++resetStateMachine :: (Eq keySymb, Hashable keySymb) => + StateMachine keySymb val -> StateMachine keySymb val+resetStateMachine m = m { smState = rootNodeId }++stateMachineStep :: (Eq keySymb, Hashable keySymb) => + StateMachine keySymb val -> keySymb -> SMStepRes keySymb val+stateMachineStep sm symb =+ case (M.lookup symb links, currentState == rootNodeId) of+ (Just nextState, _) -> SMStepRes+ ((smStates sm) ! nextState ~> smeValuesIds ~> convertToVals)+ (sm { smState = nextState })+ (Nothing, True) -> SMStepRes [] sm+ (Nothing, False) -> stateMachineStep + (sm { smState = smeFail currentNode}) symb + where+ currentState = smState sm+ currentNode = (smStates sm) ! currentState+ links = smeLinks currentNode+ convertToVals idx = map (\i -> smValues sm ! i) idx++findAll :: (Eq keySymb, Hashable keySymb) => + StateMachine keySymb val -> [keySymb] -> [Position val]+findAll sm str = + step (resetStateMachine sm) (zip [0..] str) ~> concat+ where+ step _ [] = []+ step csm ((idx,symb):next) = case stateMachineStep csm symb of+ SMStepRes [] newsm -> step newsm next+ SMStepRes r newsm -> (map (cnvToPos idx) r) : (step newsm next) + cnvToPos idx (keyLength, val) = Position (idx - keyLength + 1) keyLength val++makeSimpleStateMachine :: (Eq keySymb, Hashable keySymb) => + [[keySymb]] -> StateMachine keySymb [keySymb]+makeSimpleStateMachine keys = runST $ do+ tree <- initNewTTree+ mapM_ (\s -> addKeyVal tree s s) keys+ findFailures tree+ convertToStateMachine tree++makeStateMachine :: (Eq keySymb, Hashable keySymb) => + [([keySymb], val)] -> StateMachine keySymb val+makeStateMachine kv = runST $ do+ tree <- initNewTTree+ mapM_ (\(s,v) -> addKeyVal tree s v) kv+ findFailures tree+ convertToStateMachine tree
+ Text/AhoCorasick/Internal/Deque.hs view
@@ -0,0 +1,54 @@+module Text.AhoCorasick.Internal.Deque (+ mkDQ+ , pushBack+ , popFront+ , dqLength+ , DQ+ ) where++import Control.Monad.ST.Strict+import Data.STRef++data DQNode a s = DQNode {+ dqnData :: a+ , dqnNext :: Maybe (STRef s (DQNode a s))+ }++type DQ a s = STRef s (+ Maybe (+ STRef s (DQNode a s), + STRef s (DQNode a s)+ ),+ Int)++mkDQ :: ST s (DQ a s)+mkDQ = newSTRef (Nothing, 0)++pushBack :: DQ a s -> a -> ST s ()+pushBack dq dt = do+ dqr <- readSTRef dq+ case dqr of+ (Nothing,_) -> do+ nn <- newSTRef $ DQNode dt Nothing+ writeSTRef dq (Just (nn, nn), 1)+ (Just (f,l),lng) -> do+ nn <- newSTRef $ DQNode dt Nothing+ modifySTRef l (\v -> v {dqnNext = Just nn})+ writeSTRef dq $ (Just (f,nn),lng + 1)++popFront :: DQ a s -> ST s (Maybe a)+popFront dq = do+ dqr <- readSTRef dq+ case dqr of+ (Nothing,_) -> return Nothing+ (Just (f,l),lng) -> do+ fd <- readSTRef f+ case dqnNext fd of+ Nothing -> writeSTRef dq (Nothing, 0)+ Just k -> writeSTRef dq $ (Just (k,l),lng-1)+ return $ Just $ dqnData fd++dqLength :: DQ a s -> ST s Int+dqLength dq = do+ (_,l) <- readSTRef dq+ return l