From 3360bd3e7be366681ad77a6eef2c0bec240fb88f Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Thu, 5 Jan 2006 12:59:36 +0000
Subject: [PATCH] Print slf_graphviz with subgraphs.

---
 src/GF/Data/Utilities.hs         |  6 ++++++
 src/GF/Speech/FiniteState.hs     | 34 ++++++++++++++++++++------------
 src/GF/Speech/PrSLF.hs           | 22 ++++++++++++++++-----
 src/GF/Visualization/Graphviz.hs | 23 +++++++++++++++++----
 4 files changed, 63 insertions(+), 22 deletions(-)

diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs
index 50d1f5195..a5ceb08d2 100644
--- a/src/GF/Data/Utilities.hs
+++ b/src/GF/Data/Utilities.hs
@@ -88,6 +88,12 @@ lookup' x = fromJust . lookup x
 find' :: (a -> Bool) -> [a] -> a
 find' p = fromJust . find p
 
+-- | Set a value in a lookup table.
+tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
+tableSet x y [] = [(x,y)]
+tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs
+                           | otherwise = p:tableSet x y xs
+
 -- * equality functions
 
 -- | Use an ordering function as an equality predicate.
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index 632c20830..8dab428bc 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -22,6 +22,7 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA,
                               oneFinalState,
 			      moveLabelsToNodes, minimize,
                               dfa2nfa,
+                              unusedNames, renameStates,
 			      prFAGraphviz, faToGraphviz) where
 
 import Data.List
@@ -84,6 +85,20 @@ mapTransitions f = onGraph (emap f)
 minimize :: Ord a => NFA a -> DFA a
 minimize = determinize . reverseNFA . dfa2nfa . determinize . reverseNFA
 
+unusedNames :: FA n a b -> [n]
+unusedNames (FA (Graph names _ _) _ _) = names
+
+-- | Give new names to all nodes.
+renameStates :: Ord x => [y] -- ^ Infinite supply of new names
+             -> FA x a b
+             -> FA y a b
+renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
+    where (ns,rest) = splitAt (length (nodes g)) supply
+          newNodes = Map.fromList (zip (map fst (nodes g)) ns)
+	  newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
+          s' = newName s
+          fs' = map newName fs
+
 onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
 onGraph f (FA g s ss) = FA (f g) s ss
 
@@ -138,7 +153,7 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
                              (ns',es') = (Set.toList ns, Set.toList es)
                              final = filter isDFAFinal ns'
                              fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
- 		          in numberStates fa
+ 		          in renameStates [0..] fa
   where out = outgoing g
 --        reach = nodesReachable out
 	start = closure out $ Set.singleton s
@@ -158,13 +173,6 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
                 rs' = rs `Set.union` Set.fromList (map snd cs)
                 es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs]
 
-numberStates :: (Ord x,Enum y) => FA x a b -> FA y a b
-numberStates (FA g s fs) = FA (renameNodes newName rest g) s' fs'
-    where (ns,rest) = splitAt (length (nodes g)) $ [toEnum 0 .. ]
-          newNodes = Map.fromList (zip (map fst (nodes g)) ns)
-	  newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
-          s' = newName s
-          fs' = map newName fs
 
 -- | Get all the nodes reachable from a list of nodes by only empty edges.
 closure :: Ord n => Outgoing n a (Maybe b) -> Set n -> Set n
@@ -213,14 +221,14 @@ dfa2nfa = mapTransitions Just
 --
 
 prFAGraphviz :: (Eq n,Show n) => FA n String String -> String
-prFAGraphviz  = Dot.prGraphviz . faToGraphviz ""
+prFAGraphviz  = Dot.prGraphviz . faToGraphviz
 
 prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String
-prFAGraphviz_  = Dot.prGraphviz . faToGraphviz "" . mapStates show . mapTransitions show
+prFAGraphviz_  = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
 
-faToGraphviz :: (Eq n,Show n) => String -- ^ Graph ID
-             -> FA n String String -> Dot.Graph
-faToGraphviz i (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed i [] (map mkNode ns) (map mkEdge es) []
+faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
+faToGraphviz (FA (Graph _ ns es) s f) 
+    = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
    where mkNode (n,l) = Dot.Node (show n) attrs
 	     where attrs = [("label",l)]
 			   ++ if n == s then [("shape","box")] else []
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs
index ce0795420..a47057c80 100644
--- a/src/GF/Speech/PrSLF.hs
+++ b/src/GF/Speech/PrSLF.hs
@@ -62,13 +62,25 @@ slfGraphvizPrinter :: Ident -- ^ Grammar name
 	           -> Options -> CGrammar -> String
 slfGraphvizPrinter name opts cfg = Dot.prGraphviz g
   where MFA main subs = cfgToMFA opts cfg
-        g = Dot.addSubGraphs (map (uncurry gvSLFFA) subs) $ gvSLFFA "" main
+        g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] 
+        ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs
+        m = gvSLFFA Nothing main
 
-gvSLFFA :: String -> DFA (MFALabel String) -> Dot.Graph
-gvSLFFA n = faToGraphviz n . mapStates (maybe "" mfaLabelToGv) 
-            . mapTransitions (const "") . slfStyleFA
+gvSLFFA :: Maybe String -> DFA (MFALabel String) -> STM.State [State] Dot.Graph
+gvSLFFA n fa = 
+    liftM (mkCluster n . faToGraphviz . mapStates (maybe "" mfaLabelToGv) 
+            . mapTransitions (const "")) (rename $ slfStyleFA fa)
   where mfaLabelToGv (MFASym s) = s
-        mfaLabelToGv (MFASub s) = "<" ++ s ++ ">"
+        mfaLabelToGv (MFASub s) = "#" ++ s
+        mkCluster Nothing = id
+        mkCluster (Just x) 
+            = Dot.setName ("cluster_"++x) . Dot.setAttr "label" x
+        rename fa = do
+                    names <- STM.get
+                    let fa' = renameStates names fa
+                        names' = unusedNames fa'
+                    STM.put names'
+                    return fa'
 
 mapMFA :: (DFA (MFALabel a) -> b) -> MFA a -> (b,[(String,b)])
 mapMFA f (MFA main subs) = (f main, [(c, f fa) | (c,fa) <- subs])
diff --git a/src/GF/Visualization/Graphviz.hs b/src/GF/Visualization/Graphviz.hs
index d326d5364..b59e3ecd2 100644
--- a/src/GF/Visualization/Graphviz.hs
+++ b/src/GF/Visualization/Graphviz.hs
@@ -17,6 +17,8 @@ module GF.Visualization.Graphviz (
 				  Node(..), Edge(..),
 				  Attr,
                                   addSubGraphs,
+                                  setName,
+                                  setAttr,
 				  prGraphviz
 			) where
 
@@ -25,7 +27,14 @@ import Data.Char
 import GF.Data.Utilities
 
 -- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs
-data Graph = Graph GraphType String [Attr] [Node] [Edge] [Graph]
+data Graph = Graph {
+                    gType :: GraphType,
+                    gId :: Maybe String,
+                    gAttrs :: [Attr],
+                    gNodes :: [Node],
+                    gEdges :: [Edge],
+                    gSubgraphs :: [Graph]
+                   }
   deriving (Show)
 
 data GraphType = Directed | Undirected
@@ -44,7 +53,13 @@ type Attr = (String,String)
 --
 
 addSubGraphs :: [Graph] -> Graph -> Graph
-addSubGraphs nss (Graph t i at ns es ss) = Graph t i at ns es (nss++ss)
+addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g }
+
+setName :: String -> Graph -> Graph
+setName n g = g { gId = Just n }
+
+setAttr :: String -> String -> Graph -> Graph
+setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) }
 
 --
 -- * Pretty-printing
@@ -52,11 +67,11 @@ addSubGraphs nss (Graph t i at ns es ss) = Graph t i at ns es (nss++ss)
 
 prGraphviz :: Graph -> String
 prGraphviz g@(Graph t i _ _ _ _) =
-    graphtype t ++ " " ++ esc i ++ " {\n" ++ prGraph g ++ "}\n"
+    graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
 
 prSubGraph :: Graph -> String
 prSubGraph g@(Graph _ i _ _ _ _) = 
-    "subgraph" ++ " " ++ esc i ++ " {\n" ++ prGraph g ++ "}"
+    "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
 
 prGraph :: Graph -> String
 prGraph (Graph t id at ns es ss) =