diff --git a/src/Rextra/Automaton.hs b/src/Rextra/Automaton.hs index dab5e68..322c5c1 100644 --- a/src/Rextra/Automaton.hs +++ b/src/Rextra/Automaton.hs @@ -37,7 +37,9 @@ dfaStateToNfaState s = . groupByFirst . map swap $ Map.assocs transitionMap - in defaultTransition : otherTransitions + in Nfa.State { Nfa.transitions = defaultTransition : otherTransitions + , Nfa.epsilonTransitions = Set.empty + } dfaToNfa :: (Ord s, Ord t) => Dfa.Dfa s t -> Nfa.Nfa s t dfaToNfa dfa = @@ -52,7 +54,7 @@ dfaToNfa dfa = -} allSpecialTokens :: (Ord t) => [Nfa.State s t] -> Set.Set t -allSpecialTokens = foldMap (foldMap (Nfa.specialTokens . fst)) +allSpecialTokens = foldMap (foldMap (Nfa.specialTokens . fst) . Nfa.transitions) allNextStates :: (Ord s) => Dfa.State s t -> Set.Set s allNextStates s = @@ -62,7 +64,7 @@ allNextStates s = 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 + in Dfa.State { Dfa.transitions = Map.fromSet (\t -> Nfa.transition nfa t ns) specialTokens , Dfa.defaultTransition = Nfa.defaultTransition nfa ns , Dfa.accepting = Nfa.accepting nfa ns } diff --git a/src/Rextra/Dfa.hs b/src/Rextra/Dfa.hs index 0b45877..ac9634d 100644 --- a/src/Rextra/Dfa.hs +++ b/src/Rextra/Dfa.hs @@ -1,18 +1,35 @@ -module Rextra.Dfa - ( Dfa +module Rextra.Dfa ( + -- * Deterministic Finite Automaton + Dfa + , State(..) , StateMap + -- ** Constructing , dfa , dfa' + -- ** Properties , stateMap , entryState + -- ** Executing , transition , execute - , State(..) ) where import Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Rextra.Util + +{- + - Types + -} + +data Dfa s t = Dfa + { stateMap :: StateMap s t + , entryState :: s + } deriving (Show) + +getState :: (Ord s) => Dfa s t -> s -> State s t +getState dfa s = stateMap dfa Map.! s data State s t = State { transitions :: Map.Map t s @@ -22,13 +39,8 @@ data State s t = State type StateMap s t = Map.Map s (State s t) -data Dfa s t = Dfa - { stateMap :: StateMap s t - , entryState :: s - } deriving (Show) - {- - - Constructing a DFA + - Constructing -} integrityCheck :: (Ord s) => Dfa s t -> Bool @@ -48,12 +60,9 @@ dfa' :: (Ord s) => [(s, State s t)] -> s -> Maybe (Dfa s t) dfa' states entryState = dfa (Map.fromList states) entryState {- - - "Executing" a DFA + - Executing -} -getState :: (Ord s) => Dfa s t -> s -> State s t -getState dfa s = stateMap dfa Map.! s - transition :: (Ord s, Ord t) => Dfa s t -> s -> t -> s transition dfa s t = let state = getState dfa s diff --git a/src/Rextra/Nfa.hs b/src/Rextra/Nfa.hs index 8903978..8c66dd0 100644 --- a/src/Rextra/Nfa.hs +++ b/src/Rextra/Nfa.hs @@ -1,7 +1,11 @@ module Rextra.Nfa ( -- * Nondeterministic Finite Automaton Nfa - , State + , State(..) + , StateMap + , TransitionCondition(..) + , specialTokens + , accepts -- ** Constructing , nfa , nfa' @@ -11,21 +15,20 @@ module Rextra.Nfa ( , exitStates -- ** Executing , NdState - , entryNdState , getNdState - , accepting + -- *** Transitions , transition , defaultTransition + -- *** Running the whole automaton + , entryNdState + , accepting , execute - -- *** Transition conditions - , TransitionCondition(..) - , specialTokens - , accepts ) where import Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Rextra.Util {- - Types @@ -36,7 +39,7 @@ import qualified Data.Set as Set -- 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) + { stateMap :: StateMap s t , entryState :: s , exitStates :: Set.Set s } deriving (Show) @@ -44,9 +47,12 @@ data Nfa s t = Nfa 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)] +data State s t = State + { transitions :: [(TransitionCondition t, s)] + , epsilonTransitions :: Set.Set s + } deriving (Show) + +type StateMap s t = Map.Map s (State s t) -- | This condition determines which tokens a state transition applies to. -- @@ -60,7 +66,7 @@ data TransitionCondition t deriving (Show) -- | The tokens which are treated differently from the default by the --- 'TransitionCondition'. + specialTokens :: TransitionCondition t -> Set.Set t specialTokens (Only tSet) = tSet specialTokens (AllExcept tSet) = tSet @@ -71,16 +77,17 @@ accepts (Only s) t = Set.member t s accepts (AllExcept s) t = Set.notMember t s {- - - Constructing an NFA + - Constructing -} integrityCheck :: (Ord s) => Nfa s t -> Bool integrityCheck nfa = - let referencedStates = Set.unions + let states = Map.elems $ stateMap nfa + referencedStates = Set.unions $ [ Set.singleton (entryState nfa) , exitStates nfa - , Set.fromList . map snd . concat . Map.elems $ stateMap nfa - ] + , Set.fromList . map snd $ concatMap transitions states + ] <> map epsilonTransitions states in referencedStates `Set.isSubsetOf` Map.keysSet (stateMap nfa) -- | Construct an 'Nfa' from all its components. @@ -90,10 +97,10 @@ integrityCheck nfa = -- is limited to checking whether all state names mentioned anywhere -- in the data struture actually exist in the state map. nfa :: (Ord s) - => Map.Map s (State s t) -- ^ The state lookup map (maps state name to state itself) - -> s -- ^ The entry state (starting state) - -> Set.Set s -- ^ The exit states - -> Maybe (Nfa s t) -- ^ The 'Nfa', if the data didn't show any inconsistencies + => StateMap s t -- ^ The state lookup map (maps state name to state itself) + -> s -- ^ The entry state (starting state) + -> Set.Set s -- ^ The exit states + -> Maybe (Nfa s t) -- ^ The 'Nfa', if the data didn't show any inconsistencies nfa stateMap entryState exitStates = let myNfa = Nfa{stateMap=stateMap, entryState=entryState, exitStates=exitStates} in if integrityCheck myNfa then Just myNfa else Nothing @@ -103,7 +110,7 @@ nfa' :: (Ord s) => [(s, State s t)] -> s -> [s] -> Maybe (Nfa s t) nfa' states entryState exitStates = nfa (Map.fromList states) entryState (Set.fromList exitStates) {- - - "Executing" a NFA + - Executing -} -- | The nondeterministic (nd) current state of an NFA. @@ -111,18 +118,33 @@ nfa' states entryState exitStates = nfa (Map.fromList states) entryState (Set.fr -- 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) +-- Transitions --- | 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 -nextStates state t = Set.fromList . map snd . filter (\(cond, _) -> cond `accepts` t) $ state +epsilonStep :: (Ord s) => Nfa s t -> NdState s -> NdState s +epsilonStep nfa ns = connectedElements (epsilonTransitions . getState nfa) ns + +tokenStep :: (Ord s, Ord t) => Nfa s t -> t -> NdState s -> NdState s +tokenStep nfa t ns = foldMap (nextStates t) $ getNdState nfa ns + where + nextStates :: (Ord s, Ord t) => t -> State s t -> Set.Set s + nextStates t state = Set.fromList + . map snd + . filter (\(cond, _) -> cond `accepts` t) + $ transitions state + +defaultStep :: (Ord s) => Nfa s t -> NdState s -> NdState s +defaultStep nfa ns = Set.fromList + . map snd + . filter (isAllExcept . fst) + . concatMap transitions + $ getNdState nfa ns + where + isAllExcept :: TransitionCondition t -> Bool + isAllExcept (AllExcept _) = True + isAllExcept _ = False -- | The NFA's transition function. -- @@ -133,21 +155,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 -> NdState s -> t -> NdState s -transition nfa ns t = foldMap (\s -> nextStates s t) $ getNdState nfa ns +transition :: (Ord s, Ord t) => Nfa s t -> t -> NdState s -> NdState s +transition nfa t = epsilonStep nfa . tokenStep nfa t . epsilonStep nfa 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 +defaultTransition nfa = epsilonStep nfa . defaultStep nfa . epsilonStep nfa + +-- Actually executing + +entryNdState :: Nfa s t -> NdState s +entryNdState = Set.singleton . entryState + +accepting :: (Ord s) => Nfa s t -> NdState s -> Bool +accepting nfa ns = not $ Set.disjoint ns (exitStates nfa) execute :: (Ord s, Ord t) => Nfa s t -> [t] -> Bool execute nfa tokens = - let finalNdState = foldl' (transition nfa) (entryNdState nfa) tokens + let finalNdState = foldr (transition nfa) (entryNdState nfa) tokens in accepting nfa finalNdState diff --git a/src/Rextra/Util.hs b/src/Rextra/Util.hs new file mode 100644 index 0000000..ceac6ab --- /dev/null +++ b/src/Rextra/Util.hs @@ -0,0 +1,19 @@ +module Rextra.Util + ( connectedElements + ) where + +import Control.Monad +import Control.Monad.Trans.State +import qualified Data.Map as Map +import qualified Data.Set as Set + +explore :: (Ord n) => (n -> Set.Set n) -> n -> State (Set.Set n) () +explore trans node = do + visited <- get + unless (node `Set.member` visited) $ do + modify (Set.insert node) + mapM_ (explore trans) . Set.toList $ trans node + +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