Adapt visualisation to the new types

src/Rextra/Visualize.hs

@@ -1,121 +1,125 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
 
-module Rextra.Visualize
+module Rextra.Visualize where
-  ( showDot
-  , saveDot
-  , saveDotAsPng
-  , dfaToDot
-  , nfaToDot
-  ) where
 
 import           Control.Monad
-import           Data.Graph.Inductive
 import           Data.GraphViz
 import           Data.List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import qualified Rextra.Dfa as Dfa
+import           Rextra.Fa
 import qualified Rextra.Nfa as Nfa
-import           Rextra.Util
 
-showDot :: DotGraph Node -> IO ()
+-- First, some labelling...
+
+-- | Instances of this type class must fulfill the following rules:
+--
+-- * The return value of 'asLabel' must never be an empty string.
+--
+-- * @a == b@ is equivalent to @'asLabel' a == 'asLabel' b@.
+class AsLabel a where
+  asLabel :: a -> String
+
+instance AsLabel Int where
+  asLabel = show
+
+instance AsLabel Char where
+  asLabel c = [c]
+
+-- | __Warning__: Only use this if you know that no empty strings
+-- occur in your automaton's state names!
+instance AsLabel [Char] where
+  asLabel = id
+
+instance AsLabel a => AsLabel (Set.Set a) where
+  asLabel s =
+    let sublabels = map asLabel $ Set.toList s
+    in  "{" ++ intercalate "," sublabels ++ "}"
+
+{-
+ - Displaying or saving 'DotGraph's
+ -}
+
+showDot :: (PrintDotRepr dg n) => dg n -> IO ()
 showDot dg = runGraphvizCanvas' dg Gtk
 
-saveDot :: GraphvizOutput -> String -> DotGraph Node -> IO ()
+saveDot :: (PrintDotRepr dg n) => GraphvizOutput -> String -> dg n -> IO ()
 saveDot format path dg = void $ runGraphviz dg format path
 
-saveDotAsPng :: String -> DotGraph Node -> IO ()
+saveDotAsPng :: (PrintDotRepr dg n) => String -> dg n -> IO ()
 saveDotAsPng = saveDot Png
 
-labelFromSet :: Set.Set Char -> String
-labelFromSet charSet = "{" ++ intersperse ',' (Set.toList charSet) ++ "}"
-
 {-
- - Visualizing DFAs
+ - General 'Fa' stuff
  -}
 
-convertDfaState :: (Int, Dfa.State Int Char) -> [LEdge String]
+-- The node label is a visibility flag. If it is False the node should
-convertDfaState (from, state) =
+-- be invisible in the displayed graph.
-  let normalEdges = map (\(to, tSet) -> (from, to, labelFromSet tSet))
+nodes :: (AsLabel s) => Fa state s t -> [(String, Bool)]
-                  . Map.assocs
+nodes a =
-                  . Dfa.transitionsByState
+  let normalNodes = map (\s -> (asLabel s, True)) $ Set.toList $ states a
-                  $ Dfa.transitions state
+      entryNode   = ("", False)
-      defaultEdge = (from, Dfa.defaultTransition state, "*")
+  in entryNode : normalNodes
-  in  defaultEdge : normalEdges
 
--- | Convert a 'Dfa.Dfa' to a 'Gr' graph.
+-- Finally, a good use for the list monad! I couldn't even have used
---
+-- the applicative instance instead :D
--- This function assumes that no node has a negative name.
+edges :: (Ord s, AsLabel s)
-dfaToGraph :: Dfa.Dfa Int Char -> Gr () String
+      => Fa state s t -> (state s t -> [(String, s)]) -> [(String, String, String)]
-dfaToGraph dfa =
+edges a f = ("", asLabel $ entryState a, "") : do
-  let stateMap  = Dfa.stateMap dfa
+  from        <- Set.toList $ states a
-      startNode = (-1, ())
+  (label, to) <- f $ getState a from
-      startEdge = (-1, Dfa.entryState dfa, "")
+  pure (asLabel from, asLabel to, label)
-      nodes     = map (\k -> (k, ())) $ Map.keys stateMap
-      edges     = concatMap convertDfaState $ Map.assocs stateMap
-  in  mkGraph (startNode : nodes) (startEdge : edges)
 
-dfaAttributes :: Labellable el => Dfa.Dfa Int t -> GraphvizParams Int nl el () nl
+faParams :: (AsLabel s) => Fa state s t -> GraphvizParams String Bool String () Bool
-dfaAttributes dfa =
+faParams a =
-  let exitStates = Dfa.exitStates dfa
+  let acceptingStates = Set.map asLabel $ exitStates a
 
-      fmtNode (-1, _) = [style invis] -- Start node
+      formatNode (_, False) = [style invis] -- See comment on 'nodes'
-      fmtNode ( n, _)
+      formatNode (s,  True) =
-        | n `Set.member` exitStates = [shape DoubleCircle]
+        let accepting = s `Set.member` acceptingStates
-        | otherwise                 = [shape Circle]
+        in  [toLabel s, shape (if accepting then DoubleCircle else Circle)]
 
-      fmtEdge (-1, _, _) = [] -- Start edge
+      formatEdge (_, _,    "") = [] -- Probably the start edge
-      fmtEdge ( _, _, l) = [toLabel l]
+      formatEdge (_, _, label) = [toLabel label]
+  in  nonClusteredParams { fmtNode = formatNode, fmtEdge = formatEdge }
 
-  in  nonClusteredParams { fmtNode = fmtNode, fmtEdge = fmtEdge }
+faToDot :: (Ord s, AsLabel s)
-
+        => (state s t -> [(String, s)]) -> Fa state s t -> DotGraph String
-dfaToDot :: Dfa.Dfa Int Char -> DotGraph Node
+faToDot f a = graphElemsToDot (faParams a) (nodes a) (edges a f)
-dfaToDot dfa = graphToDot (dfaAttributes dfa) (dfaToGraph dfa)
 
 {-
- - Visualizing NFAs
+ - 'Dfa' stuff
  -}
 
-labelFromCondition :: Nfa.TransitionCondition Char -> String
+dfaShowNoDefault :: (Ord s, Ord t, AsLabel t) => Dfa.State s t -> [(String, s)]
-labelFromCondition (Nfa.Only charSet)      = labelFromSet charSet
+dfaShowNoDefault = map (\(s, t) -> (asLabel t, s)) . Map.assocs . Dfa.transitionsByState
-labelFromCondition (Nfa.AllExcept charSet)
-  | Set.null charSet = "Σ"
-  | otherwise        = "Σ\\" ++ labelFromSet charSet
 
-convertNfaState :: (Int, Nfa.State Int Char) -> [LEdge String]
+dfaShowAll :: (Ord s, Ord t, AsLabel t) => Dfa.State s t -> [(String, s)]
-convertNfaState (from, state) =
+dfaShowAll s = ("*", Dfa.defaultTransition s) : dfaShowNoDefault s
-  let transitions        = Nfa.transitions state
-      transitionEdges    = map (\(cond, to) -> (from, to, labelFromCondition cond)) transitions
-      epsilonTransitions = Set.toList $ Nfa.epsilonTransitions state
-      epsilonEdges       = map (\to -> (from, to, "ε")) epsilonTransitions
-  in transitionEdges ++ epsilonEdges
 
-nfaToGraph :: Nfa.Nfa Int Char -> Gr () String
+dfaToDot :: (Ord s, AsLabel s, Ord t, AsLabel t) => Dfa.Dfa s t -> DotGraph String
-nfaToGraph nfa =
+dfaToDot = faToDot dfaShowAll
-  let stateMap  = Nfa.stateMap nfa
-      startNode = (-1, ())
-      startEdge = (-1, Nfa.entryState nfa, "")
-      nodes     = map (\k -> (k, ())) $ Map.keys stateMap
-      edges     = concatMap convertNfaState $ Map.assocs stateMap
-  in  mkGraph (startNode : nodes) (startEdge : edges)
 
-anyNfaToGraph :: (Ord s) => Nfa.Nfa s Char -> Gr () String
+dfaToDotNoDefault :: (Ord s, AsLabel s, Ord t, AsLabel t) => Dfa.Dfa s t -> DotGraph String
-anyNfaToGraph = nfaToGraph . Nfa.rename
+dfaToDotNoDefault = faToDot dfaShowNoDefault
 
-nfaAttributes :: Labellable el => Nfa.Nfa Int t -> GraphvizParams Int nl el () nl
+{-
-nfaAttributes nfa =
+ - 'Nfa' stuff
-  let exitStates = Nfa.exitStates nfa
+ -}
 
-      fmtNode (-1, _) = [style invis] -- Start node
+showCondition :: (AsLabel t) => Nfa.TransitionCondition t -> String
-      fmtNode ( n, _)
+showCondition (Nfa.Only s)      = asLabel s
-        | n `Set.member` exitStates = [shape DoubleCircle]
+showCondition (Nfa.AllExcept s)
-        | otherwise                 = [shape Circle]
+  | Set.null s = "Σ"
+  | otherwise  = "Σ\\" ++ asLabel s
 
-      fmtEdge (-1, _, _) = [] -- Start edge
+nfaShow :: (AsLabel t) => Nfa.State s t -> [(String, s)]
-      fmtEdge ( _, _, l) = [toLabel l]
+nfaShow state =
+  let normalEdges  = map (\(cond, s) -> (showCondition cond, s)) $ Nfa.transitions state
+      epsilonEdges = map (\s -> ("ε", s)) $ Set.toList $ Nfa.epsilonTransitions state
+  in  normalEdges ++ epsilonEdges
 
-  in  nonClusteredParams { fmtNode = fmtNode, fmtEdge = fmtEdge }
+nfaToDot :: (Ord s, AsLabel s, AsLabel t) => Nfa.Nfa s t -> DotGraph String
-
+nfaToDot = faToDot nfaShow
-nfaToDot :: Nfa.Nfa Int Char -> DotGraph Node
-nfaToDot nfa = graphToDot (nfaAttributes nfa) (nfaToGraph nfa)