----------------------------------------------------------------------------- -- | -- Module : Language.HaLex.FaAsDiGraph -- Copyright : (c) João Saraiva 2001,2002,2003,2004,2005, 2016 -- License : LGPL -- -- Maintainer : saraiva@di.uminho.pt -- Stability : provisional -- Portability : portable -- -- Finite Automata as Directed Graphs in GraphViz. -- Code Included in the Lecture Notes on -- Language Processing (with a functional flavour). -- ----------------------------------------------------------------------------- module Language.HaLex.FaAsDiGraph ( ndfa2graphviz , ndfa2graphviz2file , dfa2graphviz , dfa2graphviz2file , tographviz , tographviz' , tographvizIO , tographvizIO' , dfa2DiGraphWithNoSyncSt , dfaDiGraphWithNoSyncStIO , genOneArrow ) where import Language.HaLex.RegExp import Language.HaLex.RegExp2Fa import Language.HaLex.Ndfa import Language.HaLex.Dfa import Language.HaLex.FaOperations import Language.HaLex.Minimize -- | Print a 'Ndfa' in GraphViz ndfa2graphviz ndfa name = tographviz ndfa name "circle" "LR" (show . show) -- | Print a 'Ndfa' in GraphViz in a file ndfa2graphviz2file ndfa name = writeFile (name++".dot") (ndfa2graphviz ndfa name) -- | Print a 'Dfa' in GraphViz dfa2graphviz dfa name = tographviz (dfa2ndfa dfa) name "circle" "LR" (show . show) -- | Print a 'Dfa' in GraphViz in a file dfa2graphviz2file dfa name = writeFile (name++".dot") (dfa2graphviz dfa name) -- | Print a 'Ndfa' in GraphViz/dot notation (default function) tographviz :: (Eq sy, Show sy, Ord st, Show st) => Ndfa st sy -- ^ Automaton -> [Char] -- ^ Graph's name -> [Char] -- ^ Node's shape -> [Char] -- ^ Orientation -> (st -> [Char]) -- ^ Show function to print the state ids -> [Char] tographviz ndfa@(Ndfa v q s z delta) name shape orientation showState = tographviz' ndfa name shape orientation showState show False False -- | Print a 'Ndfa' in GraphViz/dot notation tographviz' :: (Eq sy, Show sy, Ord st, Show st) => Ndfa st sy -- ^ Automaton -> [Char] -- ^ Graph's name -> [Char] -- ^ Node's shape -> [Char] -- ^ Orientation -> (st -> [Char]) -- ^ Show function to print the state ids -> (sy -> [Char]) -- ^ Show function to print the labels -> Bool -- ^ Show dead states? -> Bool -- ^ Show sync states? -> [Char] tographviz' ndfa@(Ndfa v q s z delta) name shape orientation showState showLabel deadSt syncSt = "digraph " ++ name ++ " {\n " ++ "rankdir = " ++ orientation ++ " ;\n " ++ (showElemsListPerLine (showStates q)) ++ "\n " ++ (showElemsListPerLine (showInitialStates s)) ++ "\n " ++ (showElemsListPerLine (showFinalStates' z)) ++ (showElemsListPerLine (showNdfaArrows ndfa showState showLabel deadSt syncSt)) ++ "node [shape=none, lavel=initialState, style = invis];\n" ++ (createInitialArrows (mirroredInitialStates s 1) s) ++ "\n}" where showElemsListPerLine :: [String] -> String showElemsListPerLine [] = "" showElemsListPerLine (h:t) = ((showString h) "\n ") ++ (showElemsListPerLine t) showStates qs = ["\"" ++ (showState q) ++ "\"" ++ " [shape=" ++ shape ++" , label=\"" ++ (showState q) ++ "\" ,color=black];" | q <- qs , not (ndfaIsStDead delta v z q ) || deadSt , not (ndfaIsSyncState delta v z q) || syncSt] showInitialStates ss = map showInitialState ss showInitialState s = "\"" ++ (showState s) ++ "\" [shape=" ++ shape ++ " , label= \"" ++ (showState s) ++ "\", color=green];\n " -- showFinalStates' :: Show a => [a] -> [String] showFinalStates' zs = [ "\"" ++ (showState z) ++ "\" [shape=double" ++ shape ++" , color=red];" | z <- zs ] -- Creating the incoming arrows for the initial states -- (for each state we create an invisible node and a arrow connecting to the initial one) mirroredInitialStates [] _ = [] mirroredInitialStates (x:xs) n = ("\"_newState_" ++ (show n) ++ "\"") : mirroredInitialStates xs (n+1) createInitialArrows [] [] = " " createInitialArrows (x:xs) (y:ys) = x ++ " -> \"" ++ (showState y) ++ "\" [color = green];\n" ++ createInitialArrows xs ys -- | Show the arrows between nodes (states) induced by the 'Ndfa' transitions. showNdfaArrows :: (Ord st,Show st,Show sy,Eq sy) => Ndfa st sy -- ^ Automaton -> (st -> String) -- ^ Show function to print the state ids -> (sy -> String) -- ^ Show function to print the labels -> Bool -- ^ Show dead states? -> Bool -- ^ Show sync states? -> [String] showNdfaArrows ndfa@(Ndfa v q s z delta) showState showLabel deadSt syncSt = map (\ (o,l,d) -> if deadSt then if (not syncSt) && (ndfaIsSyncState delta v z o) || (ndfaIsSyncState delta v z d) then "" else genOneArrow (showState o) (showLabels showLabel l) (showState d) else if ((ndfaIsStDead delta v z o) || (ndfaIsStDead delta v z d)) then "" else genOneArrow (showState o) (showLabels showLabel l) (showState d)) ((groupMoves . transitionTableNdfa) ndfa) -- | Group labels with same origin and destination. -- Given the Transition Table of a Ndfa it groups the transtions with -- the same origin and destination into a single transition, whose transtion -- is the list of labels of the original transtions. -- groupMoves [] = [] groupMoves ((o,l,d):rs) = res where (l',rs') = groupMoves' (o,l,d) ((o,l,d):rs) res = (o,l',d) : groupMoves rs' groupMoves' :: (Eq st, Eq sy) => (st,Maybe sy,st) -> [(st,Maybe sy,st)] -> ([Maybe sy],[(st,Maybe sy,st)]) groupMoves' _ [] = ([],[]) groupMoves' (o,l,d) ((o',l',d'):rs) | o==o' && d==d' = (new_label,rs') | otherwise = (l'', (o',l',d') : rs') where (l'',rs') = groupMoves' (o,l,d) rs new_label = if l'' == [] then [l'] else l' : l'' {- showNdfaArrows :: (Ord st,Show st,Show sy) => Ndfa st sy -> [String] showNdfaArrows (Ndfa vs qs s z delta) = [ genOneArrow (show q) (show v) (show r) | q <- qs , v <- vs , r <- delta q (Just v) , not (ndfaIsStDead delta vs z r ) , not (ndfaIsStDead delta vs z q ) ] ++ [ genOneArrow (show q) "Epsilon" (show r) | q <- qs , r <- delta q Nothing , not (ndfaIsStDead delta vs z r ) , not (ndfaIsStDead delta vs z q ) ] -} showLabels :: (st -> String) -> [Maybe st] -> String showLabels _ [] = "" showLabels showLabel (x:xs) = case x of Just a -> (showLabel a) ++ if (showLabels showLabel xs == "") then "" else ("," ++ showLabels showLabel xs) Nothing -> "Epsilon" ++ if (showLabels showLabel xs == "") then "" else ("," ++ showLabels showLabel xs) genOneArrow :: String -> String -> String -> String genOneArrow orin label dest = orin ++ " -> " ++ dest ++ " [label = " ++ (show label) ++ "];" -- | Save a 'Ndfa' in a GraphViz/dot file (default function) tographvizIO :: (Eq sy, Show sy, Ord st , Show st) => Ndfa st sy -- ^ Automaton -> [Char] -- ^ Graph's name -> [Char] -- ^ Node's shape -> [Char] -- ^ Orientation -> (st -> [Char]) -- ^ Show function to print the state ids -> IO() tographvizIO ndfa name shape orientation showState = writeFile (name++".dot") (tographviz ndfa name shape orientation showState) -- | Save a 'Ndfa' in a GraphViz/dot file tographvizIO' :: (Eq sy, Show sy, Ord st , Show st) => Ndfa st sy -- ^ Automaton -> [Char] -- ^ Graph's name -> [Char] -- ^ Node's shape -> [Char] -- ^ Orientation -> (st -> [Char]) -- ^ Show function to print the state ids -> (sy -> [Char]) -- ^ Show function to print the labels -> Bool -- ^ Show dead states? -> Bool -- ^ Show sync states? -> IO() tographvizIO' ndfa name shape orient showSt showLb deadSt syncSt = writeFile (name++".dot") (tographviz' ndfa name shape orient showSt showLb deadSt syncSt) dfa2DiGraphWithNoSyncSt dfa name = dfa2graphviz dfa name dfa2DiGraphIO dfa name fn = writeFile (fn++".gph") (dfa2graphviz dfa name ) dfaDiGraphWithNoSyncStIO dfa name fn = writeFile fn (dfa2graphviz dfa name) -- dfa2DiGraphIO'' :: (Show sy, Ord sy , Eq st) => Dfa st sy -> [Char] -> IO () dfa2DiGraphIO'' dfa name = dfa2DiGraphIO (beautifyDfa dfa) name name