module Data.FsmActions.ActionMatrix (
parseFsmActionMxFiles,
parseActionMxFile,
parseActionMx,
printActionMx
) where
import Control.Monad.Error
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import System.IO.Error (mkIOError, userErrorType)
import qualified Text.ParserCombinators.Parsec as P
import Text.PrettyPrint.HughesPJ
import Data.FsmActions
import Data.FsmActions.Error
type ActionMatrix = [ActionMatrixRow]
type ActionMatrixRow = [Bool]
parseFsmActionMxFiles :: Ord sy => [(sy, FilePath)] -> IO (FSM sy)
parseFsmActionMxFiles xs =
liftM (FSM . M.fromList) $ mapM (liftMSnd parseActionMxFile) xs
where liftMSnd :: Monad m => (a -> m b) -> (c, a) -> m (c, b)
liftMSnd f (x, y) = f y >>= \z -> return (x, z)
parseActionMxFile :: FilePath -> IO Action
parseActionMxFile path =
do contents <- readFile path
let act = parseActionMx contents
case act of
Right a -> return a
Left e -> throwError (mkIOError userErrorType (show e)
Nothing (Just path))
parseActionMx :: String -> ReadMxMonad Action
parseActionMx actionString =
case P.parse actionMxParser "" actionString of
Right mx -> interpretActionMx mx
Left err -> throwError (MxError "Action matrix parse error" (show err))
actionMxParser :: P.Parser ActionMatrix
actionMxParser = do rows <- parseRow `P.sepEndBy1` P.char '\n'
P.skipMany $ P.char '\n'
P.eof
return rows
where parseRow :: P.Parser [Bool]
parseRow = parseCell `P.sepBy1` P.char ','
parseCell :: P.Parser Bool
parseCell = P.choice [ do P.char '0'
return False
, do P.char '1'
return True
]
interpretActionMx :: ActionMatrix -> ReadMxMonad Action
interpretActionMx rows =
if all (== length transitions) rowLengths
then return $ normaliseAction $ mkAction transitions
else throwError (MxError "action matrix is not square (see row lengths)"
(show rowLengths))
where transitions = L.map parseActionMxRow rows
rowLengths = L.map length rows
parseActionMxRow :: ActionMatrixRow -> [Int]
parseActionMxRow xs = mapMaybe isSet (withIdxs xs)
where
withIdxs ys = zip ys [0..(length ys1)]
isSet (cell, index) = if cell then Just index else Nothing
printActionMx :: Action -> String
printActionMx = show . ppActionMx
ppActionMx :: Action -> Doc
ppActionMx (Action dSets) = vcat $ map mkRow dSets
where
mkRow :: DestinationSet -> Doc
mkRow (DestinationSet ds) = commas $ map (isCell ds) stateList
stateList :: [State]
stateList = [0..length dSets1]
isCell :: [State] -> State -> Doc
isCell dests src = if src `elem` dests then char '1' else char '0'
commas :: [Doc] -> Doc
commas [] = empty
commas (x:[]) = x
commas (x:xs) = x <> comma <> commas xs