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.Monad.Reader as R
import qualified Control.Concurrent   as CC
import qualified Control.Monad        as CM

import Terminal.Game.Plane


type Game m a = R.ReaderT Config m a

data Config = Config { cMEvents :: CC.MVar [Event],
                       cFPS     :: FPS              }

-- | Entry point for the game, should be called in @main@. The two
-- most important functions are the one dealing with logic and the
-- blitting one. Check @alone-in-a-room@ (you can compiler it with
-- @cabal new-build -f examples@) to see a simple game in action.
runGame :: forall s m. MonadGameIO m =>
           s                 -- ^Initial state of the game.
        -> (s -> Event -> s) -- ^Logic function.
        -> (s -> Plane)      -- ^Draw function.
        -> (s -> Bool)       -- ^\"Should I quit?\" function.
        -> FPS               -- ^Frames per second.
        -> m s
runGame s lf df qf fps =
            startEvents fps                   >>= \ve ->
            R.runReaderT game (Config ve fps)
    where
          game :: MonadGameIO m => Game m s
          game = R.ask >>= \c ->
                 R.lift (setupDisplay
                        (gameLoop c s lf df qf Nothing (0,0)
                                  (initFPSCounter 10)))


-- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm
gameLoop :: MonadGameIO m     =>
            Config            -> -- event source
            s                 -> -- state
            (s -> Event -> s) -> -- logic function
            (s -> Plane)      -> -- draw function
            (s -> Bool)       -> -- quit? function
            Maybe Plane       -> -- last blitted screen
            -- FPSCounter     -> -- FPS counter
            (Width, Height)   -> -- Term Dimensions
            FPSCounter        -> -- FPS counter
            m s
gameLoop c s lf df qf opln td fc =

        -- fetch events (if any)
        pollEvents (cMEvents c) >>= \es ->

        -- quit?
        if qf s
          then return s
        else

        -- no events? skip everything
        if null es
          then sleepABit (cFPS c)               >>
               gameLoop c s lf df qf opln td fc
        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?
        let opln' | resc = Nothing   -- res changed? restart double buffering
                  | otherwise = opln
            npln  = df s'
            cFps  = getCurrFPS fc     in
        blitPlane tw th opln' npln cFps >>
        tickCounter fc                  >>= \fc' ->

        gameLoop c s' lf df qf (Just npln) td' fc'


stepsLogic :: s -> (s -> Event -> s) -> [Event] -> s
stepsLogic s lf es = foldl lf s es


-----------------
-- FPS COUNTER --
-----------------

-- poll fps every x frames, current fps, stored time, current fps
data FPSCounter = FPSCounter Integer Integer Integer Integer

-- poll utctime every x ticks
initFPSCounter :: Integer -> FPSCounter
initFPSCounter x = FPSCounter x 0 0 0

tickCounter :: MonadGameIO m => FPSCounter -> m FPSCounter
tickCounter (FPSCounter g e t1 cf)
        | g > e  = return (FPSCounter g (e+1) t1 cf)
        | g == e = getTime >>= \t2 ->
                   let dtn = t2 - t1
                       fr  = fi dtn / fi (g+1)
                       fps = round $ fi (10^(9::Integer)) / fr in
                       --- xxx no div
                   return (FPSCounter g 0 t2 fps)
        | otherwise = error "tickCounter: g < e"
    where
          fi :: Integer -> Double
          fi = fromIntegral

getCurrFPS :: FPSCounter -> Integer
getCurrFPS (FPSCounter _ _ _ cFps) = cFps