ansi-terminal-game-1.4.0.0: src/Terminal/Game/Layer/Imperative.hs
-------------------------------------------------------------------------------
-- 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 run -f
-- examples alone@) to see a simple game in action.
data Game s = Game {
gScreenWidth :: Width, -- ^Gamescreen width, in columns.
gScreenHeight :: Height, -- ^Gamescreen height, in rows.
gTPS :: TPS, -- ^Ticks per second. Since the
-- 2D «char canvas» is coarse, you
-- do not need a high value (e.g.
-- 13 TPS is enough for action
-- games).
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!
--
-- Throws 'DisplayTooSmall' if game widht/height cannot be accomodated
-- by terminal.
playGame :: Game s -> IO ()
playGame g = () <$ runGIO (runGameGeneral g)
-- | As 'playGame', but do not discard state.
playGameS :: Game s -> IO s
playGameS 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 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 'narrateGame'. 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],
cTPS :: TPS }
runGameGeneral :: forall s m. MonadGameIO m =>
Game s -> m s
runGameGeneral (Game gw gh tps s lf df qf) =
-- init
sizeException gw gh >>
setupDisplay >>
startEvents tps >>= \(InputHandle ve ts) ->
-- do it!
let c = Config ve tps 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 'ATGException' or 'error' gets
-- displayed along with a @\<press any key to quit\>@ prompt.
-- Some terminals shut-down immediately upon program end; adding
-- @errorPress@ to 'playGame' makes it easier to beta-test games on those
-- terminals.
errorPress :: IO a -> IO a
errorPress m = E.catches m [E.Handler errorDisplay,
E.Handler atgDisplay]
where
errorDisplay :: E.ErrorCall -> IO a
errorDisplay (E.ErrorCallWithLocation cs l) = report $
putStrLn (cs ++ "\n\n") >>
putStrLn "Stack trace info:\n" >>
putStrLn l
atgDisplay :: ATGException -> IO a
atgDisplay e = report $
putStrLn (show e)
report :: IO () -> IO a
report wm =
putStrLn "ERROR REPORT\n" >>
wm >>
putStrLn "\n\n <Press any key to quit>" >>
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 (cTPS 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
displaySizeErr >>= \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 --
-----------------
sizeException :: (MonadDisplay m, MonadException m) => Width -> Height -> m ()
sizeException gw gh =
displaySizeErr >>= \(sw, sh) ->
CM.when (gw > sw || gh > sh)
(throwExc $ DisplayTooSmall (gw, gh) (sw, sh))