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.
155 lines
6.3 KiB
155 lines
6.3 KiB
{-# OPTIONS -Wall #-}
|
|
module MonadicGame(executeGame, move, moves, readScore, readNote, getBestMovesFromHere, saveGame, loadGame, deleteSavedGame, deleteAllSaved, loadFromGame, executeStepCommands, retrieveGameData) where
|
|
|
|
import Control.Applicative
|
|
import qualified Data.HashMap as M
|
|
import Data.Maybe
|
|
import Datatypes.Game
|
|
import VM
|
|
|
|
data MonadicGameInternal = MonadicGameInternal { igame :: Game , inote :: Notes, isaves :: M.Map String (Game,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, return the list of command to execute and the score
|
|
executeGame :: Game -> MonadicGame () -> ([Command], Int)
|
|
executeGame game (MonadicAction actions) = (history executedGame, score executedGame)
|
|
where
|
|
executedGame = (igame . fst . actions) (MonadicGameInternal{igame = game, inote = OK, isaves = M.empty})
|
|
|
|
loadFromGame :: Game -> MonadicGameInternal
|
|
loadFromGame game = (MonadicGameInternal{igame = game, inote = OK, isaves = M.empty})
|
|
|
|
executeStepCommands :: MonadicGame () -> MonadicGameInternal -> MonadicGameInternal
|
|
executeStepCommands (MonadicAction actions) game = newGame
|
|
where
|
|
newGame = (fst . actions) game
|
|
|
|
retrieveGameData :: MonadicGameInternal -> ([Command],Int)
|
|
retrieveGameData game = bestData
|
|
where
|
|
bestData = M.fold findBestFun initData (isaves game)
|
|
initData = ((history . igame) game, (score . igame) game)
|
|
findBestFun procEl (bestHist,bestScore) = if bestScore > (score . fst) procEl
|
|
then (bestHist,bestScore)
|
|
else (bestHist,bestScore)
|
|
-- Execute a command
|
|
move :: Command -> MonadicGame ()
|
|
move command = writeGame applyMove command
|
|
where
|
|
applyMove param oldGameInternal = newInternals
|
|
where
|
|
newInternals = oldGameInternal{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
|
|
|
|
getBestMovesFromHere :: [MonadicGame ()] -> MonadicGame ()
|
|
getBestMovesFromHere [] = return ()
|
|
getBestMovesFromHere movesArr = writeGame bestGameFun movesArr
|
|
where
|
|
bestGameFun param oldGameInternal = bestBranch
|
|
where
|
|
bestBranch = foldl maxBranch oldGameInternal gameBranches
|
|
gameBranches = map (\x -> (fst . (action x)) oldGameInternal) param
|
|
maxBranch oldMax actualBranch = if (score . igame $ oldMax) > (score . igame $ actualBranch)
|
|
then oldMax
|
|
else actualBranch
|
|
|
|
saveGame :: String -> MonadicGame ()
|
|
saveGame saveStr = writeGame saveGameFun saveStr
|
|
where
|
|
saveGameFun param oldGameInternal = savedGameInternal
|
|
where
|
|
savedGameInternal = oldGameInternal{isaves = (M.insert param (actualIgame,actualNote) actualIsaves)}
|
|
actualIsaves = isaves oldGameInternal
|
|
actualIgame = igame oldGameInternal
|
|
actualNote = inote oldGameInternal
|
|
|
|
loadGame :: String -> MonadicGame Bool
|
|
loadGame loadStr = modifyGame loadGameFun loadStr
|
|
where
|
|
loadGameFun param oldGameInternal = (loadedGameInternal, loaded)
|
|
where
|
|
lookupResult = M.lookup param (isaves oldGameInternal)
|
|
(loadedGame, loadedNote, loaded) = if isJust lookupResult
|
|
then (fst $ fromJust lookupResult,snd $ fromJust lookupResult, True)
|
|
else (igame oldGameInternal, inote oldGameInternal, False)
|
|
loadedGameInternal = oldGameInternal{igame = loadedGame, inote = loadedNote}
|
|
|
|
|
|
deleteSavedGame :: String -> MonadicGame Bool
|
|
deleteSavedGame delStr = modifyGame deleteSavedGameFun delStr
|
|
where
|
|
deleteSavedGameFun param oldGameInternal = (deletedSavedGameInternal, deleted)
|
|
where
|
|
oldGameISaved = isaves oldGameInternal
|
|
deleted = M.member param oldGameISaved
|
|
deletedSavedGameInternal = if deleted
|
|
then oldGameInternal{isaves = (M.delete param oldGameISaved)}
|
|
else oldGameInternal
|
|
|
|
|
|
deleteAllSaved :: MonadicGame ()
|
|
deleteAllSaved = writeGame deleteAllSavedGameFun ()
|
|
where
|
|
deleteAllSavedGameFun _ oldGameInternal = deletedAllSavedGameInternal
|
|
where
|
|
deletedAllSavedGameInternal = oldGameInternal{isaves = M.empty}
|
|
|
|
-----------------------------
|