-------------------------------------------------------------------------------
-- 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.Draw
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 Data.Bool as B
import qualified Data.List as D
import qualified System.IO as SI

import Terminal.Game.Plane

-- | Game environment with current terminal dimensions and current display
-- rate.
data GEnv = GEnv { GEnv -> Dimensions
eTermDims :: Dimensions,
                   GEnv -> FPS
eFPS :: FPS }

-- | General way to create a game. This gives you more control by
-- exposing 'GEnv' (allowing e.g. to adapt to screen resizes, blit
-- FPS, etc.. If you fancy simple, sensible defaults, check 'simpleGame'.
data Game s =
        Game { Game s -> FPS
gTPS           :: TPS, -- ^ Ticks per second. Since the 2D
                                      -- “char canvas” is coarse, you do not
                                      -- need high values (e.g. 13 TPS is
                                      -- enough for action games).
               Game s -> s
gInitState     :: s,   -- ^ Initial state of the game.
               Game s -> GEnv -> s -> Event -> s
gLogicFunction :: GEnv -> s -> Event -> s,
                                      -- ^ Logic function.
               Game s -> GEnv -> s -> Plane
gDrawFunction  :: GEnv -> s -> Plane,
                                      -- ^ Draw function. Check '***' for
                                       --  centre-blitting.
               Game s -> s -> Bool
gQuitFunction  :: s -> Bool
                                      -- ^ “Should I quit?” function.
                                      }

-- | Simplest way to create a game. The two most important parameters
-- 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 basic
-- game in action. If you want more control, look at 'Game'.
simpleGame :: Dimensions           -- ^ Gamescreen dimensions, in columns and
                                   --   rows. Asks the player to resize their
                                   --   terminal if it is too small.
                                   --   Centre-blits on bigger terminals.
              -> TPS               -- ^ Ticks per second. Since the 2D “char
                                   --   canvas” is coarse, you do not need
                                   --   high values (e.g. 13 TPS is enough
                                   --   for action games).
              -> s                 -- ^ Initial state of the game.
              -> (s -> Event -> s) -- ^ Simple logic function.
              -> (s -> Plane)      -- ^ Simple draw function.
              -> (s -> Bool)       -- ^ “Should I quit?” function.
              -> Game s
simpleGame :: Dimensions
-> FPS
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Game s
simpleGame (Width
sw, Width
sh) FPS
tps s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf = FPS
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Game s
forall s.
FPS
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Game s
Game FPS
tps s
s GEnv -> s -> Event -> s
lf' GEnv -> s -> Plane
df' s -> Bool
qf
    where
          -- lf' :: GEnv -> s -> Event -> s
          lf' :: GEnv -> s -> Event -> s
lf' GEnv
wen s
ws Event
we
                | Dimensions -> Bool
isSmaller (GEnv -> Dimensions
eTermDims GEnv
wen) = s
ws
                | Bool
otherwise = s -> Event -> s
lf s
ws Event
we

          -- df' :: GEnv -> s -> Plane
          df' :: GEnv -> s -> Plane
df' GEnv
wen s
ws =
                let ds :: Dimensions
ds = GEnv -> Dimensions
eTermDims GEnv
wen in
                if Dimensions -> Bool
isSmaller Dimensions
ds
                  then Dimensions -> Plane
smallMsg Dimensions
ds
                  else (Width -> Width -> Plane) -> Dimensions -> Plane
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Width -> Width -> Plane
blankPlane Dimensions
ds Plane -> Plane -> Plane
*** s -> Plane
df s
ws

          colS :: Width -> Bool
colS Width
ww = Width
ww Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
sw
          rowS :: Width -> Bool
rowS Width
wh = Width
wh Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
sh
          isSmaller :: Dimensions -> Bool
          isSmaller :: Dimensions -> Bool
isSmaller (Width
ww, Width
wh) = Width -> Bool
colS Width
ww Bool -> Bool -> Bool
|| Width -> Bool
rowS Width
wh

          smallMsg :: Dimensions -> Plane
          smallMsg :: Dimensions -> Plane
smallMsg (Width
ww, Width
wh) =
                let cm :: [Char]
cm = Width -> [Char]
forall a. Show a => a -> [Char]
show Width
ww [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" columns"
                    rm :: [Char]
rm = Width -> [Char]
forall a. Show a => a -> [Char]
show Width
wh [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" rows"
                    em :: [Char]
em | Width -> Bool
colS Width
ww Bool -> Bool -> Bool
&& Width -> Bool
rowS Width
wh = [Char]
cm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rm
                       | Width -> Bool
colS Width
ww = [Char]
cm
                       | Width -> Bool
rowS Width
wh = [Char]
rm
                       | Bool
otherwise = [Char]
"smallMsg: passed correct term size!"
                in
                Width -> [Char] -> Plane
textBoxLiquid Width
ww ([Char] -> Plane) -> [Char] -> Plane
forall a b. (a -> b) -> a -> b
$
                  [Char]
"This games requires a screen of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Width -> [Char]
forall a. Show a => a -> [Char]
show Width
sw [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char]
" columns and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Width -> [Char]
forall a. Show a => a -> [Char]
show Width
sh [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" rows.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char]
"Yours only has " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
em [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char]
"Please resize your terminal now!"


-- | 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 :: Game s -> IO ()
playGame Game s
g = () () -> IO s -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GameIO s -> IO s
forall a. GameIO a -> IO a
runGIO (Game s -> GameIO s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g)

-- | As 'playGame', but do not discard state.
playGameS :: Game s -> IO s
playGameS :: Game s -> IO s
playGameS Game s
g = GameIO s -> IO s
forall a. GameIO a -> IO a
runGIO (Game s -> GameIO s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
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 :: Game s -> [Event] -> s
testGame Game s
g [Event]
es = (s, [TestEvent]) -> s
forall a b. (a, b) -> a
fst ((s, [TestEvent]) -> s) -> (s, [TestEvent]) -> s
forall a b. (a -> b) -> a -> b
$ Test s -> Env -> (s, [TestEvent])
forall a. Test a -> Env -> (a, [TestEvent])
runTest (Game s -> Test s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g) (Bool -> [Event] -> Env
Env Bool
False [Event]
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 :: Game s -> [Event] -> Game s
setupGame Game s
g [Event]
es = let s' :: s
s' = Game s -> [Event] -> s
forall s. Game s -> [Event] -> s
testGame Game s
g [Event]
es
                 in Game s
g { gInitState :: s
gInitState = s
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 :: Game s -> [Event] -> IO s
narrateGame Game s
g [Event]
e = Narrate s -> [Event] -> IO s
forall a. Narrate a -> [Event] -> IO a
runReplay (Game s -> Narrate s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g) [Event]
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 :: Game s -> [Char] -> IO ()
recordGame Game s
g [Char]
fp =
        IO (MVar [Event])
-> (MVar [Event] -> IO ()) -> (MVar [Event] -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
          ([Event] -> IO (MVar [Event])
forall a. a -> IO (MVar a)
CC.newMVar [])
          (\MVar [Event]
ve -> [Char] -> MVar [Event] -> IO ()
writeMoves [Char]
fp MVar [Event]
ve)
          (\MVar [Event]
ve -> () () -> IO s -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Record s -> MVar [Event] -> IO s
forall a. Record a -> MVar [Event] -> IO a
runRecord (Game s -> Record s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g) MVar [Event]
ve)

data Config = Config { Config -> MVar [Event]
cMEvents :: CC.MVar [Event],
                       Config -> FPS
cTPS     :: TPS              }

runGameGeneral :: forall s m. MonadGameIO m =>
                  Game s -> m s
runGameGeneral :: Game s -> m s
runGameGeneral (Game FPS
tps s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf) =
            -- init
            m ()
forall (m :: * -> *). MonadDisplay m => m ()
setupDisplay    m () -> m InputHandle -> m InputHandle
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            FPS -> m InputHandle
forall (m :: * -> *). MonadInput m => FPS -> m InputHandle
startEvents FPS
tps m InputHandle -> (InputHandle -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(InputHandle MVar [Event]
ve [ThreadId]
ts) ->
            m Dimensions
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr  m Dimensions -> (Dimensions -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Dimensions
ds ->

            -- do it!
            let c :: Config
c = MVar [Event] -> FPS -> Config
Config MVar [Event]
ve FPS
tps in
            m s -> m () -> m s
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
cleanUpErr (MonadGameIO m => Config -> Dimensions -> m s
Config -> Dimensions -> m s
game Config
c Dimensions
ds)
                            -- this under will be run regardless
                       ([ThreadId] -> m ()
forall (m :: * -> *). MonadInput m => [ThreadId] -> m ()
stopEvents [ThreadId]
ts m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                        m ()
forall (m :: * -> *). MonadDisplay m => m ()
shutdownDisplay  )
    where
          game :: MonadGameIO m => Config -> Dimensions -> m s
          game :: Config -> Dimensions -> m s
game Config
c Dimensions
wds = Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf
                                Maybe Plane
forall a. Maybe a
Nothing Dimensions
wds
                                (FPS -> FPSCalc
creaFPSCalc FPS
tps)


-- | 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 :: IO a -> IO a
errorPress IO a
m = IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
E.catches IO a
m [(ErrorCall -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ErrorCall -> IO a
forall a. ErrorCall -> IO a
errorDisplay,
                            (ATGException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ATGException -> IO a
forall a. ATGException -> IO a
atgDisplay]
    where
          errorDisplay :: E.ErrorCall -> IO a
          errorDisplay :: ErrorCall -> IO a
errorDisplay (E.ErrorCallWithLocation [Char]
cs [Char]
l) = IO () -> IO a
forall a. IO () -> IO a
report (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$
              [Char] -> IO ()
putStrLn ([Char]
cs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n")        IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [Char] -> IO ()
putStrLn [Char]
"Stack trace info:\n" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [Char] -> IO ()
putStrLn [Char]
l

          atgDisplay :: ATGException -> IO a
          atgDisplay :: ATGException -> IO a
atgDisplay ATGException
e = IO () -> IO a
forall a. IO () -> IO a
report (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ ATGException -> IO ()
forall a. Show a => a -> IO ()
print ATGException
e

          report :: IO () -> IO a
          report :: IO () -> IO a
report IO ()
wm =
              [Char] -> IO ()
putStrLn [Char]
"ERROR REPORT\n"                IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              IO ()
wm                                       IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [Char] -> IO ()
putStrLn [Char]
"\n\n <Press any key to quit>"  IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              Handle -> BufferMode -> IO ()
SI.hSetBuffering Handle
SI.stdin BufferMode
SI.NoBuffering IO () -> IO Char -> IO Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              IO Char
getChar                                  IO Char -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [Char] -> IO a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"errorPress"


-----------
-- LOGIC --
-----------

-- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm
gameLoop :: MonadGameIO m     =>
            Config            -> -- event source
            s                 -> -- state
            (GEnv ->
             s -> Event -> s) -> -- logic function
            (GEnv ->
             s -> Plane)      -> -- draw function
            (s -> Bool)       -> -- quit? function
            Maybe Plane       -> -- last blitted screen
            Dimensions        -> -- Term dimensions
            FPSCalc           -> -- calculate fps
            m s
gameLoop :: Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln Dimensions
td FPSCalc
fps =

        -- quit?
        (s -> Bool) -> s -> m Bool
forall (m :: * -> *) s. MonadLogic m => (s -> Bool) -> s -> m Bool
checkQuit s -> Bool
qf s
s m Bool -> (Bool -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
qb ->
        if Bool
qb
          then s -> m s
forall (m :: * -> *) a. Monad m => a -> m a
return s
s
        else

        -- fetch events (if any)
        MVar [Event] -> m [Event]
forall (m :: * -> *). MonadInput m => MVar [Event] -> m [Event]
pollEvents (Config -> MVar [Event]
cMEvents Config
c) m [Event] -> ([Event] -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Event]
es ->

        -- no events? skip everything
        if [Event] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
es
          then FPS -> m ()
forall (m :: * -> *). MonadTimer m => FPS -> m ()
sleepABit (Config -> FPS
cTPS Config
c)               m () -> m s -> m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln Dimensions
td FPSCalc
fps
        else

        m Dimensions
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr            m Dimensions -> (Dimensions -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Dimensions
td' ->

        -- logic
        let ge :: GEnv
ge = Dimensions -> FPS -> GEnv
GEnv Dimensions
td' (FPSCalc -> FPS
calcFPS FPSCalc
fps)
            (FPS
i, s
s') = s -> (s -> Event -> s) -> [Event] -> (FPS, s)
forall s. s -> (s -> Event -> s) -> [Event] -> (FPS, s)
stepsLogic s
s (GEnv -> s -> Event -> s
lf GEnv
ge) [Event]
es in

        -- no `Tick` events? You do not need to blit, just update state
        if FPS
i FPS -> FPS -> Bool
forall a. Eq a => a -> a -> Bool
== FPS
0
          then Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s' GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln Dimensions
td FPSCalc
fps
        else

        -- FPS calc
        let fps' :: FPSCalc
fps' = FPS -> FPSCalc -> FPSCalc
addFPS FPS
i FPSCalc
fps in

        -- clear screen if resolution changed
        let resc :: Bool
resc = Dimensions
td Dimensions -> Dimensions -> Bool
forall a. Eq a => a -> a -> Bool
/= Dimensions
td' in
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
CM.when Bool
resc m ()
forall (m :: * -> *). MonadDisplay m => m ()
clearDisplay m () -> m s -> m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

        -- draw
        let opln' :: Maybe Plane
opln' | Bool
resc = Maybe Plane
forall a. Maybe a
Nothing -- res changed? restart double buffering
                  | Bool
otherwise = Maybe Plane
opln
            npln :: Plane
npln = GEnv -> s -> Plane
df GEnv
ge s
s' in

        Maybe Plane -> Plane -> m ()
forall (m :: * -> *).
MonadDisplay m =>
Maybe Plane -> Plane -> m ()
blitPlane Maybe Plane
opln' Plane
npln m () -> m s -> m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

        Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s' GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf (Plane -> Maybe Plane
forall a. a -> Maybe a
Just Plane
npln) Dimensions
td' FPSCalc
fps'

-- Int = number of `Tick` events
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (Integer, s)
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (FPS, s)
stepsLogic s
s s -> Event -> s
lf [Event]
es = let ies :: FPS
ies = [Event] -> FPS
forall i a. Num i => [a] -> i
D.genericLength ([Event] -> FPS) -> ([Event] -> [Event]) -> [Event] -> FPS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter Event -> Bool
isTick ([Event] -> FPS) -> [Event] -> FPS
forall a b. (a -> b) -> a -> b
$ [Event]
es
                     in (FPS
ies, (s -> Event -> s) -> s -> [Event] -> s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl s -> Event -> s
lf s
s [Event]
es)
    where
          isTick :: Event -> Bool
isTick Event
Tick = Bool
True
          isTick Event
_    = Bool
False

-------------------------------------------------------------------------------
-- Frame per Seconds

-- | The number of frames blit to terminal per second. Frames might be
-- dropped, but game speed will remain constant. Check @balls@
-- (@cabal run -f examples balls@) to see how to display FPS.
type FPS = Integer

data FPSCalc = FPSCalc [Integer] TPS
    -- list with number of `Ticks` processed at each blit and expected
    -- FPS (i.e. TPS)

-- the size of moving average will be TPS (that simplifies calculations)
creaFPSCalc :: TPS -> FPSCalc
creaFPSCalc :: FPS -> FPSCalc
creaFPSCalc FPS
tps = [FPS] -> FPS -> FPSCalc
FPSCalc (FPS -> FPS -> [FPS]
forall i a. Integral i => i -> a -> [a]
D.genericReplicate (FPS
tpsFPS -> FPS -> FPS
forall a. Num a => a -> a -> a
*FPS
1) FPS
1) FPS
tps
    -- tps*1: size of thw window in **blit actions** (not tick actions!)
    --        so keeping it small should be responsive and non flickery
    --        at the same time!

-- add ticks
addFPS :: Integer -> FPSCalc -> FPSCalc
addFPS :: FPS -> FPSCalc -> FPSCalc
addFPS FPS
nt (FPSCalc (FPS
_:[FPS]
fps) FPS
tps) = [FPS] -> FPS -> FPSCalc
FPSCalc ([FPS]
fps [FPS] -> [FPS] -> [FPS]
forall a. [a] -> [a] -> [a]
++ [FPS
nt]) FPS
tps
addFPS FPS
_ (FPSCalc [] FPS
_) = [Char] -> FPSCalc
forall a. HasCallStack => [Char] -> a
error [Char]
"addFPS: empty list."

calcFPS :: FPSCalc -> Integer
calcFPS :: FPSCalc -> FPS
calcFPS (FPSCalc [FPS]
fps FPS
tps) =
        let ts :: FPS
ts = [FPS] -> FPS
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [FPS]
fps
            ds :: FPS
ds = [FPS] -> FPS
forall i a. Num i => [a] -> i
D.genericLength [FPS]
fps
        in FPS -> FPS -> FPS
roundQuot (FPS
tps FPS -> FPS -> FPS
forall a. Num a => a -> a -> a
* FPS
ds) FPS
ts
    where
          roundQuot :: Integer -> Integer -> Integer
          roundQuot :: FPS -> FPS -> FPS
roundQuot FPS
a FPS
b = let (FPS
q, FPS
r) = FPS -> FPS -> (FPS, FPS)
forall a. Integral a => a -> a -> (a, a)
quotRem FPS
a FPS
b
                          in FPS
q FPS -> FPS -> FPS
forall a. Num a => a -> a -> a
+ FPS -> FPS -> Bool -> FPS
forall a. a -> a -> Bool -> a
B.bool FPS
0 FPS
1 (FPS
r FPS -> FPS -> Bool
forall a. Ord a => a -> a -> Bool
> FPS -> FPS -> FPS
forall a. Integral a => a -> a -> a
div FPS
b FPS
2)