Slightly change DFA visualization

Transitions to the same state are now clumped together as one arrow.

src/Rextra/Automaton.hs

@@ -17,17 +17,6 @@ import qualified Rextra.Nfa as Nfa
  - Converting a DFA to a NFA
  -}
 
-fromMonoidalList :: (Monoid m, Ord k) => [(k, m)] -> Map.Map k m
-fromMonoidalList = foldl' insertMonoidal Map.empty
-  where
-    insertMonoidal :: (Monoid m, Ord k) => Map.Map k m -> (k, m) -> Map.Map k m
-    insertMonoidal map (k, m) = Map.insertWith mappend k m map
-
-groupByFirst :: (Ord a, Ord b) => [(a, b)] -> [(a, Set.Set b)]
-groupByFirst pairs =
-  let prepared = map (\(a, b) -> (a, Set.singleton b)) pairs
-  in  Map.assocs $ fromMonoidalList prepared
-
 dfaStateToNfaState :: (Ord s, Ord t) => Dfa.State s t -> Nfa.State s t
 dfaStateToNfaState s =
   let transitionMap = Dfa.transitions s
@@ -35,9 +24,8 @@ dfaStateToNfaState s =
       defaultTransition = (Nfa.AllExcept specialTokens, Dfa.defaultTransition s)
       otherTransitions = map (\(tSet, s) -> (Nfa.Only tSet, s))
                        . map swap
-                       . groupByFirst
+                       . Map.assocs
-                       . map swap
+                       $ Dfa.transitionsByState transitionMap
-                       $ Map.assocs transitionMap
   in  Nfa.State { Nfa.transitions        = defaultTransition : otherTransitions
                 , Nfa.epsilonTransitions = Set.empty
                 }

src/Rextra/Dfa.hs

@@ -10,6 +10,7 @@ module Rextra.Dfa (
   , stateMap
   , entryState
   , exitStates
+  , transitionsByState
   -- ** Executing
   , transition
   , execute
@@ -20,6 +21,7 @@ module Rextra.Dfa (
 import           Data.List
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import           Data.Tuple
 
 import           Rextra.Util
 
@@ -50,6 +52,20 @@ data State s t = State
 
 type StateMap s t = Map.Map s (State s t)
 
+fromMonoidalList :: (Monoid m, Ord k) => [(k, m)] -> Map.Map k m
+fromMonoidalList = foldl' insertMonoidal Map.empty
+  where
+    insertMonoidal :: (Monoid m, Ord k) => Map.Map k m -> (k, m) -> Map.Map k m
+    insertMonoidal map (k, m) = Map.insertWith mappend k m map
+
+groupByFirst :: (Ord a, Ord b) => [(a, b)] -> Map.Map a (Set.Set b)
+groupByFirst pairs =
+  let prepared = map (\(a, b) -> (a, Set.singleton b)) pairs
+  in  fromMonoidalList prepared
+
+transitionsByState :: (Ord s, Ord t) => Map.Map t s -> Map.Map s (Set.Set t)
+transitionsByState = groupByFirst . map swap . Map.assocs
+
 {-
  - Constructing
  -}

src/Rextra/Visualize.hs

@@ -28,14 +28,20 @@ saveDot format path dg = void $ runGraphviz dg format path
 saveDotAsPng :: String -> DotGraph Node -> IO ()
 saveDotAsPng = saveDot Png
 
+labelFromSet :: Set.Set Char -> String
+labelFromSet charSet = "{" ++ intersperse ',' (Set.toList charSet) ++ "}"
+
 {-
  - Visualizing DFAs
  -}
 
 convertDfaState :: (Int, Dfa.State Int Char) -> [LEdge String]
 convertDfaState (from, state) =
-  let normalEdges = map (\(t, to) -> (from, to, [t])) . Map.assocs $ Dfa.transitions state
+  let normalEdges = map (\(to, tSet) -> (from, to, labelFromSet tSet))
-      defaultEdge = (from, Dfa.defaultTransition state, "**")
+                  . Map.assocs
+                  . Dfa.transitionsByState
+                  $ Dfa.transitions state
+      defaultEdge = (from, Dfa.defaultTransition state, "*")
   in  defaultEdge : normalEdges
 
 -- | Convert a 'Dfa.Dfa' to a 'Gr' graph.
@@ -71,9 +77,6 @@ dfaToDot dfa = graphToDot (dfaAttributes dfa) (dfaToGraph dfa)
  - Visualizing NFAs
  -}
 
-labelFromSet :: Set.Set Char -> String
-labelFromSet charSet = "{" ++ intersperse ',' (Set.toList charSet) ++ "}"
-
 labelFromCondition :: Nfa.TransitionCondition Char -> String
 labelFromCondition (Nfa.Only charSet)      = labelFromSet charSet
 labelFromCondition (Nfa.AllExcept charSet)