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
-- 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)

-- | 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 @\<press any key to quit\>@ 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 <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 (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)