{- | Finite state machines. Here an 'FSM' is a map from symbols to actions. Symbols are parametric (will usually be Strings or Chars). 'Action's specify the action of a symbol on each state, and are represented as lists of transitions: one per state. States are just numbers, from 0 to n, corresponding to indices on transition lists in 'Action's. Then deterministic actions are just Ints, identifying the state to transition to under that action; nondeterministic actions are lists of Ints: all the states to possibly transition to under that action. -} -- Copyright (c) 2009 Andy Gimblett - http://www.cs.swan.ac.uk/~csandy/ -- BSD Licence (see http://www.opensource.org/licenses/bsd-license.php) module Data.FsmActions (-- * Data types State, DestinationSet(..), Action(..), FSM(..), Word(..), -- * Simple FSM operations states, alphabet, fsmAction, -- * Well-formedness WellFormed(..), isWellFormed, -- * Normalisation normalise, normaliseAction, -- * Operations on actions mkAction, mkDAction, append, actionLookup, action, actionEquiv, -- * Destination sets destinationSet, destinationEquiv, -- * Identity fsmIdentity, -- * Determinism isDAction, isDFSM ) where import Control.Arrow (second) import Control.Monad import qualified Data.List as L import qualified Data.Map as M -- | States are integers, counting from zero. type State = Int -- Could be parametric (as in HaLeX), but for now, YAGNI. -- | Destination sets are just lists of 'State's. newtype DestinationSet = DestinationSet { destinations :: [State] } deriving (Eq, Ord, Show) -- | Actions are lists of 'DestinationSets', indexed by source -- 'State'. newtype Action = Action { destinationSets :: [DestinationSet] } deriving (Eq, Ord, Show) -- | Finite state machine whose nodes are labelled with type sy. newtype FSM sy = FSM { unFSM :: M.Map sy Action } deriving (Eq, Ord, Show) -- | Words are lists of symbols. newtype Word sy = Word [sy] -- | Compute the list of states of the 'FSM'. Only really meaningful -- if the FSM's well-formedness is not 'BadLengths'. With current -- implementation, is just [0..n] for some n (or empty). states :: FSM sy -> [State] states fsm = case M.elems (unFSM fsm) of ((Action ds):_) -> [0..length ds-1] _ -> [] -- | Compute the alphabet of an 'FSM'. alphabet :: FSM sy -> [sy] alphabet = M.keys . unFSM -- | Look up a symbol's 'Action' in an 'FSM' fsmAction :: Ord sy => sy -> FSM sy -> Maybe Action fsmAction sy = M.lookup sy . unFSM -- | An 'FSM' is well-formed if all its actions are the same length, -- and none of its actions contain destinations which are out of -- range. data WellFormed sy -- | 'FSM' is well-formed. (Carries an empty list: this is a slight -- wart, as no cargo is necessary; unfortunately, fixing that -- would require use of a GADT here, which seems excessive.) = WellFormed [sy] -- | Lengths of Actions in the 'FSM' don't all match. Carries a -- sorted list of (symbol, 'Action' length) pairs, one for every -- symbol in the alphabet of the 'FSM'. | BadLengths [(sy, Int)] -- | Some 'Action's contain out-of-range (negative or too-high) -- destinations. Carries a sorted list of all such actions and -- their corresponding symbols. | BadActions [(sy, Action)] deriving (Eq, Show) -- | Check if an 'FSM' is well-formed or not. isWellFormed :: Ord sy => FSM sy -> WellFormed sy isWellFormed fsm = if not $ allSame $ L.map snd actionLengths then BadLengths (L.sort actionLengths) else if not $ M.null badParts then BadActions (L.sort $ M.toList badParts) else WellFormed [] where -- All (symbol, Action length) pairs in FSM. actionLengths = L.map (second aLength) (M.toList $ unFSM fsm) -- Submap containing only Actions with bad destinations. badParts = M.filter isBad $ unFSM fsm -- Check if an Action has any bad destinations. isBad a = any badDest (flatten a) where -- Flatten lists of destination states in an Action. flatten (Action xs) = L.concat $ map destinations xs -- Check if a destination is bad (negative or too high). badDest x = (x<0) || (x >= (length $ states fsm)) -- Compute the length of an action aLength (Action xs) = length xs -- Check if every element of a list is identical. allSame :: Eq a => [a] -> Bool allSame [] = True allSame [_] = True allSame (x:y:xs) = (x == y) && allSame (y:xs) -- | Build an action given a nested list of destination states. mkAction :: [[State]] -> Action mkAction = Action . map DestinationSet -- | Build a deterministic action given a list of destination states. mkDAction :: [State] -> Action mkDAction = Action . map (\x -> DestinationSet [x]) -- | Append two 'Action's, ie compute the 'Action' corresponding to -- the application of the first followed by the second. append :: Action -> Action -> Action append (Action d1) a2 = Action $ map (flip appendAtState a2) d1 -- Given the 'DestinationSet' for some state, and an 'Action', compute -- the 'DestinationSet' reached by following the 'Action' from each -- each state in the 'DestinationSet', and collecting the results. appendAtState :: DestinationSet -> Action -> DestinationSet appendAtState (DestinationSet xs) a2 = collect $ L.map destinations $ map (actionLookup a2) xs where collect = DestinationSet . L.nub . L.sort . L.concat -- | Compute the 'DestinationSet' reached by following some 'Action' -- from some 'State'. actionLookup :: Action -> State -> DestinationSet actionLookup (Action ds) src = ds !! src -- | Compute the 'Action' for some 'Word' over some 'FSM'. The word -- might contain symbols outside the FSM's alphabet, so the result -- could be Nothing. action :: Ord sy => FSM sy -> Word sy -> Maybe Action action fsm (Word syms) = foldM (liftMaybe append) (fsmIdentity fsm) actions where actions :: [Maybe Action] actions = map (flip M.lookup (unFSM fsm)) syms liftMaybe :: (a -> a -> a) -> (a -> Maybe a -> Maybe a) liftMaybe f x y = case y of Nothing -> Nothing Just z -> Just $ f x z -- | Test if two 'Word's are action-equivalent over some FSM. actionEquiv :: Ord sy => FSM sy -> Word sy -> Word sy -> Bool actionEquiv fsm w1 w2 = action fsm w1 == action fsm w2 -- | Compute the 'DestinationSet' for some 'Word' at some 'State' of -- an 'FSM'. The word might contain symbols outside the FSM's -- alphabet, or the state might be out of range, so the result could -- be Nothing. destinationSet :: Ord sy => FSM sy -> State -> Word sy -> Maybe DestinationSet destinationSet fsm src word = if (src >= 0) && (src < (length $ states fsm)) then case (action fsm word) of Just (Action ds) -> Just $ ds !! src _ -> Nothing else Nothing -- | Test if two 'Word's are destination-equivalent at some 'State' of -- an 'FSM'. destinationEquiv :: Ord sy => FSM sy -> State -> Word sy -> Word sy -> Bool destinationEquiv fsm src w1 w2 = destinationSet fsm src w1 == destinationSet fsm src w2 -- | Compute the identity action for a given FSM. fsmIdentity :: FSM sy -> Action fsmIdentity = Action . map (\x -> DestinationSet [x]) . states -- | Test if an 'Action' is deterministic or not. isDAction :: Action -> Bool isDAction (Action destSets) = all (\x -> (length (destinations x) == 1)) destSets -- | Compute whether an 'FSM' is deterministic or not. isDFSM :: FSM sy -> Bool isDFSM = L.all isDAction . M.elems . unFSM -- | Normalise an 'FSM', i.e. normalise all its 'Actions'. normalise :: FSM sy -> FSM sy normalise = FSM . M.map normaliseAction . unFSM -- Normalise an 'Action'. Ensures that all its 'DestinationSet's are -- non-empty (empty ones becomes singleton transitions to self), -- sorted, and free from redundancy. normaliseAction :: Action -> Action normaliseAction (Action destSets) = Action $ L.map normDS $ zipWithIndex destSets where -- If 'DestinationSet' is empty, replace it with a transition -- to self. Otherwise, sort it and remove duplicates. normDS :: (State, DestinationSet) -> DestinationSet normDS (self, DestinationSet []) = DestinationSet [self] normDS (_, DestinationSet x) = DestinationSet $ L.nub $ L.sort x zipWithIndex :: [a] -> [(Int, a)] zipWithIndex xs = zip [0..(length xs-1)] xs