diff --git a/src/Rextra/Dfa.hs b/src/Rextra/Dfa.hs index dc4f9ba..b8e54ba 100644 --- a/src/Rextra/Dfa.hs +++ b/src/Rextra/Dfa.hs @@ -1,21 +1,12 @@ -module Rextra.Dfa ( - -- * Deterministic Finite Automaton - Dfa - , State(..) - , StateMap - -- ** Constructing +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Rextra.Dfa + ( Dfa , dfa - , dfa' - -- ** Properties - , stateMap - , entryState - , exitStates + , State(..) , transitionsByState - -- ** Executing - , transition - , execute - -- ** Renaming - , rename ) where import Data.List @@ -23,105 +14,40 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Tuple +import Rextra.Fa 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 - -exitStates :: (Ord s) => Dfa s t -> Set.Set s -exitStates dfa = Set.fromList - . map fst - . filter (accepting . snd) - . Map.assocs - $ stateMap dfa +-- State stuff data State s t = State { transitions :: Map.Map t s , defaultTransition :: s - , accepting :: Bool } deriving (Show) -type StateMap s t = Map.Map s (State s t) +instance FaState State where + canReach State{transitions, defaultTransition} = + Set.fromList $ defaultTransition : Map.elems transitions -fromMonoidalList :: (Monoid m, Ord k) => [(k, m)] -> Map.Map k m -fromMonoidalList = foldl' insertMonoidal Map.empty - where - insertMonoidal :: (Monoid m, Ord k) => Map.Map k m -> (k, m) -> Map.Map k m - insertMonoidal map (k, m) = Map.insertWith mappend k m map +transitionsByState :: (Ord s, Ord t) => State s t -> Map.Map s (Set.Set t) +transitionsByState = groupByFirst . map swap . Map.assocs . transitions -groupByFirst :: (Ord a, Ord b) => [(a, b)] -> Map.Map a (Set.Set b) -groupByFirst pairs = - let prepared = map (\(a, b) -> (a, Set.singleton b)) pairs - in fromMonoidalList prepared +-- Dfa stuff -transitionsByState :: (Ord s, Ord t) => Map.Map t s -> Map.Map s (Set.Set t) -transitionsByState = groupByFirst . map swap . Map.assocs +type Dfa s t = Fa State s t -{- - - Constructing - -} +instance (Ord s) => Executable (Fa State s) s where + startState = entryState + transition = dfaTransition + accepts a s = s `Set.member` exitStates a -integrityCheck :: (Ord s) => Dfa s t -> Bool -integrityCheck dfa = - let states = Map.elems $ stateMap dfa - transitionStates = concatMap (Map.elems . transitions) states - defaultTransitionStates = map defaultTransition states - referencedStates = Set.fromList $ concat [[entryState dfa], transitionStates, defaultTransitionStates] - in referencedStates `Set.isSubsetOf` Map.keysSet (stateMap dfa) - -dfa :: (Ord s) => StateMap s t -> s -> Maybe (Dfa s t) -dfa stateMap entryState = - let myDfa = Dfa{stateMap=stateMap, entryState=entryState} - in if integrityCheck myDfa then Just myDfa else Nothing - -dfa' :: (Ord s, Ord t) => [(s, [(t, s)], s, Bool)] -> s -> Maybe (Dfa s t) -dfa' states entryState = - let stateList = map (\(s, ts, dt, a) -> (s, State (Map.fromList ts) dt a)) states - in dfa (Map.fromList stateList) entryState - -{- - - Executing - -} - -transition :: (Ord s, Ord t) => Dfa s t -> s -> t -> s -transition dfa s t = - let state = getState dfa s +dfaTransition :: (Ord s, Ord t) => Dfa s t -> s -> t -> s +dfaTransition a s t = + let state = getState a s in case transitions state Map.!? t of (Just nextState) -> nextState Nothing -> defaultTransition state -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 } +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 + in fa (Map.fromList stateList) entryState (Set.fromList exitStates) diff --git a/src/Rextra/Fa.hs b/src/Rextra/Fa.hs index 51c47a0..e1b9389 100644 --- a/src/Rextra/Fa.hs +++ b/src/Rextra/Fa.hs @@ -4,8 +4,9 @@ -- | This module contains ways to represent finite automata and their -- execution/evaluation. -module Rextra.Fa - ( FaState(..) +module Rextra.Fa ( + -- * Finite automata + FaState(..) , Fa , fa , stateMap @@ -13,6 +14,7 @@ module Rextra.Fa , exitStates , states , getState + -- * Executing automata , Executable(..) , transitionAll , execute @@ -22,11 +24,15 @@ import Data.List import qualified Data.Map as Map import qualified Data.Set as Set +{- + - Finite automata + -} + -- | The state of a finite automaton. class FaState state where -- | All the states that can be reached (by any sort of transition) -- from this state. - canReach :: state s t -> Set.Set s + canReach :: (Ord s) => state s t -> Set.Set s -- | A finite automaton. data Fa state s t = Fa @@ -38,7 +44,7 @@ data Fa state s t = Fa , exitStates :: Set.Set s -- ^ The automaton's accepting states, i. e. the states that -- determine whether the automaton accepts a certain word. - } + } deriving (Show) -- | @'states' fa@ are the identifiers of all states contained in @fa@. states :: Fa state s t -> Set.Set s @@ -67,19 +73,23 @@ fa stateMap entryState exitStates = let potentialFa = Fa{stateMap, entryState, exitStates} in if integrityCheck potentialFa then Just potentialFa else Nothing +{- + - Executing + -} + -- | A special type class for automata that can be executed. These -- automata must not necessarily be finite. class Executable a execState where -- | The state at which execution of the automaton begins. - startState :: a s t -> execState + startState :: a t -> execState -- | A function that determines the automaton's next state based on -- a token. - transition :: a s t -> execState -> t -> execState - -- | Whether the automaton acceps - accepts :: a s t -> execState -> Bool + transition :: (Ord t) => a t -> execState -> t -> execState + -- | Whether the automaton accepts the execution state. + accepts :: a t -> execState -> Bool -- | Perform all transitions corresponding to a word (or list) of tokens, in order. -transitionAll :: (Executable a execState) => a s t -> execState -> [t] -> execState +transitionAll :: (Executable a execState, Ord t) => a t -> execState -> [t] -> execState transitionAll a = foldl' (transition a) -- | Like 'transitionAll', starting with the automaton's 'startState'. @@ -88,5 +98,5 @@ transitionAll a = foldl' (transition a) -- 'accepts' like this: -- -- > a `accepts` execute a w -execute :: (Executable a execState) => a s t -> [t] -> execState +execute :: (Executable a execState, Ord t) => a t -> [t] -> execState execute a = transitionAll a (startState a) diff --git a/src/Rextra/Util.hs b/src/Rextra/Util.hs index 7e2f736..4774d4e 100644 --- a/src/Rextra/Util.hs +++ b/src/Rextra/Util.hs @@ -10,10 +10,14 @@ module Rextra.Util , renameMap , renameKeys , renameValues + -- * Grouping + , fromMonoidalList + , groupByFirst ) where import Control.Monad import Control.Monad.Trans.State +import Data.List import qualified Data.Map as Map import qualified Data.Set as Set @@ -54,3 +58,14 @@ 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) + +fromMonoidalList :: (Monoid m, Ord k) => [(k, m)] -> Map.Map k m +fromMonoidalList = foldl' insertMonoidal Map.empty + where + insertMonoidal :: (Monoid v, Ord k) => Map.Map k v -> (k, v) -> Map.Map k v + insertMonoidal m (k, v) = Map.insertWith mappend k v m + +groupByFirst :: (Ord a, Ord b) => [(a, b)] -> Map.Map a (Set.Set b) +groupByFirst pairs = + let prepared = map (\(a, b) -> (a, Set.singleton b)) pairs + in fromMonoidalList prepared