module Data.FsmActions (
State,
DestinationSet(..),
Action(..),
FSM,
Word(..),
fromList,
toList,
delete,
lookup,
fsmMap,
states,
alphabet,
normalise,
normaliseAction,
mkAction,
mkDAction,
append,
actionLookup,
action,
actionEquiv,
destinationSet,
destinationEquiv,
fsmIdentity,
identity,
isDAction,
isDFSM
) where
import Control.Monad
import qualified Data.Map as M
import qualified Data.List as L
import Prelude hiding (lookup)
type State = Int
newtype DestinationSet = DestinationSet {
destinations :: [State]
} deriving (Eq, Ord, Show)
newtype Action = Action {
destinationSets :: [DestinationSet]
} deriving (Eq, Ord, Show)
newtype FSM sy = FSM (M.Map sy Action)
deriving (Eq, Ord, Show)
newtype Word sy = Word [sy]
fromList :: Ord sy => [(sy, Action)] -> FSM sy
fromList = FSM . M.fromList
toList :: FSM sy -> [(sy, Action)]
toList (FSM m) = M.toList m
delete :: Ord sy => sy -> FSM sy -> FSM sy
delete s (FSM m) = FSM $ M.delete s m
lookup :: Ord sy => sy -> FSM sy -> Maybe Action
lookup sy (FSM m) = M.lookup sy m
fsmMap :: (sy -> Action -> a) -> FSM sy -> [a]
fsmMap f = map (uncurry f) . toList
states :: FSM sy -> [State]
states (FSM m) = case M.elems m of
((Action ds):_) -> [0..length ds1]
_ -> []
alphabet :: FSM sy -> [sy]
alphabet (FSM m) = M.keys m
mkAction :: [[State]] -> Action
mkAction = Action . map DestinationSet
mkDAction :: [State] -> Action
mkDAction = Action . map (\x -> DestinationSet [x])
append :: Action -> Action -> Action
append (Action d1) a2 = Action $ map (flip appendAtState a2) d1
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
actionLookup :: Action -> State -> DestinationSet
actionLookup (Action ds) = (ds !!)
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 (flip 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
actionEquiv :: Ord sy => FSM sy -> Word sy -> Word sy -> Bool
actionEquiv fsm w1 w2 = action fsm w1 == action fsm w2
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
destinationEquiv :: Ord sy => FSM sy -> State -> Word sy -> Word sy -> Bool
destinationEquiv fsm src w1 w2 =
destinationSet fsm src w1 == destinationSet fsm src w2
fsmIdentity :: FSM sy -> Action
fsmIdentity = identity . length . states
identity :: Int -> Action
identity n = Action $ map (\x -> DestinationSet [x]) [0..n1]
isDAction :: Action -> Bool
isDAction (Action destSets) =
all (\x -> (length (destinations x) == 1)) destSets
isDFSM :: FSM sy -> Bool
isDFSM (FSM m) = L.all isDAction $ M.elems m
normalise :: FSM sy -> FSM sy
normalise (FSM m) = FSM $ M.map normaliseAction m
normaliseAction :: Action -> Action
normaliseAction (Action destSets) =
Action $ L.map normDS $ zipWithIndex destSets
where
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 xs1)] xs