module Data.SubwordGraph (
Vertex
, Edge
, LabeledEdge
, RootedEdge
, EdgeType (Solid, Soft)
, Node
, SGraph
, construct
, constructReversed
, elem
, subwords
, subwordsNum
, findNode
, toWord
, foldl
, foldlToNode
, foldr
, foldrFromNode
, topsort
, insert
, rootId
, sinkId
, nodeId
, sufId
, edges
, nodesNum
, edgesNum
, lookupNode
, findEdge
, getRootNode
, getSufNode
, getSinkNode
) where
import Prelude hiding (elem, fold, foldl, foldr, reverse)
import qualified Prelude as P
import Data.Maybe (isJust, fromMaybe)
import qualified Data.List as DList
import qualified Data.Map as DMap
import qualified Data.IntMap as DIMap
import Control.Monad.State
type Vertex = Int
type Edge = (Vertex, EdgeType)
type LabeledEdge a = (a, Edge)
type RootedEdge a = (Vertex, a, Edge)
data EdgeType = Solid | Soft deriving (Eq, Show)
data SGraph a = SGraph {
rootId :: Vertex,
sinkId :: Vertex,
nodes :: DIMap.IntMap (Node a)
} deriving (Eq, Show)
data Node a = Node {
nodeId :: Vertex,
sufId :: Maybe Vertex,
edges :: DMap.Map a Edge
} deriving (Eq, Show)
rootIx :: Int
rootIx = 0
defaultNode :: Node a
defaultNode = Node {
nodeId = rootIx,
sufId = Nothing,
edges = DMap.empty
}
emptyGraph :: SGraph a
emptyGraph = SGraph {
rootId = rootIx,
sinkId = rootIx,
nodes = DIMap.fromList [ (rootIx, defaultNode :: Node a) ]
}
construct :: Ord a => [a] -> SGraph a
construct = P.foldl (flip insert) emptyGraph
constructReversed :: Ord a => [a] -> SGraph a
constructReversed = construct . DList.reverse
elem :: Ord a => [a] -> SGraph a -> Bool
elem word graph = isJust $ findNode word graph
subwords :: SGraph a -> [[a]]
subwords = foldr (\(c, _) s1 s2 -> s1 ++ [[c]] ++ map (c:) s2) []
subwordsNum :: SGraph a -> Int
subwordsNum = foldr (\_ s1 s2 -> 1 + s1 + s2) 0
findNodeInternal :: Ord a => [a] -> SGraph a -> Node a -> Maybe (Node a)
findNodeInternal [] _ node = Just node
findNodeInternal (a:ws) graph node
| not (isEdge node a) = Nothing
| otherwise = findNodeInternal ws graph node' where
(vertex, _) = getEdge node a
node' = getNode vertex graph
findNode :: Ord a => [a] -> SGraph a -> Maybe (Node a)
findNode word graph = findNodeInternal word graph (getRootNode graph)
toWord :: Ord a => SGraph a -> [a]
toWord g = P.reverse $ head $ toWordWithStack g (rootId g) []
toWordWithStack :: Ord a => SGraph a -> Vertex -> [a] -> [[a]]
toWordWithStack g nId visited
| nId == sinkId g = [visited]
| otherwise = P.foldl f [] (getNodeSolidEdges (getNode nId g))
where
f acc (letter, (vertex, _)) = acc ++ toWordWithStack g vertex (letter:visited)
foldr :: (LabeledEdge a -> b -> b -> b) -> b -> SGraph a -> b
foldr f acc g = fst $ foldrFromNode f acc g (getRootNode g)
foldrFromNode :: (LabeledEdge a -> b -> b -> b) -> b -> SGraph a -> Node a -> (b, DIMap.IntMap b)
foldrFromNode f acc g n = runState (postorderNode f acc g n) DIMap.empty
postorderNode :: (LabeledEdge a -> b -> b -> b) -> b -> SGraph a -> Node a -> State (DIMap.IntMap b) b
postorderNode f acc g n = foldM (postorderGo f g acc) acc $ DMap.toList (edges n)
postorderGo :: (LabeledEdge a -> b -> b -> b) -> SGraph a -> b -> b -> LabeledEdge a -> State (DIMap.IntMap b) b
postorderGo f g initacc acc e = do
let (_, (dst, ety)) = e
st <- get
case DIMap.lookup dst st of
Nothing -> do
val <- postorderNode f initacc g (getNode dst g)
st <- get
put $ DIMap.insert dst val st
return (f e acc val)
Just val -> return (f e acc val)
foldl :: (b -> b -> RootedEdge a -> b) -> b -> SGraph a -> b
foldl f acc g = fst $ foldlToNode f acc g (getSinkNode g)
foldlToNode :: (b -> b -> RootedEdge a -> b) -> b -> SGraph a -> Node a -> (b, DIMap.IntMap b)
foldlToNode f acc g n = runState (toporderNode f acc g n (topsort g)) DIMap.empty
toporderNode :: (b -> b -> RootedEdge a -> b) -> b -> SGraph a -> Node a -> [Node a] -> State (DIMap.IntMap b) b
toporderNode _ _ _ _ [] = error "toporderNode: invalid end node"
toporderNode f acc g nto (h:t) =
if nodeId h == nodeId nto
then getNodeState (nodeId nto) acc
else do
let currId = nodeId h
forM_ (DMap.toList (edges h)) $ \e -> do
let (c, (dst, ety)) = e
st <- get
v1 <- getNodeState currId acc
v2 <- getNodeState dst acc
put $ DIMap.insert dst (f v1 v2 (currId, c, (dst, ety))) st
toporderNode f acc g nto t
getNodeState :: Vertex -> b -> State (DIMap.IntMap b) b
getNodeState idx def = do
st <- get
case DIMap.lookup idx st of
Nothing -> return def
Just val -> return val
topsort :: SGraph a -> [Node a]
topsort g = DList.reverse $ toporder g [getRootNode g] [] (countInDegrees g)
toporder :: SGraph a -> [Node a] -> [Node a] -> DIMap.IntMap Int -> [Node a]
toporder _ [] acc _ = acc
toporder g (h:t) acc m = toporder g t' (h:acc) m' where
(m', t') = P.foldl f (m, t) (edges h)
f (m1, t1) (dst, _) = (m2, t2) where
dg = fromMaybe 0 (DIMap.lookup dst m1)
t2 = if dg == 1 then getNode dst g : t1 else t1
m2 = DIMap.insert dst (dg 1) m1
countInDegrees :: SGraph a -> DIMap.IntMap Int
countInDegrees g = P.foldl f initmap nds where
nds = map snd $ DIMap.toList (nodes g)
initmap = DIMap.fromList [ (nodeId a, 0) | a <- nds]
f acc nd = P.foldl (\a (dst, _) -> DIMap.adjust (1+) dst a) acc (edges nd)
insert :: Ord a => a -> SGraph a -> SGraph a
insert c g = splitByNode fixedG c fixedW where
(newSinkG, sinkNum) = addNewNode g
edgeToSink = (sinkNum, Solid)
oldSinkNum = sinkId g
newSinkEdgeG = (setEdge oldSinkNum c edgeToSink newSinkG) { sinkId = sinkNum }
w = getSufNode (getNode oldSinkNum newSinkEdgeG) newSinkEdgeG
(fixedG, fixedW) = fixSufBindings isEdge sinkNum Soft w c newSinkEdgeG
fixSufBindings
:: Ord a => (Node a -> a -> Bool)
-> Vertex
-> EdgeType
-> Maybe (Node a)
-> a
-> SGraph a
-> (SGraph a, Maybe (Node a))
fixSufBindings _ _ _ Nothing _ g = (g, Nothing)
fixSufBindings edgePred redirectTo edgeType (Just w) c g
| edgePred w c = (g, Just w)
| otherwise = fixSufBindings edgePred redirectTo edgeType w' c g' where
g' = setEdge (nodeId w) c (redirectTo, edgeType) g
w' = getSufNode w g'
splitByNode :: Ord a => SGraph a -> a -> Maybe (Node a) -> SGraph a
splitByNode g _ Nothing = changeSinkSuf g (rootId g)
splitByNode g c (Just w) =
case getEdge w c of
(v, Solid) -> changeSinkSuf g v
(v, Soft) -> g7 where
(g1, v') = addNewNode g
g2 = P.foldl redirectEdge g1 $ DMap.toList (edges (getNode v g1))
redirectEdge :: Ord a => SGraph a -> (a, Edge) -> SGraph a
redirectEdge g (c, (u, _)) = setEdge v' c (u, Soft) g
g3 = setEdge (nodeId w) c (v', Solid) g2
g4 = changeSinkSuf g3 v'
g5 = changeSufNode g4 v' (getSufNode (getNode v g4) g4)
g6 = changeSuf g5 v (Just v')
sufW = getSufNode w g6
(g7, _) = fixSufBindings isNodeEdgeSolid v' Soft sufW c g6
changeSinkSuf :: SGraph a -> Vertex -> SGraph a
changeSinkSuf g suf = changeSuf g (sinkId g) (Just suf)
changeSuf :: SGraph a -> Vertex -> Maybe Vertex -> SGraph a
changeSuf g v Nothing = changeSufNode g v Nothing
changeSuf g v (Just suf) = changeSufNode g v $ Just (getNode suf g)
changeSufNode :: SGraph a -> Vertex -> Maybe (Node a) -> SGraph a
changeSufNode g v sufNode = updateNode v vNodeNewSuf g where
vnode = getNode v g
vNodeNewSuf =
vnode { sufId = sufNode >>= return . nodeId }
addNode :: Node a -> SGraph a -> SGraph a
addNode n g = g { nodes = DIMap.insert k n (nodes g) } where
k = nodeId n
addNewNode :: SGraph a -> (SGraph a, Int)
addNewNode g = (addNode n g, k) where
n = defaultNode { nodeId = k }
k = nodesNum g
setEdge :: Ord a => Int -> a -> Edge -> SGraph a -> SGraph a
setEdge ix c e g = g { nodes = DIMap.insert ix n' (nodes g) } where
n = getNode ix g
n' = n { edges = DMap.insert c e (edges n) }
updateNode :: Int -> Node a -> SGraph a -> SGraph a
updateNode ix n g = g { nodes = DIMap.insert ix n (nodes g) }
nodesNum :: SGraph a -> Int
nodesNum = DIMap.size . nodes
edgesNum :: SGraph a -> Int
edgesNum = P.foldr ((+) . DMap.size . edges) 0 . nodes
getNode :: Int -> SGraph a -> Node a
getNode ix g = fromMaybe (error $ "there is no node with id: " ++ show ix) (lookupNode ix g)
lookupNode :: Int -> SGraph a -> Maybe (Node a)
lookupNode ix g = DIMap.lookup ix (nodes g)
getRootNode :: SGraph a -> Node a
getRootNode g = getNode (rootId g) g
getSufNode :: Node a -> SGraph a -> Maybe (Node a)
getSufNode n g = do
sid <- sufId n
return $ getNode sid g
getSinkNode :: SGraph a -> Node a
getSinkNode g = getNode (sinkId g) g
findEdge :: Ord a => Node a -> a -> Maybe Edge
findEdge n c = DMap.lookup c (edges n)
getEdge :: Ord a => Node a -> a -> Edge
getEdge n c = fromMaybe (error $ "there is no given egde from node with id: " ++ show (nodeId n) ) (findEdge n c)
getNodeSolidEdges :: Ord a => Node a -> [(a, Edge)]
getNodeSolidEdges n = P.filter (\(_, edge) -> isEdgeSolid edge) (DMap.toList (edges n))
isEdge :: Ord a => Node a -> a -> Bool
isEdge n c = isJust $ findEdge n c
isEdgeSolid :: Edge -> Bool
isEdgeSolid (_, et) = et == Solid
isNodeEdgeSolid :: Ord a => Node a -> a -> Bool
isNodeEdgeSolid n c = isEdgeSolid $ getEdge n c