module Data.FsmActions.Graph (
SelfLoops(..),
fsmToFGL,
fglDot,
strongCCs,
weakCCs,
fsmToDot,
fglToFsm
) where
import Data.Graph.Inductive.Basic (undir)
import Data.Graph.Inductive.Graph (Graph, labEdges, labNodes, Node,
LNode, mkGraph)
import qualified Data.Graph.Inductive.PatriciaTree as P
import qualified Data.Graph.Inductive.Tree as T
import Data.Graph.Inductive.Query.DFS (scc)
import Data.GraphViz
import Data.List (nub, sort)
import qualified Data.Map as M
import Data.Map.Utils (forceLookupM)
import Data.FsmActions hiding (mkAction)
import Data.FsmActions.Error
import Data.FsmActions.WellFormed (polishFSM)
data SelfLoops =
Keep
| Trim
fsmToFGL :: FSM sy -> SelfLoops -> T.Gr () sy
fsmToFGL = fsmToFGL'
fsmToFGL' :: (Graph gr) => FSM sy -> SelfLoops -> gr () sy
fsmToFGL' fsm selfs = mkGraph nodes edges
where nodes = map (\state -> (state, ())) $ states fsm
edges = fsmEdges selfs fsm
fsmEdges :: SelfLoops -> FSM sy -> [(State, State, sy)]
fsmEdges selfs = concat . fsmMap (symbolEdges selfs)
symbolEdges :: SelfLoops -> sy -> Action -> [(State, State, sy)]
symbolEdges selfs s =
concatMap (syStateEdges selfs s) . zipWithIndex . destinationSets
syStateEdges :: SelfLoops -> sy -> (State, DestinationSet) ->
[(State, State, sy)]
syStateEdges Keep s (src, dSet) = syStateEdges' s (src, dSet)
syStateEdges Trim s (src, dSet) =
if destinations dSet == [src] then [] else syStateEdges' s (src, dSet)
syStateEdges' :: sy -> (State, DestinationSet) -> [(State, State, sy)]
syStateEdges' s (src, dSet) = map (\x -> (src, x, s)) $ destinations dSet
zipWithIndex :: [a] -> [(Int, a)]
zipWithIndex xs = zip [0..(length xs1)] xs
strongCCs :: Eq sy => FSM sy -> [[State]]
strongCCs = scc . fsmToPatriciaTree Trim
weakCCs :: Eq sy => FSM sy -> [[State]]
weakCCs = scc . undir . fsmToPatriciaTree Trim
fsmToPatriciaTree :: SelfLoops -> FSM sy -> P.Gr () sy
fsmToPatriciaTree = flip fsmToFGL'
fsmToDot :: (Ord sy, Labellable sy) => FSM sy -> DotGraph Int
fsmToDot = fglDot . flip fsmToFGL Trim
fglDot :: (Ord b, Labellable b, Graph gr) => gr a b -> DotGraph Int
fglDot g = graphToDot parms g
where parms = nonClusteredParams {
isDirected = True
, fmtNode = const []
, fmtEdge = edgeFn
}
edgeFn (_, _, label) = [toLabel label]
fglToFsm :: (Graph gr, Ord sy, Show sy) => gr a sy ->
ReadFsmMonad (FSM sy, [LNode a])
fglToFsm g = do let (nodes, actions) = graphActions g
let fsm = fromList actions
p <- polishFSM fsm
return (p, nodes)
graphActions :: (Graph gr, Ord b) => gr a b -> ([LNode a], [(b, Action)])
graphActions g = (nodeList, actions)
where nodeList = labNodes g
actions = mkActions destsMap nodeMap srcStates actionSymbols
srcStates = map fst nodeList
actionSymbols = symbols g
destsMap = mkDestsMap g
nodeMap = mkNodeMap g
mkActions :: Ord sy => DestsMap sy -> NodeMap -> [Node] -> [sy] ->
[(sy, Action)]
mkActions destsMap nodeMap srcs =
map $ mkAction destsMap nodeMap srcs
mkAction :: Ord sy => DestsMap sy -> NodeMap -> [Node] -> sy ->
(sy, Action)
mkAction destsMap nodeMap srcs l =
(l, Action $ map (mkDestSet destsMap nodeMap l) srcs)
mkDestSet :: Ord b => DestsMap b -> NodeMap -> b -> Node ->
DestinationSet
mkDestSet destsMap nodeMap l src =
DestinationSet $ map (nodeToState nodeMap) destNodes
where destNodes = M.findWithDefault [src] (l, src) destsMap
symbols :: (Graph gr, Ord sy) => gr a sy -> [sy]
symbols = sort . nub . map (\(_,_,s) -> s) . labEdges
type DestsMap sy = M.Map (sy, Node) [Node]
mkDestsMap :: (Graph gr, Ord b) => gr a b -> DestsMap b
mkDestsMap = foldr insertEdge M.empty . labEdges
where insertEdge (s, d, l) = M.insertWith (++) (l, s) [d]
type NodeMap = M.Map Node State
mkNodeMap :: Graph gr => gr a b -> NodeMap
mkNodeMap = M.fromList . map flipPair . zipWithIndex . map fst . labNodes
where flipPair (a,b) = (b,a)
nodeToState :: NodeMap -> Node -> State
nodeToState nodeMap node = forceLookupM err node nodeMap
where err = "Node -> State lookup failure (can't happen?)"