{- | Generating, interpreting, and drawing graphs of FSMs. Includes: - Interface to fgl graph library for graph input/output (<http://hackage.haskell.org/package/fgl>). - Interface to graphviz library for dot output (<http://hackage.haskell.org/package/graphviz>). - Home-grown GML (Graph Modelling Language) output. -} -- Copyright (c) 2009 Andy Gimblett - http://www.cs.swan.ac.uk/~csandy/ -- BSD Licence (see http://www.opensource.org/licenses/bsd-license.php) -- We need these declarations for the CleanShow typeclass. {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} module Data.FsmActions.Graph ( -- * FGL graph operations. SelfLoops(..), fsmToFGL, fglDot, -- XXX strongCCs, weakCCs, -- * Dot and GML format output. CleanShow, cleanShow, fsmToDot, fsmToGML, -- * Input. 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 (foldr, nub, sort) import qualified Data.Map as M import Data.Map.Utils (forceLookupM) import Text.PrettyPrint.HughesPJ import Data.FsmActions hiding (mkAction) import Data.FsmActions.Error import Data.FsmActions.WellFormed (polishFSM) -- | When converting an 'Data.FsmActions.FSM' into a graph, do we keep -- all self-loops, or only those which are sources of nondeterminism? data SelfLoops = -- | Keep them all Keep -- | Trim any which aren't nondeterminism sources. | Trim -- | Turn an FSM into an fgl graph with labelled edges. fsmToFGL :: FSM sy -> SelfLoops -> T.Gr () sy -- Note use of T.Gr; this instance of Graph allows multiple edges -- between the same pair of nodes, which is what we _usually_ (but not -- always) want. fsmToFGL = fsmToFGL' -- Generalised FSM to graph conversion; works with any Graph instance. 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 -- Compute an FSM's labelled edges fsmEdges :: SelfLoops -> FSM sy -> [(State, State, sy)] fsmEdges selfs = concat . fsmMap (symbolEdges selfs) -- Given a symbol, action pair, compute the list of edges with that -- symbol. symbolEdges :: SelfLoops -> sy -> Action -> [(State, State, sy)] symbolEdges selfs s = concatMap (syStateEdges selfs s) . zipWithIndex . destinationSets -- Given a symbol, a start state, and a destination set, compute the -- list of edges leading from that state with that symbol, possibly -- taking account of a desire to trim deterministic self-loops. 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) -- Given a symbol, a start state, and a destination set, compute the -- list of edges leading from that state with that symbol. syStateEdges' :: sy -> (State, DestinationSet) -> [(State, State, sy)] syStateEdges' s (src, dSet) = map (\x -> (src, x, s)) $ destinations dSet -- Create a zip of a list with its index list. zipWithIndex :: [a] -> [(Int, a)] zipWithIndex xs = zip [0..(length xs-1)] xs -- | Compute an FSM's strongly-connected components. strongCCs :: Eq sy => FSM sy -> [[State]] strongCCs = scc . fsmToPatriciaTree Trim -- | Compute an FSM's weakly-connected components. weakCCs :: Eq sy => FSM sy -> [[State]] weakCCs = scc . undir . fsmToPatriciaTree Trim -- | The PatriciaTree instance of Graph is faster, but not generally -- useful to us because it doesn't allow multiple edges between the -- same pair of nodes. For SCC checks, however, that doesn't matter, -- so we use it. fsmToPatriciaTree :: SelfLoops -> FSM sy -> P.Gr () sy fsmToPatriciaTree = flip fsmToFGL' -- | Subclass 'Show' so that 'show' calls on 'String's and 'Char's -- don't get quotes inserted. class (Show a) => CleanShow a where cleanShow :: a -> String cleanShow = show -- by default, turn it to a String instance (Show a) => CleanShow a instance CleanShow () where cleanShow _ = "" instance CleanShow String where cleanShow = id -- don't need to do anything for a String instance CleanShow Char where cleanShow c = cleanShow [c] -- just lift it to String -- | Turn an FSM into a 'Data.GraphViz.DotGraph', trimming any -- self-loops which aren't sources of nondeterminism. fsmToDot :: (Ord sy, CleanShow sy) => FSM sy -> DotGraph Int fsmToDot = fglDot . flip fsmToFGL Trim -- Turn an FGL into a DotGraph with labelled edges. fglDot :: (Ord b, CleanShow b, Graph gr) => gr a b -> DotGraph Int fglDot g = graphToDot True g [] nodeFn edgeFn where nodeFn _ = [] edgeFn (_, _, label) = [Label $ StrLabel $ cleanShow label] -- | Turn an FSM into a GML-formatted graph', trimming any self-loops -- which aren't sources of nondeterminism. 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) ]) -- And now for some input. -- | Turn an FGL graph (interpreted as being a directed graph) into an -- FSM. Self-loops are inserted as required. Also returns a list of -- the graph's labelled nodes, since the labels are discarded by the -- FSM construction. FSM states are numbered [0..] and thus may be -- used as an index into that list of labelled nodes, in order to -- relate FSM states back to the original graph nodes and their -- labels. 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) -- | Turn a graph into a list of its labelled nodes (indexed by -- corresponding FSM state) and a list of (symbol, -- 'Data.FsmActions.Action') pairs. 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 ls = map (mkAction destsMap nodeMap srcs) ls 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 -- | Given a labelled directed graph, compute the list of its unique -- labels, which will be the corresponding FSM's symbols. symbols :: (Graph gr, Ord sy) => gr a sy -> [sy] symbols = sort . nub . map (\(_,_,s) -> s) . labEdges -- | A DestsMap maps (action symbol, source graph node) pairs to -- [destination graph node] lists, which provide a handy lookup when -- building 'Data.FsmActions.DestinationSet's. type DestsMap sy = M.Map (sy, Node) [Node] -- | Build a DestsMap from a graph. 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] -- | A NodeMap is a map from graph node numbers to FSM state numbers, -- the inverse of the indexing produced by labNodes, ie -- forall n . (fst (labNodes g !! n)) `M.lookup` nodeMap g == n type NodeMap = M.Map Node State -- | Construct a NodeMap. mkNodeMap :: Graph gr => gr a b -> NodeMap mkNodeMap = M.fromList . map flipPair . zipWithIndex . map fst . labNodes where flipPair (a,b) = (b,a) -- | Perform a node -> state lookup in a NodeMap; throws an exception -- if it fails, which it shouldn't ever here. nodeToState :: NodeMap -> Node -> State nodeToState nodeMap node = forceLookupM err node nodeMap where err = "Node -> State lookup failure (can't happen?)" -- Examples for hacking. {- love :: T.Gr Char String love = mkGraph nodes edges where nodes = [(1, 'x'), (3, 'y'), (5, 'z')] edges = [(1,3,"a"), (3,5,"a"), (5,3,"a"), (1,1,"b"), (3,3,"b"), (5,1,"b"), (1,1,"c"), (3,3,"c"), (5,1,"c") ] mooKid :: T.Gr () String mooKid = mkGraph (map mkNode nodes) edges where mkNode x = (x, ()) nodes = [0,1,2] edges = [(0,0,"a") ,(0,1,"a") ,(0,2,"c") ,(1,1,"b") ,(1,0,"a") ,(2,0,"c") ] -}