From 51dfa176acf707432f0bdb8c035b4fe698bdebf2 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 30 Oct 2019 18:09:30 +0000 Subject: [PATCH] Adapt nfaToDfa and dfaToNfa to new types Also, the files updated so far compile with --pedantic now :) --- src/Rextra/Automaton.hs | 93 ++++++++++++++++++++++------------------- src/Rextra/Dfa.hs | 5 +-- src/Rextra/Nfa.hs | 18 +++++--- 3 files changed, 64 insertions(+), 52 deletions(-) diff --git a/src/Rextra/Automaton.hs b/src/Rextra/Automaton.hs index db0ed17..33f284e 100644 --- a/src/Rextra/Automaton.hs +++ b/src/Rextra/Automaton.hs @@ -1,17 +1,19 @@ +{-# LANGUAGE ScopedTypeVariables #-} + 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 Rextra.Fa import qualified Rextra.Nfa as Nfa +import Rextra.Util {- - Converting a DFA to a NFA @@ -19,65 +21,68 @@ import qualified Rextra.Nfa as Nfa dfaStateToNfaState :: (Ord s, Ord t) => Dfa.State s t -> Nfa.State s t dfaStateToNfaState s = - let transitionMap = Dfa.transitions s - specialTokens = Map.keysSet transitionMap + let specialTokens = Map.keysSet $ Dfa.transitions s defaultTransition = (Nfa.AllExcept specialTokens, Dfa.defaultTransition s) - otherTransitions = map (\(tSet, s) -> (Nfa.Only tSet, s)) - . map swap - . Map.assocs - $ Dfa.transitionsByState transitionMap + otherTransitions = map (\(tokenSet, state) -> (Nfa.Only tokenSet, state)) + $ map swap + $ Map.assocs + $ Dfa.transitionsByState s 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 = - let stateMap = Dfa.stateMap dfa - exitStates = Dfa.exitStates dfa - nfaStateMap = Map.map dfaStateToNfaState stateMap +dfaToNfa a = + let nfaStateMap = Map.map dfaStateToNfaState $ stateMap a -- The NFA was created from a valid DFA, so it will be valid too. - in fromJust $ Nfa.nfa nfaStateMap (Dfa.entryState dfa) exitStates + in fromJust $ fa nfaStateMap (entryState a) (exitStates a) {- - Converting a NFA to a DFA -} -allSpecialTokens :: (Ord t) => [Nfa.State s t] -> Set.Set t -allSpecialTokens = foldMap (foldMap (Nfa.specialTokens . fst) . Nfa.transitions) +specialTokensOf :: Nfa.TransitionCondition t -> Set.Set t +specialTokensOf (Nfa.Only t) = t +specialTokensOf (Nfa.AllExcept t) = t -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) +-- | @'allSpecialTokens' a ns@ returns all tokens that behave +-- different from the default when when in state @ns@ of the automaton +-- @a@ (the default being an implicitly defined token that is not +-- mentioned in any of the automaton's state transitions). +specialTokensAt :: (Ord s, Ord t) => Nfa.Nfa s t -> Nfa.NdState s -> Set.Set t +specialTokensAt a ns = + let ndStates = Nfa.getNdState a $ Nfa.epsilonStep a ns + in foldMap (foldMap (specialTokensOf . fst) . Nfa.transitions) ndStates + +possibleTransitionsFrom :: (Ord s, Ord t) + => Nfa.Nfa s t -> Nfa.NdState s -> Map.Map t (Nfa.NdState s) +possibleTransitionsFrom a ns = Map.fromSet (transition a ns) (specialTokensAt a ns) 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 $ Nfa.epsilonStep nfa ns - 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 - } +ndStateToDfaState a ns = + Dfa.State { Dfa.transitions = possibleTransitionsFrom a ns + , Dfa.defaultTransition = Nfa.defaultTransition a ns + } -type Visited s = Set.Set (Nfa.NdState s) +nextStatesFrom :: (Ord s, Ord t) => Nfa.Nfa s t -> Nfa.NdState s -> Set.Set (Nfa.NdState s) +nextStatesFrom a ns = + let tokenTransitioned = Map.elems $ possibleTransitionsFrom a ns + defaultTransitioned = Nfa.defaultTransition a ns + in Set.fromList $ defaultTransitioned : tokenTransitioned -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) +-- This whole forall business is just so I can tell the Execute +-- typeclass that I mean Nfa.NdState when I say startState a. +connectedStates :: forall s t. (Ord s, Ord t) => Nfa.Nfa s t -> Set.Set (Nfa.NdState s) +connectedStates a = + let start = Set.singleton (startState a :: Nfa.NdState s) + in connectedElements (nextStatesFrom a) start -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 +dfaStateMap :: (Ord s, Ord t) + => Nfa.Nfa s t -> Map.Map (Nfa.NdState s) (Dfa.State (Nfa.NdState s) t) +dfaStateMap a = Map.fromSet (ndStateToDfaState a) $ connectedStates a 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) +nfaToDfa a = + let theStateMap = dfaStateMap a + acceptingStates = Set.filter (Nfa.isAccepting a) $ Map.keysSet theStateMap + in fromJust $ fa theStateMap (startState a) acceptingStates diff --git a/src/Rextra/Dfa.hs b/src/Rextra/Dfa.hs index b8e54ba..817ff16 100644 --- a/src/Rextra/Dfa.hs +++ b/src/Rextra/Dfa.hs @@ -9,7 +9,6 @@ module Rextra.Dfa , transitionsByState ) where -import Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Tuple @@ -48,6 +47,6 @@ dfaTransition a s t = Nothing -> defaultTransition state dfa :: (Ord s, Ord t) => [(s, [(t, s)], s)] -> s -> [s] -> Maybe (Dfa s t) -dfa states entryState exitStates = - let stateList = map (\(s, ts, dt) -> (s, State (Map.fromList ts) dt)) states +dfa stateInfo entryState exitStates = + let stateList = map (\(s, ts, dt) -> (s, State (Map.fromList ts) dt)) stateInfo in fa (Map.fromList stateList) entryState (Set.fromList exitStates) diff --git a/src/Rextra/Nfa.hs b/src/Rextra/Nfa.hs index b872b81..631590e 100644 --- a/src/Rextra/Nfa.hs +++ b/src/Rextra/Nfa.hs @@ -14,6 +14,7 @@ module Rextra.Nfa , holdsTrueForDefault -- * Executing , NdState + , isAccepting , getNdState , epsilonStep , defaultTransition @@ -61,10 +62,17 @@ instance FaState State where type Nfa s t = Fa State s t type NdState s = Set.Set s +-- Not the most brilliant of names, very similar to Executable's +-- 'accepts'. But I'd rather repeat myself in this way than +-- reimplement this predicate everywhere I need it (e. g. in +-- 'nfaToDfa' in Automaton.hs). +isAccepting :: (Ord s) => Nfa s t -> NdState s -> Bool +isAccepting a ns = not $ ns `Set.disjoint` exitStates a + instance (Ord s) => Executable (Fa State s) (Set.Set s) where startState = Set.singleton . entryState transition = nfaTransition - accepts a s = not $ s `Set.disjoint` exitStates a + accepts = isAccepting only :: (Ord t) => [t] -> TransitionCondition t only = Only . Set.fromList @@ -77,8 +85,8 @@ nfa :: (Ord s) -> s -> [s] -> Maybe (Nfa s t) -nfa states entryState exitStates = - let stateList = map (\(s, ts, et) -> (s, State ts (Set.fromList et))) states +nfa stateInfo entryState exitStates = + let stateList = map (\(s, ts, et) -> (s, State ts (Set.fromList et))) stateInfo in fa (Map.fromList stateList) entryState (Set.fromList exitStates) -- Transitions @@ -93,9 +101,9 @@ tokenStep :: (Ord s, Ord t) => Nfa s t -> t -> NdState s -> NdState s tokenStep a t ns = foldMap (nextStates t) $ getNdState a ns where nextStates :: (Ord s, Ord t) => t -> State s t -> Set.Set s - nextStates t state = Set.fromList + nextStates token state = Set.fromList $ map snd - $ filter (\(cond, _) -> cond `holdsTrueFor` t) + $ filter (\(cond, _) -> cond `holdsTrueFor` token) $ transitions state defaultStep :: (Ord s) => Nfa s t -> NdState s -> NdState s