Implement Dfa using Fa

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)

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)

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