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
ndfa2graphviz ndfa name = tographviz ndfa name "circle" "LR" (show . show)
ndfa2graphviz2file ndfa name =
writeFile (name++".dot") (ndfa2graphviz ndfa name)
dfa2graphviz dfa name =
tographviz (dfa2ndfa dfa) name "circle" "LR" (show . show)
dfa2graphviz2file dfa name = writeFile (name++".dot") (dfa2graphviz dfa name)
tographviz :: (Eq sy, Show sy, Ord st, Show st)
=> Ndfa st sy
-> [Char]
-> [Char]
-> [Char]
-> (st -> [Char])
-> [Char]
tographviz ndfa@(Ndfa v q s z delta) name shape orientation showState =
tographviz' ndfa name shape orientation showState show False False
tographviz' :: (Eq sy, Show sy, Ord st, Show st)
=> Ndfa st sy
-> [Char]
-> [Char]
-> [Char]
-> (st -> [Char])
-> (sy -> [Char])
-> Bool
-> Bool
-> [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' zs = [ "\"" ++ (showState z) ++ "\" [shape=double" ++ shape ++" , color=red];"
| z <- zs ]
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
showNdfaArrows :: (Ord st,Show st,Show sy,Eq sy)
=> Ndfa st sy
-> (st -> String)
-> (sy -> String)
-> Bool
-> Bool
-> [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)
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''
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) ++ "];"
tographvizIO :: (Eq sy, Show sy, Ord st , Show st)
=> Ndfa st sy
-> [Char]
-> [Char]
-> [Char]
-> (st -> [Char])
-> IO()
tographvizIO ndfa name shape orientation showState =
writeFile (name++".dot") (tographviz ndfa name shape orientation showState)
tographvizIO' :: (Eq sy, Show sy, Ord st , Show st)
=> Ndfa st sy
-> [Char]
-> [Char]
-> [Char]
-> (st -> [Char])
-> (sy -> [Char])
-> Bool
-> Bool
-> 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'' dfa name = dfa2DiGraphIO (beautifyDfa dfa) name name