-------------------------------------------------------------------------------
-- 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 { eTermDims :: Dimensions,
                   eFPS :: FPS }

-- | General way to create a 'Game'. This allows you more control by
-- exposing 'GEnv' (allows you to e.g. adapt to screen resizes, blit
-- FPS). If you fancy simple, sensible defaults, check 'simpleGame'.
data Game s =
        Game { 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).
               gInitState     :: s,   -- ^ Initial state of the game.
               gLogicFunction :: GEnv -> s -> Event -> s,
                                      -- ^ Logic function.
               gDrawFunction  :: GEnv -> s -> Plane,
                                      -- ^ Draw function.
               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.
              -> 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 (sw, sh) tps s lf df qf = Game tps s lf' df' qf
    where
          -- lf' :: GEnv -> s -> Event -> s
          lf' wen ws we
                | isSmaller (eTermDims wen) = ws
                | otherwise = lf ws we

          -- df' :: GEnv -> s -> Plane
          df' wen ws =
                let ds = eTermDims wen in
                if isSmaller ds
                  then smallMsg ds
                  else uncurry blankPlane ds *** df ws

          colS ww = ww < sw
          rowS wh = wh < sh
          isSmaller :: Dimensions -> Bool
          isSmaller (ww, wh) = colS ww || rowS wh

          smallMsg :: Dimensions -> Plane
          smallMsg (ww, wh) =
                let cm = show ww ++ " columns"
                    rm = show wh ++ " rows"
                    em | colS ww && rowS wh = cm ++ " and " ++ rm
                       | colS ww = cm
                       | rowS wh = rm
                       | otherwise = "smallMsg: passed correct term size!"
                in
                textBoxLiquid ww $
                  "This games requires a screen of " ++ show sw ++
                  " columns and " ++ show sh ++ " rows.\n" ++
                  "Yours only has " ++ em ++ "!\n\n" ++
                  "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 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 tps s lf df qf) =
            -- init
            setupDisplay    >>
            startEvents tps >>= \(InputHandle ve ts) ->
            displaySizeErr  >>= \ds ->

            -- do it!
            let c = Config ve tps in
            cleanUpErr (game c ds)
                            -- this under will be run regardless
                       (stopEvents ts >>
                        shutdownDisplay  )
    where
          game :: MonadGameIO m => Config -> Dimensions -> m s
          game c wds = gameLoop c s lf df qf
                                Nothing wds
                                (creaFPSCalc 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 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 $ print 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     =>
            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 c s lf df qf opln td fps =

        -- quit?
        checkQuit qf s >>= \qb ->
        if qb
          then return s
        else

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

        -- no events? skip everything
        if null es
          then sleepABit (cTPS c)               >>
               gameLoop c s lf df qf opln td fps
        else

        displaySizeErr            >>= \td' ->

        -- logic
        let ge = GEnv td' (calcFPS fps)
            (i, s') = stepsLogic s (lf ge) es in

        -- no `Tick` events? You do not need to blit, just update state
        if i == 0
          then gameLoop c s' lf df qf opln td fps
        else

        -- FPS calc
        let fps' = addFPS i fps in

        -- clear screen if resolution changed
        let resc = td /= td' in
        CM.when resc clearDisplay >>

        -- draw
        let opln' | resc = Nothing -- res changed? restart double buffering
                  | otherwise = opln
            npln = df ge s' in

        blitPlane opln' npln >>

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

-- Int = number of `Tick` events
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (Integer, s)
stepsLogic s lf es = let ies = D.genericLength . filter isTick $ es
                     in (ies, foldl lf s es)
    where
          isTick Tick = True
          isTick _    = 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 tps = FPSCalc (D.genericReplicate (tps*1) 1) 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 nt (FPSCalc (_:fps) tps) = FPSCalc (fps ++ [nt]) tps
addFPS _ (FPSCalc [] _) = error "addFPS: empty list."

calcFPS :: FPSCalc -> Integer
calcFPS (FPSCalc fps tps) =
        let ts = sum fps
            ds = D.genericLength fps
        in roundQuot (tps * ds) ts
    where
          roundQuot :: Integer -> Integer -> Integer
          roundQuot a b = let (q, r) = quotRem a b
                          in q + B.bool 0 1 (r > div b 2)