-------------------------------------------------------------------------------
-- 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 run -f
-- examples alone@) to see a simple game in action.
data Game s = Game {
        Game s -> Width
gScreenWidth   :: Width,           -- ^Gamescreen width, in columns.
        Game s -> Width
gScreenHeight  :: Height,          -- ^Gamescreen height, in rows.
        Game s -> TPS
gTPS           :: TPS,             -- ^Ticks per second. Since the
                                           -- 2D «char canvas» is coarse, you
                                           -- do not need a high value (e.g.
                                           -- 13 TPS is enough for action
                                           -- games).
        Game s -> s
gInitState     :: s,               -- ^Initial state of the game.
        Game s -> s -> Event -> s
gLogicFunction :: s -> Event -> s, -- ^Logic function.
        Game s -> s -> Plane
gDrawFunction  :: s -> Plane,      -- ^Draw function.
        Game s -> s -> Bool
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!
--
-- Throws 'DisplayTooSmall' if game widht/height cannot be accomodated
-- by terminal.
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 -> FilePath -> IO ()
recordGame Game s
g FilePath
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 -> FilePath -> MVar [Event] -> IO ()
writeMoves FilePath
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 -> TPS
cTPS     :: TPS              }

runGameGeneral :: forall s m. MonadGameIO m =>
                  Game s -> m s
runGameGeneral :: Game s -> m s
runGameGeneral (Game Width
gw Width
gh TPS
tps s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf) =
            -- init
            Width -> Width -> m ()
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
Width -> Width -> m ()
sizeException Width
gw Width
gh m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            m ()
forall (m :: * -> *). MonadDisplay m => m ()
setupDisplay     m () -> m InputHandle -> m InputHandle
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            TPS -> m InputHandle
forall (m :: * -> *). MonadInput m => TPS -> m InputHandle
startEvents TPS
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) ->

            -- do it!
            let c :: Config
c = MVar [Event] -> TPS -> Config
Config MVar [Event]
ve TPS
tps in
            m s -> m () -> m s
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
cleanUpErr (MonadGameIO m => Config -> m s
Config -> m s
game Config
c)
                            -- 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 -> m s
          game :: Config -> m s
game Config
c = Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
gameLoop Width
gw Width
gh Config
c
                            s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf
                            Maybe Plane
forall a. Maybe a
Nothing (Width
0,Width
0)


-- | 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 FilePath
cs FilePath
l) = IO () -> IO a
forall a. IO () -> IO a
report (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$
              FilePath -> IO ()
putStrLn (FilePath
cs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n\n")        IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              FilePath -> IO ()
putStrLn FilePath
"Stack trace info:\n" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              FilePath -> IO ()
putStrLn FilePath
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
$
              FilePath -> IO ()
putStrLn (ATGException -> FilePath
forall a. Show a => a -> FilePath
show ATGException
e)

          report :: IO () -> IO a
          report :: IO () -> IO a
report IO ()
wm =
              FilePath -> IO ()
putStrLn FilePath
"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
>>
              FilePath -> IO ()
putStrLn FilePath
"\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
>>
              FilePath -> IO a
forall a. FilePath -> a
errorWithoutStackTrace FilePath
"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 :: Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
gameLoop Width
gw Width
gh Config
c s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf Maybe Plane
opln (Width, Width)
td =

        -- 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 ->
            -- xxx test poll events si rompe se lo sposto su

        -- no events? skip everything
        if [Event] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
es
          then TPS -> m ()
forall (m :: * -> *). MonadTimer m => TPS -> m ()
sleepABit (Config -> TPS
cTPS Config
c)               m () -> m s -> m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
gameLoop Width
gw Width
gh Config
c s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf Maybe Plane
opln (Width, Width)
td
               -- xxx reader monad qui
        else

        -- logic
        let s' :: s
s' = s -> (s -> Event -> s) -> [Event] -> s
forall s. s -> (s -> Event -> s) -> [Event] -> s
stepsLogic s
s s -> Event -> s
lf [Event]
es in

        -- clear screen if resolution change
        m (Width, Width)
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m (Width, Width)
displaySizeErr            m (Width, Width) -> ((Width, Width) -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \td' :: (Width, Width)
td'@(Width
tw, Width
th) ->
        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 s -> m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

        -- draw
        -- xxx solo se è tick e non kpress? [loop]
        let opln' :: Maybe Plane
opln' | Bool
resc = Maybe Plane
forall a. Maybe a
Nothing -- res changed? restart double buffering
                  | Bool
otherwise = Maybe Plane
opln
            gpl :: Plane
gpl   = Width -> Width -> Plane
blankPlane Width
gw Width
gh
            npln :: Plane
npln  = Plane -> Plane -> (Width, Width) -> Plane
pastePlane (s -> Plane
df s
s') Plane
gpl (Width
1, Width
1) in
        Width -> Width -> Maybe Plane -> Plane -> m ()
forall (m :: * -> *).
MonadDisplay m =>
Width -> Width -> Maybe Plane -> Plane -> m ()
blitPlane Width
tw Width
th Maybe Plane
opln' Plane
npln m () -> m s -> m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

        Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Width
-> Width
-> Config
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> m s
gameLoop Width
gw Width
gh Config
c s
s' s -> Event -> s
lf s -> Plane
df s -> Bool
qf (Plane -> Maybe Plane
forall a. a -> Maybe a
Just Plane
npln) (Width, Width)
td'


stepsLogic :: s -> (s -> Event -> s) -> [Event] -> s
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> s
stepsLogic s
s s -> Event -> s
lf [Event]
es = (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


-----------------
-- ANCILLARIES --
-----------------

sizeException :: (MonadDisplay m, MonadException m) => Width -> Height -> m ()
sizeException :: Width -> Width -> m ()
sizeException Width
gw Width
gh =
        m (Width, Width)
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m (Width, Width)
displaySizeErr m (Width, Width) -> ((Width, Width) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Width
sw, Width
sh) ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
CM.when (Width
gw Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
sw Bool -> Bool -> Bool
|| Width
gh Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
sh)
                (ATGException -> m ()
forall (m :: * -> *) a. MonadException m => ATGException -> m a
throwExc (ATGException -> m ()) -> ATGException -> m ()
forall a b. (a -> b) -> a -> b
$ (Width, Width) -> (Width, Width) -> ATGException
DisplayTooSmall (Width
gw, Width
gh) (Width
sw, Width
sh))