Adapt nfaToDfa and dfaToNfa to new types
Also, the files updated so far compile with --pedantic now :)
This commit is contained in:
parent
c99b6dcd47
commit
51dfa176ac
3 changed files with 64 additions and 52 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue