Rename a DFA's and NFA's states

src/Rextra/Automaton.hs

@@ -9,6 +9,7 @@ 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
 

src/Rextra/Dfa.hs

@@ -12,11 +12,14 @@ module Rextra.Dfa (
   -- ** Executing
   , transition
   , execute
+  -- ** Renaming
+  , rename
   ) where
 
 import           Data.List
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+
 import           Rextra.Util
 
 {-
@@ -76,3 +79,25 @@ execute :: (Ord s, Ord t) => Dfa s t -> [t] -> Bool
 execute dfa tokens =
   let finalState = foldl' (transition dfa) (entryState dfa) tokens
   in  accepting $ getState dfa finalState
+
+{-
+ - Renaming
+ -}
+
+renameState :: (Ord s, Ord t) => State s t -> Rename s (State Int t)
+renameState state = do
+  newTransitions <- renameValues getName $ transitions state
+  newDefaultTransition <- getName $ defaultTransition state
+  pure $ State { transitions       = newTransitions
+               , defaultTransition = newDefaultTransition
+               , accepting         = accepting state
+               }
+
+renameAssoc :: (Ord s, Ord t) => (s, State s t) -> Rename s (Int, State Int t)
+renameAssoc (name, state) = (,) <$> getName name <*> renameState state
+
+rename :: (Ord s, Ord t) => Dfa s t -> Dfa Int t
+rename dfa = doRename $ do
+  newStateMap <- renameMap renameAssoc $ stateMap dfa
+  newEntryState <- getName $ entryState dfa
+  pure $ Dfa { stateMap = newStateMap, entryState = newEntryState }

src/Rextra/Nfa.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 module Rextra.Nfa (
   -- * Nondeterministic Finite Automaton
     Nfa
@@ -25,6 +27,8 @@ module Rextra.Nfa (
   , entryNdState
   , accepting
   , execute
+  -- ** Renaming
+  , rename
   ) where
 
 import           Data.List
@@ -186,3 +190,29 @@ execute :: (Ord s, Ord t) => Nfa s t -> [t] -> Bool
 execute nfa tokens =
   let finalNdState = foldr (transition nfa) (entryNdState nfa) tokens
   in  accepting nfa finalNdState
+
+{-
+ - Renaming
+ -}
+
+renameTransition :: (Ord s) => (TransitionCondition t, s) -> Rename s (TransitionCondition t, Int)
+renameTransition (cond, s) = (cond,) <$> getName s
+
+renameState :: (Ord s) => State s t -> Rename s (State Int t)
+renameState state = do
+  newTransitions <- mapM renameTransition $ transitions state
+  newEpsilonTransitions <- renameSet getName $ epsilonTransitions state
+  pure $ State { transitions = newTransitions, epsilonTransitions = newEpsilonTransitions }
+
+renameAssoc :: (Ord s, Ord t) => (s, State s t) -> Rename s (Int, State Int t)
+renameAssoc (name, state) = (,) <$> getName name <*> renameState state
+
+rename :: (Ord s, Ord t) => Nfa s t -> Nfa Int t
+rename nfa = doRename $ do
+  newStateMap <- renameMap renameAssoc $ stateMap nfa
+  newEntryState <- getName $ entryState nfa
+  newExitStates <- renameSet getName $ exitStates nfa
+  pure $ Nfa { stateMap   = newStateMap
+             , entryState = newEntryState
+             , exitStates = newExitStates
+             }

src/Rextra/Util.hs

@@ -1,5 +1,15 @@
+{-# LANGUAGE TupleSections #-}
+
 module Rextra.Util
   ( connectedElements
+  -- * Renaming
+  , Rename
+  , doRename
+  , getName
+  , renameSet
+  , renameMap
+  , renameKeys
+  , renameValues
   ) where
 
 import           Control.Monad
@@ -17,3 +27,30 @@ explore trans node = do
 connectedElements :: (Ord n) => (n -> Set.Set n) -> Set.Set n -> Set.Set n
 connectedElements trans startingNodes =
   flip execState Set.empty . mapM (explore trans) $ Set.toList startingNodes
+
+type Rename n = State (Int, Map.Map n Int)
+
+doRename :: Rename n a -> a
+doRename rename = evalState rename (0, Map.empty)
+
+getName :: (Ord n) => n -> Rename n Int
+getName thing = do
+  (i, names) <- get
+  case names Map.!? thing of
+    Just name -> pure name
+    Nothing   -> i <$ put (i + 1, Map.insert thing i names)
+
+renameSet :: (Ord v2) => (v1 -> Rename n v2) -> Set.Set v1 -> Rename n (Set.Set v2)
+renameSet renameFunc s = Set.fromList <$> (mapM renameFunc $ Set.toList s)
+
+renameMap :: (Ord k2)
+          => ((k1, v1) -> Rename n (k2, v2))
+          -> Map.Map k1 v1
+          -> Rename n (Map.Map k2 v2)
+renameMap f m = Map.fromList <$> (mapM f $ Map.assocs m)
+
+renameKeys :: (Ord k2) => (k1 -> Rename n k2) -> Map.Map k1 v -> Rename n (Map.Map k2 v)
+renameKeys f = renameMap (\(k, v) -> (,v) <$> f k)
+
+renameValues :: (Ord k) => (v1 -> Rename n v2) -> Map.Map k v1 -> Rename n (Map.Map k v2)
+renameValues f = renameMap (\(k, v) -> (k,) <$> f v)