Graph.hs

{- |

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 (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 parms g
    where parms = nonClusteredParams {
                    isDirected = True
                  , fmtNode = const []
                  , fmtEdge = edgeFn
                  }
          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 =
    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

-- | 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")
                  ]

-}