diff --git a/src/Rextra/Automaton.hs b/src/Rextra/Automaton.hs index 322c5c1..784ebe1 100644 --- a/src/Rextra/Automaton.hs +++ b/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 diff --git a/src/Rextra/Dfa.hs b/src/Rextra/Dfa.hs index 1b4f375..dcb722f 100644 --- a/src/Rextra/Dfa.hs +++ b/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 } diff --git a/src/Rextra/Nfa.hs b/src/Rextra/Nfa.hs index 12a0138..698953e 100644 --- a/src/Rextra/Nfa.hs +++ b/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 + } diff --git a/src/Rextra/Util.hs b/src/Rextra/Util.hs index ceac6ab..7e2f736 100644 --- a/src/Rextra/Util.hs +++ b/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)