GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-11 20:22:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

Print slf_graphviz with subgraphs.

Browse Source
This commit is contained in:
bringert
2006-01-05 12:59:36 +00:00
parent a4ba93cc55
commit 5c0d9d52b3
4 changed files with 63 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/GF/Speech/PrSLF.hs
View File

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