{-# LANGUAGE RecordWildCards #-}
module Data.DAWG.Int.Dynamic
(
DAWG (root)
, lookup
, numStates
, numEdges
, value
, edges
, follow
, empty
, fromList
, fromListWith
, fromLang
, insert
, insertWith
, delete
, assocs
, keys
, elems
) where
import Prelude hiding (lookup)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (first)
import Data.List (foldl')
import qualified Control.Monad.State.Strict as S
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Data.DAWG.Gen.Types
import Data.DAWG.Gen.Graph (Graph)
import qualified Data.DAWG.Gen.Trans as T
import qualified Data.DAWG.Gen.Graph as G
import Data.DAWG.Int.Dynamic.Internal
import qualified Data.DAWG.Int.Dynamic.Node as N
type GraphM = S.State (Graph N.Node)
mkState :: (Graph a -> Graph a) -> Graph a -> ((), Graph a)
mkState f g = ((), f g)
nodeBy :: ID -> GraphM N.Node
nodeBy i = G.nodeBy i <$> S.get
insertNode :: N.Node -> GraphM ID
insertNode = S.state . G.insert
insertLeaf :: GraphM ID
insertLeaf = insertNode $ N.Node Nothing T.empty
deleteNode :: N.Node -> GraphM ()
deleteNode = S.state . mkState . G.delete
insertM :: [Sym] -> Val -> ID -> GraphM ID
insertM (x:xs) y i = do
n <- nodeBy i
j <- case N.onSym x n of
Just j -> return j
Nothing -> insertLeaf
k <- insertM xs y j
deleteNode n
insertNode (N.insert x k n)
insertM [] y i = do
n <- nodeBy i
deleteNode n
insertNode (n { N.value = Just y })
insertWithM
:: (Val -> Val -> Val)
-> [Sym] -> Val -> ID -> GraphM ID
insertWithM f (x:xs) y i = do
n <- nodeBy i
j <- case N.onSym x n of
Just j -> return j
Nothing -> insertLeaf
k <- insertWithM f xs y j
deleteNode n
insertNode (N.insert x k n)
insertWithM f [] y i = do
n <- nodeBy i
deleteNode n
let y'new = case N.value n of
Just y' -> f y y'
Nothing -> y
insertNode (n { N.value = Just y'new })
deleteM :: [Sym] -> ID -> GraphM ID
deleteM (x:xs) i = do
n <- nodeBy i
case N.onSym x n of
Nothing -> return i
Just j -> do
k <- deleteM xs j
deleteNode n
insertNode (N.insert x k n)
deleteM [] i = do
n <- nodeBy i
deleteNode n
insertNode (n { N.value = Nothing })
followPath :: [Sym] -> ID -> MaybeT GraphM ID
followPath (x:xs) i = do
n <- lift $ nodeBy i
j <- liftMaybe $ N.onSym x n
followPath xs j
followPath [] i = return i
lookupM :: [Sym] -> ID -> GraphM (Maybe Val)
lookupM xs i = runMaybeT $ do
j <- followPath xs i
MaybeT $ N.value <$> nodeBy j
subPairs :: Graph N.Node -> ID -> [([Sym], Val)]
subPairs g i =
here n ++ concatMap there (N.edges n)
where
n = G.nodeBy i g
here v = case N.value v of
Just x -> [([], x)]
Nothing -> []
there (sym, j) = map (first (sym:)) (subPairs g j)
empty :: DAWG
empty =
let (i, g) = S.runState insertLeaf G.empty
in DAWG g i
numStates :: DAWG -> Int
numStates = G.size . graph
numEdges :: DAWG -> Int
numEdges = sum . map (length . N.edges) . G.nodes . graph
insert :: [Sym] -> Val -> DAWG -> DAWG
insert xs y d =
let (i, g) = S.runState (insertM xs y $ root d) (graph d)
in DAWG g i
{-# INLINE insert #-}
insertWith
:: (Val -> Val -> Val)
-> [Sym] -> Val -> DAWG -> DAWG
insertWith f xs y d =
let (i, g) = S.runState (insertWithM f xs y $ root d) (graph d)
in DAWG g i
delete :: [Sym] -> DAWG -> DAWG
delete xs d =
let (i, g) = S.runState (deleteM xs $ root d) (graph d)
in DAWG g i
lookup :: [Sym] -> DAWG -> Maybe Val
lookup xs d = S.evalState (lookupM xs $ root d) (graph d)
assocs :: DAWG -> [([Sym], Val)]
assocs = subPairs <$> graph <*> root
keys :: DAWG -> [[Sym]]
keys = map fst . assocs
elems :: DAWG -> [Val]
elems = map snd . (subPairs <$> graph <*> root)
fromList :: [([Sym], Val)] -> DAWG
fromList xs =
let update t (x, v) = insert x v t
in foldl' update empty xs
fromListWith :: (Val -> Val -> Val) -> [([Sym], Val)] -> DAWG
fromListWith f xs =
let update t (x, v) = insertWith f x v t
in foldl' update empty xs
fromLang :: [[Sym]] -> DAWG
fromLang xs = fromList [(x, 0) | x <- xs]
edges :: ID -> DAWG -> [(Sym, ID)]
edges i
= map (first toEnum)
. N.edges . G.nodeBy i
. graph
value :: ID -> DAWG -> Maybe Val
value i = N.value . G.nodeBy i . graph
follow :: ID -> Sym -> DAWG -> Maybe ID
follow i x DAWG{..} = flip S.evalState graph $ runMaybeT $
followPath [x] i
liftMaybe :: Monad m => Maybe a -> MaybeT m a
liftMaybe = MaybeT . return
{-# INLINE liftMaybe #-}