ac-machine 0.2.0.2 → 0.2.0.4
raw patch · 2 files changed
+57/−65 lines, 2 files
Files
- Data/AhoCorasick.hs +51/−62
- ac-machine.cabal +6/−3
Data/AhoCorasick.hs view
@@ -20,6 +20,7 @@ import Data.Maybe import Data.Vector (Vector) import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV import GHC.Generics (Generic) @@ -30,8 +31,6 @@ type Output v = Vector [(Int, v)] type GotoMap a = HashMap State (HashMap a State)-type FailureMap = HashMap State State-type OutputMap v = HashMap State [(Int, v)] newtype State = State Int deriving (Eq, Generic)@@ -43,32 +42,21 @@ } deriving (Show) construct :: (Eq a, Hashable a) => [[a]] -> ACMachine a [a]-construct ps = ACMachine (toGotoArray n gotoMap) (toFailureArray n failureMap) (toOutputArray n outputMap)- where- (m, gotoMap) = buildGoto ps- n = m + 1- failureMap = buildFailure gotoMap- outputMap = buildOutput pvs gotoMap failureMap- pvs = zip ps ps+construct ps = constructWithValues $ zip ps ps constructWithValues :: (Eq a, Hashable a) => [([a], v)] -> ACMachine a v-constructWithValues pvs = ACMachine (toGotoArray n gotoMap) (toFailureArray n failureMap) (toOutputArray n outputMap)+constructWithValues pvs = ACMachine g f o where (m, gotoMap) = buildGoto ps n = m + 1- failureMap = buildFailure gotoMap- outputMap = buildOutput pvs gotoMap failureMap+ g = toGotoArray n gotoMap+ f = buildFailure g+ o = buildOutput pvs g f ps = map fst pvs toGotoArray :: Int -> GotoMap a -> Goto a toGotoArray n m = V.generate n (fromMaybe Map.empty . flip Map.lookup m . State) -toFailureArray :: Int -> FailureMap -> Failure-toFailureArray n m = V.generate n (fromMaybe (error "failure: ") . flip Map.lookup m . State)--toOutputArray :: Int -> OutputMap v -> Output v-toOutputArray n m = V.generate n (fromMaybe [] . flip Map.lookup m . State)- root :: State root = State 0 @@ -85,25 +73,33 @@ step (ACMachine g f o) x s = (s', output s') where s' = head $ mapMaybe (flip goto x) $ iterate failure s- goto (State 0) x' = (Map.lookup x' $ g V.! 0) <|> Just root- goto (State i) x' = Map.lookup x' $ g V.! i+ goto (State 0) x' = Map.lookup x' (g V.! 0) <|> Just root+ goto (State i) x' = Map.lookup x' (g V.! i) failure (State i) = f V.! i output (State i) = o V.! i -buildOutput :: (Eq a, Hashable a) => [([a], v)] -> GotoMap a -> FailureMap -> OutputMap v-buildOutput pvs gotoMap failureMap = foldl' build o0 $ tail $ toBFList gotoMap+buildOutput :: (Eq a, Hashable a) => [([a], v)] -> Goto a -> Failure -> Output v+buildOutput pvs g f = V.create $ do+ o <- MV.replicate (V.length g) []+ forM_ (map (fromJust . toKV) pvs) $ \(State i, vs) ->+ MV.write o i vs+ forM_ (tail $ toBFList g) $ \(State i) -> do+ let ts = Map.toList (g V.! i)+ forM_ ts $ \(_, s'@(State j)) -> do+ let (State k) = failure s'+ vs <- MV.read o j+ vsf <- MV.read o k+ let vs' = vsf `seq` vs ++ vsf+ MV.write o j vs'+ return o where- build o s = foldl' (\a (_, s') -> let vs = lookupDefault [] (failure s') a in vs `seq` Map.insertWith (flip (++)) s' vs a) o ts- where- ts = Map.toList $ lookupDefault Map.empty s gotoMap- failure = fromMaybe (error "failure: ") . flip Map.lookup failureMap- o0 = Map.fromList $ map (fromJust . toKV) pvs+ failure (State i) = f V.! i toKV (p, v) = do- s <- finalState gotoMap root p+ s <- finalState g root p return (s, [(length p, v)]) -finalState :: (Eq a, Hashable a) => GotoMap a -> State -> [a] -> Maybe State-finalState m = foldM (\s x -> Map.lookup s m >>= Map.lookup x)+finalState :: (Eq a, Hashable a) => Goto a -> State -> [a] -> Maybe State+finalState g = foldM (\(State i) x -> Map.lookup x (g V.! i)) buildGoto :: (Eq a, Hashable a) => [[a]] -> (Int, GotoMap a) buildGoto = foldl' (flip extend) (0, Map.empty)@@ -123,53 +119,46 @@ where sm = fromMaybe Map.empty $ Map.lookup s m -buildFailure :: (Eq a, Hashable a) => GotoMap a -> FailureMap-buildFailure m = foldl' build Map.empty $ toBFList m+buildFailure :: (Eq a, Hashable a) => Goto a -> Failure+buildFailure g = V.create $ do+ f <- MV.new (V.length g)+ MV.write f 0 (error "Referencing the failure transition from the root node.")+ forM_ (toBFList g) $ \s@(State i) -> do+ let ts = Map.toList (g V.! i)+ forM_ ts $ \(x, State j) -> do+ s' <- failureState f s x+ MV.write f j s'+ return f where- build f s = foldl' (\a (x, s') -> Map.insert s' (failureState f s x) a) f ts- where- ts = Map.toList $ lookupDefault Map.empty s m- failureState _ (State 0) _ = root- failureState f s x = head $ mapMaybe (flip goto x) $ iterate failure (failure s)+ failureState _ (State 0) _ = return root+ failureState f s x = go =<< failure s where- failure = fromMaybe (error "failure: ") . flip Map.lookup f- goto (State 0) x = (Map.lookup root m >>= Map.lookup x) <|> Just root- goto s x = Map.lookup s m >>= Map.lookup x--toBFList :: GotoMap a -> [State]-toBFList m = ss0- where- ss0 = root : go 1 ss0- go 0 _ = []- go n (s:ss) = case Map.lookup s m of- Nothing -> go (n - 1) ss- Just sm -> children ++ go (n - 1 + Map.size sm) ss- where- children = Map.elems sm- go _ _ = error "toBFList: invalid state"+ go s' = case goto s' x of+ Nothing -> go =<< failure s'+ Just s'' -> return s''+ failure (State i) = MV.read f i+ goto (State 0) x = Map.lookup x (g V.! 0) <|> Just root+ goto (State i) x = Map.lookup x (g V.! i) -toBFList' :: Goto a -> [State]-toBFList' v = ss0+toBFList :: Goto a -> [State]+toBFList g = ss0 where ss0 = root : go 1 ss0 go 0 _ = []- go n ((State i):ss) = children ++ go (n - 1 + Map.size sm) ss+ go n (State i : ss) = children ++ go (n - 1 + Map.size sm) ss where- sm = v V.! i+ sm = g V.! i children = Map.elems sm go _ _ = error "toBFList: invalid state" -lookupDefault :: (Eq k, Hashable k) => v -> k -> HashMap k v -> v-lookupDefault def k m = fromMaybe def $ Map.lookup k m- renderGraph :: ACMachine Char [Char] -> String renderGraph (ACMachine g f o) = graph "digraph" $ statements [ attr "graph" [("rankdir", "LR")]- , statements $ map state (toBFList' g)+ , statements $ map state (toBFList g) , statements $ map stateWithOutput $ filter (not . null . snd) $ zip (map State [0..]) (V.toList o)- , statements $ map (\s@(State i) -> statements $ map (uncurry $ transEdge s) $ Map.toList $ g V.! i) (toBFList' g)- , statements $ map (\s@(State i) -> failEdge s $ f V.! i) (tail $ toBFList' g)+ , statements $ map (\s@(State i) -> statements $ map (uncurry $ transEdge s) $ Map.toList $ g V.! i) (toBFList g)+ , statements $ map (\s@(State i) -> failEdge s $ f V.! i) (tail $ toBFList g) ] where statements = intercalate " "
ac-machine.cabal view
@@ -1,5 +1,5 @@ name: ac-machine-version: 0.2.0.2+version: 0.2.0.4 synopsis: Aho-Corasick string matching algorithm in Haskell description: An implementation of the Aho-Corasick string matching algorithm written in Haskell. license: BSD3@@ -13,9 +13,12 @@ library exposed-modules: Data.AhoCorasick- other-extensions: DeriveGeneric- build-depends: base >=4.6 && <4.7, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.11+ build-depends: base >=4.6 && <4.7+ , hashable >=1.2 && <1.3+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.11 default-language: Haskell2010+ ghc-options: -Wall source-repository head type: git