module Data.FsmActions.Graph (
SelfLoops(..),
fsmToFGL,
strongCCs,
weakCCs,
CleanShow,
fsmToDot,
fsmToGML
) where
import Data.Graph.Inductive.Basic (undir)
import Data.Graph.Inductive.Graph (Graph, labEdges, 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 Text.PrettyPrint.HughesPJ
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 = 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'
class (Show a) => CleanShow a where
cleanShow :: a -> String
cleanShow = show
instance (Show a) => CleanShow a
instance CleanShow String where
cleanShow = id
instance CleanShow Char where
cleanShow c = cleanShow [c]
fsmToDot :: (Ord sy, CleanShow sy) => FSM sy -> DotGraph
fsmToDot = fglDot . flip fsmToFGL Trim
fglDot :: (Ord b, CleanShow b, Graph gr) => gr a b -> DotGraph
fglDot g = graphToDot g [] nodeFn edgeFn
where nodeFn _ = []
edgeFn (_, _, label) = [Label $ StrLabel $ cleanShow label]
fsmToGML :: CleanShow sy => FSM sy -> Doc
fsmToGML f = text "graph" <+> brackets body
where body = vcat [directed, planar, fNodes, fEdges]
directed = text "directed 1"
planar = text "IsPlanar 1"
fNodes = vcat $ map gmlNode $ states f
fEdges = vcat $ map gmlEdge $ labEdges $ fsmToFGL f Trim
gmlNode :: State -> Doc
gmlNode i =
text "node" <+> brackets (vcat [
text "id" <+> text (show i),
text "label" <+> doubleQuotes (text $ show i)
])
gmlEdge :: CleanShow sy => (State, State, sy) -> Doc
gmlEdge (src, dest, label) =
text "edge" <+> brackets (vcat [
text "source" <+> text (show src),
text "target" <+> text (show dest),
text "label" <+> doubleQuotes (text $ cleanShow label)
])