{-# 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 GEnv = GEnv { GEnv -> Dimensions
eTermDims :: Dimensions,
GEnv -> FPS
eFPS :: FPS }
data Game s =
Game { Game s -> FPS
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
}
simpleGame :: Dimensions
-> TPS
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Game s
simpleGame :: Dimensions
-> FPS
-> s
-> (s -> Event -> s)
-> (s -> Plane)
-> (s -> Bool)
-> Game s
simpleGame (Width
sw, Width
sh) FPS
tps s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf = FPS
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Game s
forall s.
FPS
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Game s
Game FPS
tps s
s GEnv -> s -> Event -> s
lf' GEnv -> s -> Plane
df' s -> Bool
qf
where
lf' :: GEnv -> s -> Event -> s
lf' GEnv
wen s
ws Event
we
| Dimensions -> Bool
isSmaller (GEnv -> Dimensions
eTermDims GEnv
wen) = s
ws
| Bool
otherwise = s -> Event -> s
lf s
ws Event
we
df' :: GEnv -> s -> Plane
df' GEnv
wen s
ws =
let ds :: Dimensions
ds = GEnv -> Dimensions
eTermDims GEnv
wen in
if Dimensions -> Bool
isSmaller Dimensions
ds
then Dimensions -> Plane
smallMsg Dimensions
ds
else (Width -> Width -> Plane) -> Dimensions -> Plane
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Width -> Width -> Plane
blankPlane Dimensions
ds Plane -> Plane -> Plane
*** s -> Plane
df s
ws
colS :: Width -> Bool
colS Width
ww = Width
ww Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
sw
rowS :: Width -> Bool
rowS Width
wh = Width
wh Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
sh
isSmaller :: Dimensions -> Bool
isSmaller :: Dimensions -> Bool
isSmaller (Width
ww, Width
wh) = Width -> Bool
colS Width
ww Bool -> Bool -> Bool
|| Width -> Bool
rowS Width
wh
smallMsg :: Dimensions -> Plane
smallMsg :: Dimensions -> Plane
smallMsg (Width
ww, Width
wh) =
let cm :: [Char]
cm = Width -> [Char]
forall a. Show a => a -> [Char]
show Width
ww [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" columns"
rm :: [Char]
rm = Width -> [Char]
forall a. Show a => a -> [Char]
show Width
wh [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" rows"
em :: [Char]
em | Width -> Bool
colS Width
ww Bool -> Bool -> Bool
&& Width -> Bool
rowS Width
wh = [Char]
cm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rm
| Width -> Bool
colS Width
ww = [Char]
cm
| Width -> Bool
rowS Width
wh = [Char]
rm
| Bool
otherwise = [Char]
"smallMsg: passed correct term size!"
in
Width -> [Char] -> Plane
textBoxLiquid Width
ww ([Char] -> Plane) -> [Char] -> Plane
forall a b. (a -> b) -> a -> b
$
[Char]
"This games requires a screen of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Width -> [Char]
forall a. Show a => a -> [Char]
show Width
sw [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
" columns and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Width -> [Char]
forall a. Show a => a -> [Char]
show Width
sh [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" rows.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"Yours only has " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
em [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"Please resize your terminal now!"
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 -> [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)
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' }
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
recordGame :: Game s -> FilePath -> IO ()
recordGame :: Game s -> [Char] -> IO ()
recordGame Game s
g [Char]
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 -> [Char] -> MVar [Event] -> IO ()
writeMoves [Char]
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 -> FPS
cTPS :: TPS }
runGameGeneral :: forall s m. MonadGameIO m =>
Game s -> m s
runGameGeneral :: Game s -> m s
runGameGeneral (Game FPS
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
>>
FPS -> m InputHandle
forall (m :: * -> *). MonadInput m => FPS -> m InputHandle
startEvents FPS
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 Dimensions
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr m Dimensions -> (Dimensions -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Dimensions
ds ->
let c :: Config
c = MVar [Event] -> FPS -> Config
Config MVar [Event]
ve FPS
tps in
m s -> m () -> m s
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
cleanUpErr (MonadGameIO m => Config -> Dimensions -> m s
Config -> Dimensions -> m s
game Config
c Dimensions
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 -> Dimensions -> m s
game Config
c Dimensions
wds = Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> 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 Dimensions
wds
(FPS -> FPSCalc
creaFPSCalc FPS
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 [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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[Char] -> IO ()
putStrLn [Char]
"Stack trace info:\n" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[Char] -> IO ()
putStrLn [Char]
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 =
[Char] -> IO ()
putStrLn [Char]
"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
>>
[Char] -> IO ()
putStrLn [Char]
"\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
>>
[Char] -> IO a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"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
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln Dimensions
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 FPS -> m ()
forall (m :: * -> *). MonadTimer m => FPS -> m ()
sleepABit (Config -> FPS
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
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln Dimensions
td FPSCalc
fps
else
m Dimensions
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr m Dimensions -> (Dimensions -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Dimensions
td' ->
let ge :: GEnv
ge = Dimensions -> FPS -> GEnv
GEnv Dimensions
td' (FPSCalc -> FPS
calcFPS FPSCalc
fps)
(FPS
i, s
s') = s -> (s -> Event -> s) -> [Event] -> (FPS, s)
forall s. s -> (s -> Event -> s) -> [Event] -> (FPS, s)
stepsLogic s
s (GEnv -> s -> Event -> s
lf GEnv
ge) [Event]
es in
if FPS
i FPS -> FPS -> Bool
forall a. Eq a => a -> a -> Bool
== FPS
0
then Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> FPSCalc
-> m s
gameLoop Config
c s
s' GEnv -> s -> Event -> s
lf GEnv -> s -> Plane
df s -> Bool
qf Maybe Plane
opln Dimensions
td FPSCalc
fps
else
let fps' :: FPSCalc
fps' = FPS -> FPSCalc -> FPSCalc
addFPS FPS
i FPSCalc
fps in
let resc :: Bool
resc = Dimensions
td Dimensions -> Dimensions -> Bool
forall a. Eq a => a -> a -> Bool
/= Dimensions
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
-> Dimensions
-> FPSCalc
-> m s
forall (m :: * -> *) s.
MonadGameIO m =>
Config
-> s
-> (GEnv -> s -> Event -> s)
-> (GEnv -> s -> Plane)
-> (s -> Bool)
-> Maybe Plane
-> Dimensions
-> 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) Dimensions
td' FPSCalc
fps'
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (Integer, s)
stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (FPS, s)
stepsLogic s
s s -> Event -> s
lf [Event]
es = let ies :: FPS
ies = [Event] -> FPS
forall i a. Num i => [a] -> i
D.genericLength ([Event] -> FPS) -> ([Event] -> [Event]) -> [Event] -> FPS
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] -> FPS) -> [Event] -> FPS
forall a b. (a -> b) -> a -> b
$ [Event]
es
in (FPS
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
type FPS = Integer
data FPSCalc = FPSCalc [Integer] TPS
creaFPSCalc :: TPS -> FPSCalc
creaFPSCalc :: FPS -> FPSCalc
creaFPSCalc FPS
tps = [FPS] -> FPS -> FPSCalc
FPSCalc (FPS -> FPS -> [FPS]
forall i a. Integral i => i -> a -> [a]
D.genericReplicate (FPS
tpsFPS -> FPS -> FPS
forall a. Num a => a -> a -> a
*FPS
1) FPS
1) FPS
tps
addFPS :: Integer -> FPSCalc -> FPSCalc
addFPS :: FPS -> FPSCalc -> FPSCalc
addFPS FPS
nt (FPSCalc (FPS
_:[FPS]
fps) FPS
tps) = [FPS] -> FPS -> FPSCalc
FPSCalc ([FPS]
fps [FPS] -> [FPS] -> [FPS]
forall a. [a] -> [a] -> [a]
++ [FPS
nt]) FPS
tps
addFPS FPS
_ (FPSCalc [] FPS
_) = [Char] -> FPSCalc
forall a. HasCallStack => [Char] -> a
error [Char]
"addFPS: empty list."
calcFPS :: FPSCalc -> Integer
calcFPS :: FPSCalc -> FPS
calcFPS (FPSCalc [FPS]
fps FPS
tps) =
let ts :: FPS
ts = [FPS] -> FPS
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [FPS]
fps
ds :: FPS
ds = [FPS] -> FPS
forall i a. Num i => [a] -> i
D.genericLength [FPS]
fps
in FPS -> FPS -> FPS
roundQuot (FPS
tps FPS -> FPS -> FPS
forall a. Num a => a -> a -> a
* FPS
ds) FPS
ts
where
roundQuot :: Integer -> Integer -> Integer
roundQuot :: FPS -> FPS -> FPS
roundQuot FPS
a FPS
b = let (FPS
q, FPS
r) = FPS -> FPS -> (FPS, FPS)
forall a. Integral a => a -> a -> (a, a)
quotRem FPS
a FPS
b
in FPS
q FPS -> FPS -> FPS
forall a. Num a => a -> a -> a
+ FPS -> FPS -> Bool -> FPS
forall a. a -> a -> Bool -> a
B.bool FPS
0 FPS
1 (FPS
r FPS -> FPS -> Bool
forall a. Ord a => a -> a -> Bool
> FPS -> FPS -> FPS
forall a. Integral a => a -> a -> a
div FPS
b FPS
2)