{-# 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
data Game s =
Game { Game s -> TPS
gTPS :: TPS,
Game s -> s
gInitState :: s,
Game s -> GEnv -> s -> Event -> s
gLogicFunction :: GEnv -> s -> Event -> s,
Game s -> GEnv -> s -> Plane
gDrawFunction :: GEnv -> s -> Plane,
Game s -> s -> Bool
gQuitFunction :: s -> Bool
}
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)
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 -> 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)
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)
testGame :: Game s -> GRec -> s
testGame :: Game s -> GRec -> s
testGame Game s
g GRec
ts = (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 -> GRec -> (s, [TestEvent])
forall a. Test a -> GRec -> (a, [TestEvent])
runTest (Game s -> Test s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g) GRec
ts
setupGame :: Game s -> GRec -> Game s
setupGame :: Game s -> GRec -> Game s
setupGame Game s
g GRec
ts = let s' :: s
s' = Game s -> GRec -> s
forall s. Game s -> GRec -> s
testGame Game s
g GRec
ts
in Game s
g { gInitState :: s
gInitState = s
s' }
narrateGame :: Game s -> GRec -> IO s
narrateGame :: Game s -> GRec -> IO s
narrateGame Game s
g GRec
e = Narrate s -> GRec -> IO s
forall a. Narrate a -> GRec -> IO a
runReplay (Game s -> Narrate s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g) GRec
e
recordGame :: Game s -> FilePath -> IO ()
recordGame :: Game s -> FilePath -> IO ()
recordGame Game s
g FilePath
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 -> FilePath -> MVar GRec -> IO ()
writeRec FilePath
fp MVar GRec
ve)
(\MVar GRec
ve -> () () -> IO s -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Record s -> MVar GRec -> IO s
forall a. Record a -> MVar GRec -> IO a
runRecord (Game s -> Record s
forall s (m :: * -> *). MonadGameIO m => Game s -> m s
runGameGeneral Game s
g) MVar GRec
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 TPS
tps s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf) =
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) ->
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
>>= \(Width, Width)
ds ->
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 -> (Width, Width) -> m s
Config -> (Width, Width) -> m s
game Config
c (Width, Width)
ds)
([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 -> (Width, Width) -> m s
game Config
c (Width, Width)
wds = Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> 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 (Width, Width)
wds
(TPS -> FPSCalc
creaFPSCalc TPS
tps)
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
$ ATGException -> IO ()
forall a. Show a => a -> IO ()
print 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"
gameLoop :: MonadGameIO m =>
Config ->
s ->
(GEnv ->
s -> Event -> s) ->
(GEnv ->
s -> Plane) ->
(s -> Bool) ->
Maybe Plane ->
Dimensions ->
FPSCalc ->
m s
gameLoop :: Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln (Width, Width)
td FPSCalc
fps =
(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
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 ->
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
>>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf 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 s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Width, Width)
td' ->
let ge :: GEnv
ge = (Width, Width) -> TPS -> GEnv
GEnv (Width, Width)
td' (FPSCalc -> TPS
calcFPS FPSCalc
fps)
(TPS
i, s
s') = s -> (s -> Event -> s) -> [Event] -> (TPS, s)
forall s. s -> (s -> Event -> s) -> [Event] -> (TPS, s)
stepsLogic s
s (GEnv -> s -> Event -> s
lf GEnv
ge) [Event]
es in
if TPS
i TPS -> TPS -> Bool
forall a. Eq a => a -> a -> Bool
== TPS
0
then Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> FPSCalc
-> m s
gameLoop Config
c s
s' GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln (Width, Width)
td FPSCalc
fps
else
let fps' :: FPSCalc
fps' = TPS -> FPSCalc -> FPSCalc
addFPS TPS
i FPSCalc
fps in
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
>>
let opln' :: Maybe Plane
opln' | Bool
resc = Maybe Plane
forall a. Maybe a
Nothing
| 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
-> (Width, Width)
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> (Width, Width)
-> 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) (Width, Width)
td' FPSCalc
fps'
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (Integer, s)
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (TPS, s)
stepsLogic s
s s -> Event -> s
lf [Event]
es = let ies :: TPS
ies = [Event] -> TPS
forall i a. Num i => [a] -> i
D.genericLength ([Event] -> TPS) -> ([Event] -> [Event]) -> [Event] -> TPS
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] -> TPS) -> [Event] -> TPS
forall a b. (a -> b) -> a -> b
$ [Event]
es
in (TPS
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
data FPSCalc = FPSCalc [Integer] TPS
creaFPSCalc :: TPS -> FPSCalc
creaFPSCalc :: TPS -> FPSCalc
creaFPSCalc TPS
tps = [TPS] -> TPS -> FPSCalc
FPSCalc (TPS -> TPS -> [TPS]
forall i a. Integral i => i -> a -> [a]
D.genericReplicate TPS
tps TPS
1) TPS
tps
addFPS :: Integer -> FPSCalc -> FPSCalc
addFPS :: TPS -> FPSCalc -> FPSCalc
addFPS TPS
nt (FPSCalc (TPS
_:[TPS]
fps) TPS
tps) = [TPS] -> TPS -> FPSCalc
FPSCalc ([TPS]
fps [TPS] -> [TPS] -> [TPS]
forall a. [a] -> [a] -> [a]
++ [TPS
nt]) TPS
tps
addFPS TPS
_ (FPSCalc [] TPS
_) = FilePath -> FPSCalc
forall a. HasCallStack => FilePath -> a
error FilePath
"addFPS: empty list."
calcFPS :: FPSCalc -> Integer
calcFPS :: FPSCalc -> TPS
calcFPS (FPSCalc [TPS]
fps TPS
tps) =
let ts :: TPS
ts = [TPS] -> TPS
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [TPS]
fps
ds :: TPS
ds = [TPS] -> TPS
forall i a. Num i => [a] -> i
D.genericLength [TPS]
fps
in TPS -> TPS -> TPS
roundQuot (TPS
tps TPS -> TPS -> TPS
forall a. Num a => a -> a -> a
* TPS
ds) TPS
ts
where
roundQuot :: Integer -> Integer -> Integer
roundQuot :: TPS -> TPS -> TPS
roundQuot TPS
a TPS
b = let (TPS
q, TPS
r) = TPS -> TPS -> (TPS, TPS)
forall a. Integral a => a -> a -> (a, a)
quotRem TPS
a TPS
b
in TPS
q TPS -> TPS -> TPS
forall a. Num a => a -> a -> a
+ TPS -> TPS -> Bool -> TPS
forall a. a -> a -> Bool -> a
B.bool TPS
0 TPS
1 (TPS
r TPS -> TPS -> Bool
forall a. Ord a => a -> a -> Bool
> TPS -> TPS -> TPS
forall a. Integral a => a -> a -> a
div TPS
b TPS
2)