{- |

Generating and drawing graphs of FSMs.

Includes:

  - Interface to fgl graph library
    (<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,
    strongCCs,
    weakCCs,
    -- * Dot and GML format output.
    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

-- | 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 | 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 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
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
fglDot g = graphToDot 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)
    ])