{-# 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
data Game s r = Game {
forall s r. Game s r -> Integer
gTPS :: TPS,
forall s r. Game s r -> s
gInitState :: s,
forall s r. Game s r -> GEnv -> s -> Event -> Either r s
gLogicFunction :: GEnv -> s -> Event -> Either r s,
forall s r. Game s r -> GEnv -> s -> Plane
gDrawFunction :: GEnv -> s -> Plane
}
blankPlaneFull :: GEnv -> Plane
blankPlaneFull :: GEnv -> Plane
blankPlaneFull GEnv
e = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Width -> Width -> Plane
blankPlane (GEnv -> Dimensions
eTermDims GEnv
e)
centerFull :: GEnv -> Plane -> Plane
centerFull :: GEnv -> Plane -> Plane
centerFull GEnv
e Plane
p = GEnv -> Plane
blankPlaneFull GEnv
e Plane -> Plane -> Plane
*** Plane
p
playGame :: Game s r -> IO r
playGame :: forall s r. Game s r -> IO r
playGame Game s r
g = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a. HasCallStack => [Char] -> a
error [Char]
"`Right` in playGame") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. GameIO a -> IO a
runGIO (forall s r (m :: * -> *).
MonadGameIO m =>
Game s r -> m (Either r s)
runGameGeneral Game s r
g)
playGame_ :: Game s r -> IO ()
playGame_ :: forall s r. Game s r -> IO ()
playGame_ Game s r
g = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s r. Game s r -> IO r
playGame Game s r
g
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 forall a. Test a -> GRec -> (Maybe a, [TestEvent])
runTest (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) -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"testGame, exception called: " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show [TestEvent]
l
(Just Either r s
s, [TestEvent]
_) -> Either r s
s
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' = forall s r. Game s r -> GRec -> Either r s
testGame Game s r
g GRec
ts
in case Either r s
s' of
Left r
r -> Game s r
g { gLogicFunction :: GEnv -> s -> Event -> Either r s
gLogicFunction = \GEnv
_ s
_ Event
_ -> forall a b. a -> Either a b
Left r
r }
Right s
s -> Game s r
g { gInitState :: s
gInitState = s
s }
narrateGame :: Game s r -> GRec -> IO ()
narrateGame :: forall s r. Game s r -> GRec -> IO ()
narrateGame Game s r
g GRec
e = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Narrate a -> GRec -> IO a
runReplay (forall s r (m :: * -> *).
MonadGameIO m =>
Game s r -> m (Either r s)
runGameGeneral Game s r
g) GRec
e
recordGame :: Game s r -> FilePath -> IO ()
recordGame :: forall s r. Game s r -> [Char] -> IO ()
recordGame Game s r
g [Char]
fp =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
(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 -> () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Record a -> MVar GRec -> IO a
runRecord (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) =
forall (m :: * -> *). MonadDisplay m => m ()
setupDisplay forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *). MonadInput m => Integer -> m InputHandle
startEvents Integer
tps forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(InputHandle MVar [Event]
ve [ThreadId]
ts) ->
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Dimensions
ds ->
let c :: Config
c = MVar [Event] -> Integer -> Config
Config MVar [Event]
ve Integer
tps in
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
cleanUpErr (MonadGameIO m => Config -> Dimensions -> m (Either r s)
game Config
c Dimensions
ds)
(forall (m :: * -> *). MonadInput m => [ThreadId] -> m ()
stopEvents [ThreadId]
ts forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *). MonadDisplay m => m ()
shutdownDisplay )
where
game :: MonadGameIO m => Config -> Dimensions -> m (Either r s)
game :: MonadGameIO m => Config -> Dimensions -> m (Either r s)
game Config
c Dimensions
wds = forall (m :: * -> *) r s.
MonadGameIO m =>
Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m (Either r s)
gameLoop Config
c (forall a b. b -> Either a b
Right s
s) GEnv -> s -> Event -> Either r s
lf GEnv -> s -> Plane
df
forall a. Maybe a
Nothing Dimensions
wds
(Integer -> FPSCalc
creaFPSCalc Integer
tps)
errorPress :: IO a -> IO a
errorPress :: forall a. IO a -> IO a
errorPress IO a
m = forall a. IO a -> [Handler a] -> IO a
E.catches IO a
m [forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler forall a. ErrorCall -> IO a
errorDisplay,
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler 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) = forall a. IO () -> IO a
report forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLn ([Char]
cs forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[Char] -> IO ()
putStrLn [Char]
"Stack trace info:\n" 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 = forall a. IO () -> IO a
report forall a b. (a -> b) -> a -> b
$ 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" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
IO ()
wm forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[Char] -> IO ()
putStrLn [Char]
"\n\n <Press any key to quit>" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Handle -> BufferMode -> IO ()
SI.hSetBuffering Handle
SI.stdin BufferMode
SI.NoBuffering forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
IO Char
getChar forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"errorPress"
gameLoop :: MonadGameIO m =>
Config ->
Either r s ->
(GEnv ->
s -> Event ->
Either r s) ->
(GEnv ->
s -> Plane) ->
Maybe Plane ->
Dimensions ->
FPSCalc ->
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
-> Dimensions
-> 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 Dimensions
td FPSCalc
fps =
forall (m :: * -> *). MonadInput m => m Bool
areEventsOver forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
qb ->
if forall a b. Either a b -> Bool
ET.isLeft Either r s
s Bool -> Bool -> Bool
|| Bool
qb
then forall (m :: * -> *) a. Monad m => a -> m a
return Either r s
s
else
forall (m :: * -> *). MonadInput m => MVar [Event] -> m [Event]
pollEvents (Config -> MVar [Event]
cMEvents Config
c) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Event]
es ->
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
es
then forall (m :: * -> *). MonadTimer m => Integer -> m ()
sleepABit (Config -> Integer
cTPS Config
c) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *) r s.
MonadGameIO m =>
Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> Dimensions
-> 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 Dimensions
td FPSCalc
fps
else
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Dimensions
td' ->
let ge :: GEnv
ge = Dimensions -> Integer -> GEnv
GEnv Dimensions
td' (FPSCalc -> Integer
calcFPS FPSCalc
fps)
(Integer
i, Either r s
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
if Integer
i forall a. Eq a => a -> a -> Bool
== Integer
0
then forall (m :: * -> *) r s.
MonadGameIO m =>
Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> Dimensions
-> 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 Dimensions
td FPSCalc
fps
else
let fps' :: FPSCalc
fps' = Integer -> FPSCalc -> FPSCalc
addFPS Integer
i FPSCalc
fps in
let resc :: Bool
resc = Dimensions
td forall a. Eq a => a -> a -> Bool
/= Dimensions
td' in
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
CM.when Bool
resc forall (m :: * -> *). MonadDisplay m => m ()
clearDisplay forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
let
opln' :: Maybe Plane
opln' | Bool
resc = forall a. Maybe a
Nothing
| 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
_) -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Width -> Width -> Plane
blankPlane Dimensions
td'
in
forall (m :: * -> *).
MonadDisplay m =>
Maybe Plane -> Plane -> m ()
blitPlane Maybe Plane
opln' Plane
npln forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *) r s.
MonadGameIO m =>
Config
-> Either r s
-> (GEnv -> s -> Event -> Either r s)
-> (GEnv -> s -> Plane)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m (Either r s)
gameLoop Config
c Either r s
s' GEnv -> s -> Event -> Either r s
lf GEnv -> s -> Plane
df (forall a. a -> Maybe a
Just Plane
npln) Dimensions
td' FPSCalc
fps'
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 = forall i a. Num i => [a] -> i
D.genericLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Event -> Bool
isTick forall a b. (a -> b) -> a -> b
$ [Event]
es
in (Integer
ies, 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]
_ = forall a b. a -> Either a b
Left r
r
logicFold s -> Event -> Either r s
wlf (Right s
ws) [Event]
wes = 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
data FPSCalc = FPSCalc [Integer] TPS
creaFPSCalc :: TPS -> FPSCalc
creaFPSCalc :: Integer -> FPSCalc
creaFPSCalc Integer
tps = [Integer] -> Integer -> FPSCalc
FPSCalc (forall i a. Integral i => i -> a -> [a]
D.genericReplicate Integer
tps Integer
1) Integer
tps
addFPS :: Integer -> FPSCalc -> FPSCalc
addFPS :: Integer -> FPSCalc -> FPSCalc
addFPS Integer
nt (FPSCalc (Integer
_:[Integer]
fps) Integer
tps) = [Integer] -> Integer -> FPSCalc
FPSCalc ([Integer]
fps forall a. [a] -> [a] -> [a]
++ [Integer
nt]) Integer
tps
addFPS Integer
_ (FPSCalc [] Integer
_) = 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 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
fps
ds :: Integer
ds = forall i a. Num i => [a] -> i
D.genericLength [Integer]
fps
in Integer -> Integer -> Integer
roundQuot (Integer
tps 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) = forall a. Integral a => a -> a -> (a, a)
quotRem Integer
a Integer
b
in Integer
q forall a. Num a => a -> a -> a
+ forall a. a -> a -> Bool -> a
B.bool Integer
0 Integer
1 (Integer
r forall a. Ord a => a -> a -> Bool
> forall a. Integral a => a -> a -> a
div Integer
b Integer
2)