{-# 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
data Game s = Game {
Game s -> Width
gScreenWidth :: Width,
Game s -> Width
gScreenHeight :: Height,
Game s -> FPS
gFPS :: FPS,
Game s -> s
gInitState :: s,
Game s -> s -> Event -> s
gLogicFunction :: s -> Event -> s,
Game s -> s -> Plane
gDrawFunction :: s -> Plane,
Game s -> s -> Bool
gQuitFunction :: s -> Bool
}
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 -> 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 -> FPS
cFPS :: FPS }
runGameGeneral :: forall s m. MonadGameIO m =>
Game s -> m s
runGameGeneral :: Game s -> m s
runGameGeneral (Game Width
gw Width
gh FPS
fps s
s s -> Event -> s
lf s -> Plane
df s -> Bool
qf) =
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
>>
FPS -> m InputHandle
forall (m :: * -> *). MonadInput m => FPS -> m InputHandle
startEvents FPS
fps 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) ->
let c :: Config
c = MVar [Event] -> FPS -> Config
Config MVar [Event]
ve FPS
fps 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)
([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)
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"
gameLoop :: MonadGameIO m =>
Width ->
Height ->
Config ->
s ->
(s -> Event -> s) ->
(s -> Plane) ->
(s -> Bool) ->
Maybe Plane ->
(Width, Height) ->
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 =
(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
cFPS 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
else
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
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
>>
let opln' :: Maybe Plane
opln' | Bool
resc = Maybe Plane
forall a. Maybe a
Nothing
| 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
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))