------------------------------------------------------------------------------- -- Layer 1 (imperative), as per -- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html -- 2019 Francesco Ariis GPLv3 ------------------------------------------------------------------------------- {-# Language ScopedTypeVariables #-} module Terminal.Game.Layer.Imperative where import Terminal.Game.Layer.Object import qualified Control.Concurrent as CC import qualified Control.Exception as E import qualified Control.Monad as CM import qualified System.IO as SI import Terminal.Game.Plane -- xxx also when it goes to crash screen, it says press any key to -- continue, yet only enter works -- | Game definition datatype, parametrised on your gamestate. The two -- most important elements are the function dealing with logic and the -- drawing one. Check @alone@ (you can compile it with @cabal -- new-run -f examples alone@) to see a simple game in action. data Game s = Game { gScreenWidth :: Width, -- ^Gamescreen size, width. gScreenHeight :: Height, -- ^Gamescreen size, height. gFPS :: FPS, -- ^Frames per second. gInitState :: s, -- ^Initial state of the game. gLogicFunction :: s -> Event -> s, -- ^Logic function. gDrawFunction :: s -> Plane, -- ^Draw function. gQuitFunction :: s -> Bool -- ^\"Should I quit?\" function. } -- | Entry point for the game execution, should be called in @main@. -- -- You __must__ compile your programs with @-threaded@; if you do not do -- this the game will crash at start-up. Just add: -- -- @ -- ghc-options: -threaded -- @ -- -- in your @.cabal@ file and you will be fine! playGame :: Game s -> IO () playGame g = () <$ runGIO (runGameGeneral g) -- | Tests a game in a /pure/ environment. You can -- supply the 'Event's yourself or use 'recordGame' to obtain them. testGame :: Game s -> [Event] -> s testGame g es = fst $ runTest (runGameGeneral g) (Env False es) -- | As 'testGame', but returns 'Game' instead of a bare state. -- Useful to fast-forward (e.g.: skip menus) before invoking 'playGame'. setupGame :: Game s -> [Event] -> Game s setupGame g es = let s' = testGame g es in g { gInitState = s' } -- | Similar to 'testGame', runs the game given a list of 'Events'. Unlike -- 'testGame', the playthrough will be displayed on screen. Useful when a -- test fails and you want to see how. -- -- See this in action with @cabal new-run -f examples alone-playback@. narrateGame :: Game s -> [Event] -> IO s narrateGame g e = runReplay (runGameGeneral g) e -- xxx replaygame is very difficult to test -- -- | Play as in 'playGame' and write the session to @file@. Useful to -- -- produce input for 'testGame' and 'replayGame'. -- recordGame :: Game s -> FilePath -> IO s -- recordGame g fp = -- CC.newMVar [] >>= \ve -> -- runRecord (runGameGeneral g) ve >>= \s -> -- writeMoves fp ve >> -- return s -- | Play as in 'playGame' and write the session to @file@. Useful to -- produce input for 'testGame' and 'replayGame'. Session will be -- recorded even if an exception happens while playing. recordGame :: Game s -> FilePath -> IO () recordGame g fp = E.bracket (CC.newMVar []) (\ve -> writeMoves fp ve) (\ve -> () <$ runRecord (runGameGeneral g) ve) data Config = Config { cMEvents :: CC.MVar [Event], cFPS :: FPS } runGameGeneral :: forall s m. MonadGameIO m => Game s -> m s runGameGeneral (Game gw gh fps s lf df qf) = -- init sizeAssert gw gh >> setupDisplay >> startEvents fps >>= \(InputHandle ve ts) -> -- do it! let c = Config ve fps in cleanUpErr (game c) -- this under will be run regardless (stopEvents ts >> shutdownDisplay ) where game :: MonadGameIO m => Config -> m s game c = gameLoop gw gh c s lf df qf Nothing (0,0) -- | Wraps an @IO@ computation so that any 'error' gets displayed along -- with a @\@ prompt. -- Some terminals shut-down immediately upon program end: 'errorPress' -- makes it easier to beta-test games on those terminals. errorPress :: IO a -> IO a errorPress m = E.catch m errorDisplay where errorDisplay :: E.ErrorCall -> IO a errorDisplay (E.ErrorCallWithLocation cs l) = putStrLn "ERROR REPORT\n" >> putStrLn (cs ++ "\n\n") >> putStrLn "Stack trace info:\n" >> putStrLn (l ++ "\n") >> putStrLn "\n " >> SI.hSetBuffering SI.stdin SI.NoBuffering >> getChar >> errorWithoutStackTrace "errorPress" ----------- -- LOGIC -- ----------- -- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm gameLoop :: MonadGameIO m => Width -> -- gamewidth Height -> -- gameheight Config -> -- event source s -> -- state (s -> Event -> s) -> -- logic function (s -> Plane) -> -- draw function (s -> Bool) -> -- quit? function Maybe Plane -> -- last blitted screen (Width, Height) -> -- Term Dimensions m s gameLoop gw gh c s lf df qf opln td = -- quit? checkQuit qf s >>= \qb -> if qb then return s else -- fetch events (if any) pollEvents (cMEvents c) >>= \es -> -- xxx test poll events si rompe se lo sposto su -- no events? skip everything if null es then sleepABit (cFPS c) >> gameLoop gw gh c s lf df qf opln td -- xxx reader monad qui else -- logic let s' = stepsLogic s lf es in -- clear screen if resolution change displaySize >>= \td'@(tw, th) -> let resc = td /= td' in CM.when resc clearDisplay >> -- draw -- xxx solo se รจ tick e non kpress? [loop] let opln' | resc = Nothing -- res changed? restart double buffering | otherwise = opln gpl = blankPlane gw gh npln = pastePlane (df s') gpl (1, 1) in blitPlane tw th opln' npln >> gameLoop gw gh c s' lf df qf (Just npln) td' stepsLogic :: s -> (s -> Event -> s) -> [Event] -> s stepsLogic s lf es = foldl lf s es ----------------- -- ANCILLARIES -- ----------------- sizeAssert :: MonadDisplay m => Width -> Height -> m () sizeAssert gw gh = displaySize >>= \(sw, sh) -> let errMess = "This games requires a screen of " ++ show gw ++ " columns and " ++ show gh ++ " rows.\n" ++ "Yours only has " ++ show sw ++ " columns and " ++ show sh ++ " rows!\n\n" ++ "Please resize your terminal and relaunch " ++ "the game!\n" in CM.when (gw > sw || gh > sh) (error errMess)