```{- |

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/

module Data.FsmActions (
-- * Data types
State,
DestinationSet(..),
Action(..),
FSM,
Word(..),
-- * Simple FSM operations
fromList,
toList,
delete,
lookup,
fsmMap,
states,
alphabet,
-- * Normalisation
normalise,
normaliseAction,
-- * Operations on actions
mkAction,
mkDAction,
append,
actionLookup,
action,
actionEquiv,
-- * Destination sets
destinationSet,
destinationEquiv,
-- * Identity
fsmIdentity,
identity,
-- * Determinism
isDAction,
isDFSM
) where

import qualified Data.Map as M
import qualified Data.List as L
import Prelude hiding (lookup)

--import Data.FsmActions.FGL

-- | 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 (M.Map sy Action)
deriving (Eq, Ord, Show)

-- | Words are lists of symbols.
newtype Word sy = Word [sy]

-- | Create an FSM from a list of symbol, Action pairs.
fromList :: Ord sy => [(sy, Action)] -> FSM sy
fromList = FSM . M.fromList

-- | Turn an FSM into a list of symbol, Action pairs.
toList :: FSM sy -> [(sy, Action)]
toList (FSM m) = M.toList m

-- | Delete a symbol and its action from an FSM.
delete :: Ord sy => sy -> FSM sy -> FSM sy
delete s (FSM m) = FSM \$ M.delete s m

-- | Look up a symbol's 'Action' in an 'FSM'
lookup :: Ord sy => sy -> FSM sy -> Maybe Action
lookup sy (FSM m) = M.lookup sy m

-- | Map a function over the FSM.
fsmMap :: (sy -> Action -> a) -> FSM sy -> [a]
fsmMap f = map (uncurry f) . toList

-- | 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 m) = case M.elems m of
(Action ds:_) -> [0..length ds-1]
_             -> []

-- | Compute the alphabet of an 'FSM'.
alphabet :: FSM sy -> [sy]
alphabet (FSM m) = M.keys m

-- | 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 (`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 . 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) = (ds !!)

-- | 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@(FSM m) (Word syms) =
foldM (liftMaybe append) (fsmIdentity fsm) actions
where actions :: [Maybe Action]
actions = map (`M.lookup` m) 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 = identity . length . states

-- | Compute the identity action for a given number of states
identity :: Int -> Action
identity n = Action \$ map (\x -> DestinationSet [x]) [0..n-1]

-- | 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 (FSM m) = L.all isDAction \$ M.elems m

-- | Normalise an 'FSM', i.e. normalise all its 'Actions'.
normalise :: FSM sy -> FSM sy
normalise (FSM m) = FSM \$ M.map normaliseAction m

-- 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
```