You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
82 lines
2.9 KiB
82 lines
2.9 KiB
{-# OPTIONS -Wall #-}
|
|
import Control.Applicative
|
|
import Datatypes.Game
|
|
import VM
|
|
|
|
|
|
|
|
data MonadicGameInternal = MonadicGameInternal { igame :: Game , inote :: Notes}
|
|
|
|
data MonadicGame a = MonadicAction {action :: (MonadicGameInternal -> (MonadicGameInternal, a))}
|
|
|
|
instance Functor MonadicGame where
|
|
fmap f (MonadicAction modifierFunction) = (MonadicAction newModifierFunction)
|
|
where
|
|
newModifierFunction = (\x -> ((fst . modifierFunction) x, (f . snd . modifierFunction) x))
|
|
|
|
|
|
instance Applicative MonadicGame where
|
|
(MonadicAction higherOrderModifierFunction) <*> (MonadicAction modifierFunction) = (MonadicAction newModifierFunction)
|
|
where
|
|
getGameFunction = fst . modifierFunction
|
|
getValueFunction = snd . modifierFunction
|
|
newGameState = fst . higherOrderModifierFunction . getGameFunction
|
|
functionToApply = snd . higherOrderModifierFunction . getGameFunction
|
|
newModifierFunction = (\x -> (newGameState x, (functionToApply x) (getValueFunction x)))
|
|
|
|
pure retData = MonadicAction (\x -> (x, retData))
|
|
|
|
|
|
instance Monad MonadicGame where
|
|
(MonadicAction modifierFunction) >>= f = (MonadicAction newModifierFunction)
|
|
where
|
|
getGameFunction = fst . modifierFunction
|
|
getValueFunction = snd . modifierFunction
|
|
getParametrizedModifierFunction = action . f . getValueFunction
|
|
newModifierFunction = (\x -> getParametrizedModifierFunction x (getGameFunction x))
|
|
|
|
return = pure
|
|
|
|
-- Private state modifiers --
|
|
|
|
modifyGame :: (a -> MonadicGameInternal -> (MonadicGameInternal, b)) -> a -> MonadicGame b
|
|
modifyGame accessorFunction param = (MonadicAction (accessorFunction param))
|
|
|
|
readGame :: (MonadicGameInternal -> a) -> MonadicGame a
|
|
readGame readFunction = modifyGame (\_ x -> (x, readFunction x)) ()
|
|
|
|
writeGame :: (a -> MonadicGameInternal -> MonadicGameInternal) -> a -> MonadicGame ()
|
|
writeGame writeFunction = modifyGame (\x y -> (writeFunction x y, ()))
|
|
|
|
------ Public Functions -----
|
|
|
|
|
|
-- Apply the monad to a Game
|
|
executeGame :: Game -> MonadicGame () -> ([Command], Int)
|
|
executeGame game (MonadicAction finalFunction) = (history executedGame, score executedGame)
|
|
where
|
|
executedGame = (igame . fst . finalFunction) (MonadicGameInternal{igame = game, inote = OK})
|
|
|
|
-- Execute a command
|
|
move :: Command -> MonadicGame ()
|
|
move command = writeGame applyMove command
|
|
where
|
|
applyMove param oldGameInternal = newInternals
|
|
where
|
|
newInternals = MonadicGameInternal {igame = newIgame, inote = newInote}
|
|
newIgame = fst $ step (igame oldGameInternal) param
|
|
newInote = snd $ step (igame oldGameInternal) param
|
|
|
|
-- Execute a list of commands
|
|
moves :: [Command] -> MonadicGame ()
|
|
moves commands = mapM_ move commands
|
|
|
|
-- Read actual score
|
|
readScore :: MonadicGame Int
|
|
readScore = readGame (score . igame)
|
|
|
|
-- Read actual note
|
|
readNote :: MonadicGame Notes
|
|
readNote = readGame inote
|
|
|
|
-----------------------------
|