fsmActions-0.1: Data/FsmActions.hs

{- |

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