module Data.FsmActions.FGL (
SelfLoops(..),
fsmToFGL,
strongCCs,
weakCCs
) where
import qualified Data.Map as M
import Data.Graph.Inductive.Basic (undir)
import Data.Graph.Inductive.Graph (Graph, 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.FsmActions
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 = concatMap (symbolEdges selfs) . M.toList . unFSM
symbolEdges :: SelfLoops -> (sy, Action) -> [(State, State, sy)]
symbolEdges selfs (s, a) =
concatMap (syStateEdges selfs s) $ zipWithIndex $ destinationSets a
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'