-------------------------------------------------------------------------------
-- 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.Either as ET
import qualified Data.List as D
import qualified System.IO as SI

import Terminal.Game.Plane

-- | Game definition datatype, parametrised on:
--
-- * your gamestate @s@; and
-- * a result when the game is finished @r@. Simple games do not need this,
--   just fill @r@ with @()@.
--
-- The two most important elements are the function dealing with logic and
-- the drawing one. Check @alone@ demo (@cabal run -f examples alone@) to
-- see a basic game in action.
data Game s r = Game {
        forall s r. Game s r -> Integer
gTPS           :: TPS,
            -- ^ Game speed in ticks per second. You do not
            -- need high values, since the 2D canvas is coarse
            -- (e.g. 13 TPS is enough for action games).
        forall s r. Game s r -> s
gInitState     :: s,   -- ^ Initial state of the game.
        forall s r. Game s r -> GEnv -> s -> Event -> Either r s
gLogicFunction :: GEnv -> s -> Event -> Either r s,
            -- ^ Logic function.  If `gLogicFunction` returns @Right s@
            -- the game will continue with state @s@; if it returns @Left@
            -- the game is over (quit condition).
            --
            -- Curious to see how @r@ can be useful? Check
            -- @cabal run -f examples balls@ and
            -- @example/MainBalls.hs@.
        forall s r. Game s r -> GEnv -> s -> Plane
gDrawFunction  :: GEnv -> s -> Plane
            -- ^ Draw function. Just want to blit your game
            -- in the middle? Check 'centerFull'.
    }

-- | A blank plane as big as the terminal.
blankPlaneFull :: GEnv -> Plane
blankPlaneFull :: GEnv -> Plane
blankPlaneFull GEnv
e = (Width -> Width -> Plane) -> (Width, Width) -> Plane
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Width -> Width -> Plane
blankPlane (GEnv -> (Width, Width)
eTermDims GEnv
e)

-- | Blits plane in the middle of terminal.
--
-- @
--   draw :: GEnv -> MyState -> Plane
--   draw ev s =
--       centerFull ev $
--         ⁝
-- @
centerFull :: GEnv -> Plane -> Plane
centerFull :: GEnv -> Plane -> Plane
centerFull GEnv
e Plane
p = GEnv -> Plane
blankPlaneFull GEnv
e Plane -> Plane -> Plane
*** Plane
p

-- | 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 r -> IO r
playGame :: forall s r. Game s r -> IO r
playGame Game s r
g = (r -> r) -> (s -> r) -> Either r s -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either r -> r
forall a. a -> a
id ([Char] -> s -> r
forall a. HasCallStack => [Char] -> a
error [Char]
"`Right` in playGame") (Either r s -> r) -> IO (Either r s) -> IO r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               GameIO (Either r s) -> IO (Either r s)
forall a. GameIO a -> IO a
runGIO (Game s r -> GameIO (Either r s)
forall s r (m :: * -> *).
MonadGameIO m =>
Game s r -> m (Either r s)
runGameGeneral Game s r
g)

-- | As 'playGame', but ignore the result @r@.
playGame_ :: Game s r -> IO ()
playGame_ :: forall s r. Game s r -> IO ()
playGame_ Game s r
g = () () -> IO r -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Game s r -> IO r
forall s r. Game s r -> IO r
playGame Game s r
g

-- | Tests a game in a /pure/ environment. Aims to accurately emulate 'GEnv'
-- changes (screen size, FPS) too. Returns a result @r@ or a state @s@ in
-- case the Event stream is exhausted before the game exits.
--
-- A useful trick is to call 'recordGame' and press /Ctrl-C/ while playing
-- (instead of quitting properly). This way @testGame@ will return
-- @Left s@, a state that you can then inspect.
testGame :: Game s r -> GRec -> Either r s
testGame :: forall s r. Game s r -> GRec -> Either r s
testGame Game s r
g GRec
ts =
        case Test (Either r s) -> GRec -> (Maybe (Either r s), [TestEvent])
forall a. Test a -> GRec -> (Maybe a, [TestEvent])
runTest (Game s r -> Test (Either r s)
forall s r (m :: * -> *).
MonadGameIO m =>
Game s r -> m (Either r s)
runGameGeneral Game s r
g) GRec
ts of
            (Maybe (Either r s)
Nothing, [TestEvent]
l) -> [Char] -> Either r s
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either r s) -> [Char] -> Either r s
forall a b. (a -> b) -> a -> b
$ [Char]
"testGame, exception called: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    [TestEvent] -> [Char]
forall a. Show a => a -> [Char]
show [TestEvent]
l
                -- it is fine to use error here since in the end
                -- hspec can deal with it gracefully and we give
                -- more infos on a failed test
            (Just Either r s
s, [TestEvent]
_) -> Either r s
s

-- | As 'testGame', but returns 'Game' instead of result/state.
-- Useful to fast-forward (e.g.: skip menus) before invoking 'playGame'.
setupGame :: Game s r -> GRec -> Game s r
setupGame :: forall s r. Game s r -> GRec -> Game s r
setupGame Game s r
g GRec
ts = let s' :: Either r s
s' = Game s r -> GRec -> Either r s
forall s r. Game s r -> GRec -> Either r s
testGame Game s r
g GRec
ts
                 in case Either r s
s' of
                      -- If the game is already over, return a mock logic
                      -- function which simply ends the game.
                      Left r
r -> Game s r
g { gLogicFunction = \GEnv
_ s
_ Event
_ -> r -> Either r s
forall a b. a -> Either a b
Left r
r }
                      Right s
s -> Game s r
g { gInitState = s }

-- | Similar to 'testGame', runs the game given a 'GRec'. 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@.
--
-- Notice that 'GEnv' will be provided at /run-time/, and not
-- record-time; this can make emulation slightly inaccurate if — e.g. —
-- you replay the game on a smaller terminal than the one you recorded
-- the session on.
narrateGame :: Game s r -> GRec -> IO ()
narrateGame :: forall s r. Game s r -> GRec -> IO ()
narrateGame Game s r
g GRec
e = () () -> IO (Either r s) -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Narrate (Either r s) -> GRec -> IO (Either r s)
forall a. Narrate a -> GRec -> IO a
runReplay (Game s r -> Narrate (Either r s)
forall s r (m :: * -> *).
MonadGameIO m =>
Game s r -> m (Either r s)
runGameGeneral Game s r
g) GRec
e

-- | Play as in 'playGame' and write the session (input stream, etc.) to
-- @file@. Then you can use this with 'testGame' and 'narrateGame'. Session
-- will be recorded even if an exception happens while playing.
recordGame :: Game s r -> FilePath -> IO ()
recordGame :: forall s r. Game s r -> [Char] -> IO ()
recordGame Game s r
g [Char]
fp =
        IO (MVar GRec)
-> (MVar GRec -> IO ()) -> (MVar GRec -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
          (GRec -> IO (MVar GRec)
forall a. a -> IO (MVar a)
CC.newMVar GRec
igrec)
          (\MVar GRec
ve -> [Char] -> MVar GRec -> IO ()
writeRec [Char]
fp MVar GRec
ve)
          (\MVar GRec
ve -> () () -> IO (Either r s) -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Record (Either r s) -> MVar GRec -> IO (Either r s)
forall a. Record a -> MVar GRec -> IO a
runRecord (Game s r -> Record (Either r s)
forall s r (m :: * -> *).
MonadGameIO m =>
Game s r -> m (Either r s)
runGameGeneral Game s r
g) MVar GRec
ve)

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

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

            -- do it!
            let c :: Config
c = MVar [Event] -> Integer -> Config
Config MVar [Event]
ve Integer
tps in
            m (Either r s) -> m () -> m (Either r s)
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
cleanUpErr (MonadGameIO m => Config -> (Width, Width) -> m (Either r s)
Config -> (Width, Width) -> m (Either r s)
game Config
c (Width, Width)
ds)
                            -- this under will be run regardless
                       ([ThreadId] -> m ()
forall (m :: * -> *). MonadInput m => [ThreadId] -> m ()
stopEvents [ThreadId]
ts m () -> m () -> m ()
forall a b. m a -> m b -> m b
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 (Either r s)
          game :: MonadGameIO m => Config -> (Width, Width) -> m (Either r s)
game Config
c (Width, Width)
wds = Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m (Either r s)
forall (m :: * -> *) r s.
MonadGameIO m =>
Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m (Either r s)
gameLoop Config
c (s -> Either r s
forall a b. b -> Either a b
Right s
s) GEnv -> s -> Event -> Either r s
lf GEnv -> s -> Plane
df
                                Maybe Plane
forall a. Maybe a
Nothing (Width, Width)
wds
                                (Integer -> FPSCalc
creaFPSCalc Integer
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 :: forall a. 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 :: forall a. 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [Char] -> IO ()
putStrLn [Char]
"Stack trace info:\n" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [Char] -> IO ()
putStrLn [Char]
l

          atgDisplay :: ATGException -> IO a
          atgDisplay :: forall a. 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 :: forall a. IO () -> IO a
report IO ()
wm =
              [Char] -> IO ()
putStrLn [Char]
"ERROR REPORT\n"                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              IO ()
wm                                       IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              IO Char
getChar                                  IO Char -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
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
            Either r s        ->  -- state
            (GEnv ->
              s -> Event ->
              Either r s)     ->  -- logic function
            (GEnv ->
             s -> Plane)      ->  -- draw function
            Maybe Plane       ->  -- last blitted screen
            Dimensions        ->  -- Term dimensions
            FPSCalc           ->  -- calculate fps
            m (Either r s)
gameLoop :: forall (m :: * -> *) r s.
MonadGameIO m =>
Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m (Either r s)
gameLoop Config
c Either r s
s GEnv -> s -> Event -> Either r s
lf GEnv -> s -> Plane
df Maybe Plane
opln (Width, Width)
td FPSCalc
fps =

        -- Quit?
        m Bool
forall (m :: * -> *). MonadInput m => m Bool
areEventsOver m Bool -> (Bool -> m (Either r s)) -> m (Either r s)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
qb ->
            -- We will quit in case input stream (events) is exhausted.
            -- This might happen during test/narrate.
        if Either r s -> Bool
forall a b. Either a b -> Bool
ET.isLeft Either r s
s Bool -> Bool -> Bool
|| Bool
qb
          then Either r s -> m (Either r s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either r s
s
        else

        -- Fetch events (if any).
        -- This is safe as we checked for `areEventsOver` above.
        MVar [Event] -> m [Event]
forall (m :: * -> *). MonadInput m => MVar [Event] -> m [Event]
pollEvents (Config -> MVar [Event]
cMEvents Config
c) m [Event] -> ([Event] -> m (Either r s)) -> m (Either r s)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Event]
es ->

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

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

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

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

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

        -- clear screen if resolution changed
        let resc :: Bool
resc = (Width, Width)
td (Width, Width) -> (Width, Width) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Width, Width)
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 (Either r s) -> m (Either r s)
forall a b. m a -> m b -> m b
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 = case Either r s
s' of
                    (Right s
rs) -> GEnv -> s -> Plane
df GEnv
ge s
rs
                    (Left r
_) -> (Width -> Width -> Plane) -> (Width, Width) -> Plane
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Width -> Width -> Plane
blankPlane (Width, Width)
td'
                    -- In case the logic function came to an end
                    -- (Left), just print a blank plane.
        in

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

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

-- Int = number of `Tick` events
stepsLogic :: Either r s -> (s -> Event -> Either r s) -> [Event] ->
              (Integer, Either r s)
stepsLogic :: forall r s.
Either r s
-> (s -> Event -> Either r s) -> [Event] -> (Integer, Either r s)
stepsLogic Either r s
s s -> Event -> Either r s
lf [Event]
es = let ies :: Integer
ies = [Event] -> Integer
forall i a. Num i => [a] -> i
D.genericLength ([Event] -> Integer) -> ([Event] -> [Event]) -> [Event] -> Integer
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] -> Integer) -> [Event] -> Integer
forall a b. (a -> b) -> a -> b
$ [Event]
es
                     in (Integer
ies, (s -> Event -> Either r s) -> Either r s -> [Event] -> Either r s
forall s r.
(s -> Event -> Either r s) -> Either r s -> [Event] -> Either r s
logicFold s -> Event -> Either r s
lf Either r s
s [Event]
es)
    where
          isTick :: Event -> Bool
isTick Event
Tick = Bool
True
          isTick Event
_    = Bool
False

          logicFold :: (s -> Event -> Either r s) ->
                       Either r s -> [Event] -> Either r s
          logicFold :: forall s r.
(s -> Event -> Either r s) -> Either r s -> [Event] -> Either r s
logicFold s -> Event -> Either r s
_ (Left r
r) [Event]
_ = r -> Either r s
forall a b. a -> Either a b
Left r
r
          logicFold s -> Event -> Either r s
wlf (Right s
ws) [Event]
wes = (s -> Event -> Either r s) -> s -> [Event] -> Either r s
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
CM.foldM s -> Event -> Either r s
wlf s
ws [Event]
wes


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

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 :: Integer -> FPSCalc
creaFPSCalc Integer
tps = [Integer] -> Integer -> FPSCalc
FPSCalc (Integer -> Integer -> [Integer]
forall i a. Integral i => i -> a -> [a]
D.genericReplicate Integer
tps {- (tps*2) -} Integer
1) Integer
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 :: Integer -> FPSCalc -> FPSCalc
addFPS Integer
nt (FPSCalc (Integer
_:[Integer]
fps) Integer
tps) = [Integer] -> Integer -> FPSCalc
FPSCalc ([Integer]
fps [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer
nt]) Integer
tps
addFPS Integer
_ (FPSCalc [] Integer
_) = [Char] -> FPSCalc
forall a. HasCallStack => [Char] -> a
error [Char]
"addFPS: empty list."

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