From 11f0f68513d6f63dfb5d3cc39e43d85dce861351 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Fri, 25 Oct 2019 15:06:52 +0000
Subject: [PATCH] Convert between DFA and NFA

---
 src/Rextra/Automaton.hs | 92 +++++++++++++++++++++++++++++++++++++++++
 src/Rextra/Dfa.hs       |  7 +++-
 src/Rextra/Nfa.hs       | 92 ++++++++++++++++++++++++++++-------------
 3 files changed, 160 insertions(+), 31 deletions(-)
 create mode 100644 src/Rextra/Automaton.hs

diff --git a/src/Rextra/Automaton.hs b/src/Rextra/Automaton.hs
new file mode 100644
index 0000000..dab5e68
--- /dev/null
+++ b/src/Rextra/Automaton.hs
@@ -0,0 +1,92 @@
+module Rextra.Automaton
+  ( dfaToNfa
+  , nfaToDfa
+  ) where
+
+import           Control.Monad.Trans.State
+import           Data.List
+import qualified Data.Map.Strict as Map
+import           Data.Maybe
+import qualified Data.Set as Set
+import           Data.Tuple
+import qualified Rextra.Dfa as Dfa
+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
+      specialTokens = Map.keysSet transitionMap
+      defaultTransition = (Nfa.AllExcept specialTokens, Dfa.defaultTransition s)
+      otherTransitions = map (\(tSet, s) -> (Nfa.Only tSet, s))
+                       . map swap
+                       . groupByFirst
+                       . map swap
+                       $ Map.assocs transitionMap
+  in  defaultTransition : otherTransitions
+
+dfaToNfa :: (Ord s, Ord t) => Dfa.Dfa s t -> Nfa.Nfa s t
+dfaToNfa dfa =
+  let stateMap = Dfa.stateMap dfa
+      exitingStates = map fst . filter (\(s, state) -> Dfa.accepting state) $ Map.assocs stateMap
+      nfaStateMap = Map.map dfaStateToNfaState stateMap
+  -- The NFA was created from a valid DFA, so it will be valid too.
+  in  fromJust $ Nfa.nfa nfaStateMap (Dfa.entryState dfa) (Set.fromList exitingStates)
+
+{-
+ - Converting a NFA to a DFA
+ -}
+
+allSpecialTokens :: (Ord t) => [Nfa.State s t] -> Set.Set t
+allSpecialTokens = foldMap (foldMap (Nfa.specialTokens . fst))
+
+allNextStates :: (Ord s) => Dfa.State s t -> Set.Set s
+allNextStates s =
+  let nextStates = Map.elems $ Dfa.transitions s
+  in  Set.fromList (Dfa.defaultTransition s : nextStates)
+
+ndStateToDfaState :: (Ord s, Ord t) => Nfa.Nfa s t -> Nfa.NdState s -> Dfa.State (Nfa.NdState s) t
+ndStateToDfaState nfa ns =
+  let specialTokens = allSpecialTokens $ Nfa.getNdState nfa ns
+  in  Dfa.State { Dfa.transitions       = Map.fromSet (Nfa.transition nfa ns) specialTokens
+                , Dfa.defaultTransition = Nfa.defaultTransition nfa ns
+                , Dfa.accepting         = Nfa.accepting nfa ns
+                }
+
+type Visited s = Set.Set (Nfa.NdState s)
+
+exploreState :: (Ord s, Ord t)
+             => Nfa.Nfa s t
+             -> Nfa.NdState s
+             -> State (Visited s) (Dfa.StateMap (Nfa.NdState s) t)
+exploreState nfa ns = do
+  visitedStates <- get
+  if ns `Set.member` visitedStates
+    then pure Map.empty
+    else do
+      modify (Set.insert ns) -- Adding this state to the visited states
+      let dfaState    = ndStateToDfaState nfa ns
+          ownStateMap = Map.singleton ns dfaState
+          nextStates  = Set.toList $ allNextStates dfaState
+      otherStateMaps <- mapM (exploreState nfa) nextStates
+      pure $ Map.unions (ownStateMap : otherStateMaps)
+
+dfaStateMap :: (Ord s, Ord t) => Nfa.Nfa s t -> Dfa.StateMap (Nfa.NdState s) t
+dfaStateMap nfa = evalState (exploreState nfa (Nfa.entryNdState nfa)) Set.empty
+
+nfaToDfa :: (Ord s, Ord t) => Nfa.Nfa s t -> Dfa.Dfa (Nfa.NdState s) t
+nfaToDfa nfa = fromJust $ Dfa.dfa (dfaStateMap nfa) (Nfa.entryNdState nfa)
diff --git a/src/Rextra/Dfa.hs b/src/Rextra/Dfa.hs
index 6196d22..0b45877 100644
--- a/src/Rextra/Dfa.hs
+++ b/src/Rextra/Dfa.hs
@@ -1,5 +1,6 @@
 module Rextra.Dfa
   ( Dfa
+  , StateMap
   , dfa
   , dfa'
   , stateMap
@@ -19,8 +20,10 @@ data State s t = State
   , accepting         :: Bool
   } deriving (Show)
 
+type StateMap s t = Map.Map s (State s t)
+
 data Dfa s t = Dfa
-  { stateMap   :: Map.Map s (State s t)
+  { stateMap   :: StateMap s t
   , entryState :: s
   } deriving (Show)
 
@@ -36,7 +39,7 @@ integrityCheck dfa =
       referencedStates = Set.fromList $ concat [[entryState dfa], transitionStates, defaultTransitionStates]
   in  referencedStates `Set.isSubsetOf` Map.keysSet (stateMap dfa)
 
-dfa :: (Ord s) => Map.Map s (State s t) -> s -> Maybe (Dfa s t)
+dfa :: (Ord s) => StateMap s t -> s -> Maybe (Dfa s t)
 dfa stateMap entryState =
   let myDfa = Dfa{stateMap=stateMap, entryState=entryState}
   in  if integrityCheck myDfa then Just myDfa else Nothing
diff --git a/src/Rextra/Nfa.hs b/src/Rextra/Nfa.hs
index 4a2638e..8903978 100644
--- a/src/Rextra/Nfa.hs
+++ b/src/Rextra/Nfa.hs
@@ -5,15 +5,21 @@ module Rextra.Nfa (
   -- ** Constructing
   , nfa
   , nfa'
-  -- ** Using
+  -- ** Properties
   , stateMap
   , entryState
   , exitStates
+  -- ** Executing
+  , NdState
+  , entryNdState
+  , getNdState
+  , accepting
   , transition
+  , defaultTransition
   , execute
-  -- ** Transitions
+  -- *** Transition conditions
   , TransitionCondition(..)
-  , specialStates
+  , specialTokens
   , accepts
   ) where
 
@@ -21,6 +27,27 @@ import           Data.List
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
+{-
+ - Types
+ -}
+
+-- | A type representing a nondeterministic finite automaton.
+--
+-- It has one entry state and any number of exit states, which can be
+-- interpreted as accepting states when the NFA is run.
+data Nfa s t = Nfa
+  { stateMap   :: Map.Map s (State s t)
+  , entryState :: s
+  , exitStates :: Set.Set s
+  } deriving (Show)
+
+getState :: (Ord s) => Nfa s t -> s -> State s t
+getState nfa s = stateMap nfa Map.! s
+
+-- | A state consists of the transitions to other states, and the
+-- conditions under which those transitions happen.
+type State s t = [(TransitionCondition t, s)]
+
 -- | This condition determines which tokens a state transition applies to.
 --
 -- This representation is based on the assumption that there can be an
@@ -32,33 +59,19 @@ data TransitionCondition t
   | AllExcept (Set.Set t)
   deriving (Show)
 
--- | The states which are treated differently from the default by the
+-- | The tokens which are treated differently from the default by the
 -- 'TransitionCondition'.
-specialStates :: TransitionCondition t -> Set.Set t
-specialStates (Only s)      = s
-specialStates (AllExcept s) = s
+specialTokens :: TransitionCondition t -> Set.Set t
+specialTokens (Only tSet)      = tSet
+specialTokens (AllExcept tSet) = tSet
 
 -- | Whether the condition holds true for a token.
 accepts :: (Ord t) => TransitionCondition t -> t -> Bool
 accepts (Only s)      t = Set.member t s
 accepts (AllExcept s) t = Set.notMember t s
 
--- | A state consists of the transitions to other states, and the
--- conditions under which those transitions happen.
-type State s t = [(TransitionCondition t, s)]
-
--- | A type representing a nondeterministic finite automaton.
---
--- It has one entry state and any number of exit states, which can be
--- interpreted as accepting states when the NFA is run.
-data Nfa s t = Nfa
-  { stateMap   :: Map.Map s (State s t)
-  , entryState :: s
-  , exitStates :: Set.Set s
-  } deriving (Show)
-
 {-
- - Constructing a NFA
+ - Constructing an NFA
  -}
 
 integrityCheck :: (Ord s) => Nfa s t -> Bool
@@ -93,8 +106,19 @@ nfa' states entryState exitStates = nfa (Map.fromList states) entryState (Set.fr
  - "Executing" a NFA
  -}
 
-getState :: (Ord s) => Nfa s t -> s -> State s t
-getState nfa s = stateMap nfa Map.! s
+-- | The nondeterministic (nd) current state of an NFA.
+--
+-- This type is used when executing a NFA.
+type NdState s = Set.Set s
+
+entryNdState :: Nfa s t -> NdState s
+entryNdState = Set.singleton . entryState
+
+getNdState :: (Ord s) => Nfa s t -> NdState s -> [State s t]
+getNdState nfa ns = map (getState nfa) $ Set.toList ns
+
+accepting :: (Ord s) => Nfa s t -> NdState s -> Bool
+accepting nfa ns = not $ Set.disjoint ns (exitStates nfa)
 
 -- | Starting from a state, find all the states that it can transition to with token @t@.
 nextStates :: (Ord s, Ord t) => State s t -> t -> Set.Set s
@@ -109,11 +133,21 @@ nextStates state t = Set.fromList . map snd . filter (\(cond, _) -> cond `accept
 -- __Warning__: This function does /not/ check whether the states
 -- actually exist in the automaton, and it crashes if an invalid state
 -- is used.
-transition :: (Ord s, Ord t) => Nfa s t -> Set.Set s -> t -> Set.Set s
-transition nfa ss t = foldMap (\s -> nextStates (getState nfa s) t) ss
+transition :: (Ord s, Ord t) => Nfa s t -> NdState s -> t -> NdState s
+transition nfa ns t = foldMap (\s -> nextStates s t) $ getNdState nfa ns
+
+defaultTransition :: (Ord s) => Nfa s t -> NdState s -> NdState s
+defaultTransition nfa ns = Set.fromList
+                         . map snd
+                         . filter (isAllExcept . fst)
+                         . concat
+                         $ getNdState nfa ns
+  where
+    isAllExcept :: TransitionCondition t -> Bool
+    isAllExcept (AllExcept _) = True
+    isAllExcept _             = False
 
 execute :: (Ord s, Ord t) => Nfa s t -> [t] -> Bool
 execute nfa tokens =
-  let entryStates = Set.singleton $ entryState nfa
-      finalStates = foldl' (transition nfa) entryStates tokens
-  in  not $ Set.disjoint finalStates (exitStates nfa)
+  let finalNdState = foldl' (transition nfa) (entryNdState nfa) tokens
+  in  accepting nfa finalNdState