commit 19ea926788fba9a248fc93ffe5815b131a5e35f6
parent 347632ef69d32fbdd8af2e8d81e9e7eea8c479b7
Author: Francesco Ariis <fa-ml@ariis.it>
Date: Tue, 28 Feb 2023 20:18:54 +0100
Move logic function to `Either r s`
Diffstat:
19 files changed, 232 insertions(+), 130 deletions(-)
diff --git a/NEWS b/NEWS
@@ -1,6 +1,57 @@
next
----
+tl;dr and migration guide:
+- This version of ansi-terminal-games has a new signature for logic
+ function:
+ gLogicFunction :: GEnv -> s -> Event -> Either r s
+- Notice the `Either r s`: `Left` means “game is over”; `Right`means
+ “game continues.
+- To migrate a project to 1.9.0.0 you should:
+ - Adjust logic function to incorporate those changes.
+ - Get rid of your `quitFunction` in your `Game`.
+ - Modify every `Game s` to `Game s ()`.
+
+Breaking changes:
+- This version changes the logic function from
+ gLogicFunction :: GEnv -> s -> Event -> s
+ to
+ gLogicFunction :: GEnv -> s -> Event -> Either r s
+ `Either r s` is a way to explicitly state whether the game is over
+ not not. If you return `Left $ …` then the game will stop, if you
+ return `Right $ …` your game will continue.
+- the `r` stands for `result` and is present in the type constructor
+ too:
+ Game s r -- A game with state `s` which will,
+ -- upon exit, return a result `r`.
+- Usually r is () (as simple games do not care about end results,
+ they just quit to terminal). But there are cases (games embedded
+ in a larger program, a set of minigames, high scores) where you
+ want to return something and this is the way to do it.
+- Many other functions have had a slight change of signature to
+ accomodate this change
+ playGame :: Game s r -> IO r
+ narrateGame :: Game s r -> GRec -> IO ()
+ testGame :: Game s -> GRec -> Either s r
+ I will spend some second on the test function. A game tested in
+ a pure environment will end in two ways: a) by reaching Left
+ (proper end game) b) by exhausting the input stream.
+ In case b) we cannot return a result `r`, but just a half-baked
+ ingame state. This is very useful for testing purposes.
+ A trick that I do is this: record events with `recordGame` and
+ then press Ctrl-C midgame. This way the stream is cut and I will
+ get a `Right` state when running `testGame`. I can then analyse
+ the resulting state.
+- Functions have been deleted too
+ playGame :: Game s -> IO s
+ is no more
+- And new functions were introduced:
+ playGame_ :: Game s r -> IO () -- discard result
+- The change was suggested by Gergő Érdi, whom I thank.
+ The rationale was to improve ergonomics for the game-makes, I
+ welcome feedback from you.
+
+Other changes:
- Clarified KeyPress and Tick behaviour. tl;dr: *all* keypresses are
recorded and fed to your game-logic function. If your played manages
to type the Divine Comedy in the space of a Tick, all those characters
diff --git a/ansi-terminal-game.cabal b/ansi-terminal-game.cabal
@@ -21,8 +21,9 @@ build-type: Simple
extra-source-files: README,
NEWS,
AUTHORS,
- test/records/alone-record-test.gr
- test/records/balls-dims.gr
+ test/records/alone-record-test.gr,
+ test/records/alone-record-left.gr,
+ test/records/balls-dims.gr,
test/records/balls-slow.gr
cabal-version: >=1.10
diff --git a/example/Alone.hs b/example/Alone.hs
@@ -8,14 +8,12 @@ import Terminal.Game
import qualified Data.Tuple as T
-- game specification
-aloneInARoom :: Game MyState
+aloneInARoom :: Game MyState ()
aloneInARoom = Game 13 -- ticks per second
- (MyState (10, 10)
- Stop False) -- init state
+ (MyState (10, 10) Stop) -- init state
(\_ s e -> logicFun s e) -- logic function
(\r s -> centerFull r $
drawFun s) -- draw function
- gsQuit -- quit function
sizeCheck :: IO ()
sizeCheck = let (w, h) = T.swap . snd $ boundaries
@@ -25,8 +23,7 @@ sizeCheck = let (w, h) = T.swap . snd $ boundaries
-- Types
data MyState = MyState { gsCoord :: Coords,
- gsMove :: Move,
- gsQuit :: Bool }
+ gsMove :: Move }
deriving (Show, Eq)
data Move = N | S | E | W | Stop
@@ -38,10 +35,11 @@ boundaries = ((1, 1), (24, 80))
-------------------------------------------------------------------------------
-- Logic
-logicFun :: MyState -> Event -> MyState
-logicFun gs (KeyPress 'q') = gs { gsQuit = True }
-logicFun gs Tick = gs { gsCoord = pos (gsMove gs) (gsCoord gs) }
-logicFun gs (KeyPress c) = gs { gsMove = move (gsMove gs) c }
+logicFun :: MyState -> Event -> Either () MyState
+logicFun _ (KeyPress 'q') = Left ()
+logicFun gs Tick = Right $ gs { gsCoord = pos (gsMove gs)
+ (gsCoord gs) }
+logicFun gs (KeyPress c) = Right $ gs { gsMove = move (gsMove gs) c }
-- SCI movement
move :: Move -> Char -> Move
@@ -75,7 +73,7 @@ pos m oldcs | oob newcs = oldcs
-- Draw
drawFun :: MyState -> Plane
-drawFun (MyState (r, c) _ _) =
+drawFun (MyState (r, c) _) =
blankPlane mw mh &
(1, 1) % box mw mh '.' &
(2, 2) % box (mw-2) (mh-2) ' ' &
diff --git a/example/Balls.hs b/example/Balls.hs
@@ -117,33 +117,35 @@ dtimer (_, i) = word . show $ i
-- Game
data GState = GState { gen :: StdGen,
- quit :: Bool,
timer :: Timer,
balls :: [Ball],
bslow :: Bool }
-- pSlow is not used in game, it is there just
-- for the test suite
-fireworks :: StdGen -> Game GState
-fireworks g = Game tps istate lfun dfun qfun
+fireworks :: StdGen -> Game GState Int
+fireworks g = Game tps istate lfun dfun
where
tps = 60
istate :: GState
- istate = GState g False (ctimer tps) [] False
+ istate = GState g (ctimer tps) [] False
-------------------------------------------------------------------------------
-- Logic
-lfun :: GEnv -> GState -> Event -> GState
+-- The `Int` in `Either Int Gstate` is: number of balls
+-- on screen at the end of the game.
+lfun :: GEnv -> GState -> Event -> Either Int GState
lfun e s (KeyPress 's') =
let g = gen s
ds = eTermDims e
(b, g1) = genBall g ds
- in s { gen = g1,
- balls = b : balls s }
-lfun _ s (KeyPress 'q') = s { quit = True }
-lfun _ s (KeyPress _) = s
+ s' = s { gen = g1,
+ balls = b : balls s }
+ in Right s'
+lfun _ s (KeyPress 'q') = Left $ length (balls s)
+lfun _ s (KeyPress _) = Right s
lfun r s Tick =
let ds = eTermDims r
@@ -151,12 +153,10 @@ lfun r s Tick =
ps' = M.mapMaybe (modPar ds) ps
bs = eFPS r < 30
- in s { timer = ltimer (timer s),
- balls = filter (isIn ds) ps',
- bslow = bs }
-
-qfun :: GState -> Bool
-qfun s = quit s
+ s' = s { timer = ltimer (timer s),
+ balls = filter (isIn ds) ps',
+ bslow = bs }
+ in Right s'
-------------------------------------------------------------------------------
-- Draw
diff --git a/example/MainBalls.hs b/example/MainBalls.hs
@@ -7,6 +7,16 @@ import Terminal.Game
-- Balls Main module. The meat of the game is in `examples/Balls.hs`
main :: IO ()
-main = getStdGen >>= \g ->
- playGame (fireworks g)
+main = do
+ g <- getStdGen
+ r <- playGame (fireworks g)
+ -- We use game result `r` (how many balls were on
+ -- screen) and feed it to another function.
+ -- This could be useful to upload high scores to
+ -- a site, or for a game embedded in a larger pro-
+ -- gram, etc.
+ putStrLn (bye i)
+ where
+ bye wi = "See you later!\nYou left the game with " ++
+ show wi ++ " balls on screen."
diff --git a/example/MainHotReload.hs b/example/MainHotReload.hs
@@ -65,7 +65,7 @@ import Terminal.Game
cannot handle interactive programs. But if you are just displaying a
replay, this can come handy
- find example/*.hs | entr -cr cabal run -f examples hot reload
+ find example/*.hs | entr -cr cabal run -f examples hot-reload
This is very useful to incrementally build NPCs’ behaviour,
iron out mechanics bugs etc.
diff --git a/src/Terminal/Game.hs b/src/Terminal/Game.hs
@@ -33,7 +33,7 @@ module Terminal.Game ( -- * Running
ATGException(..),
-- ** Helpers
- playGameS,
+ playGame_,
Terminal.Game.displaySize,
assertTermDims,
errorPress,
diff --git a/src/Terminal/Game/Layer/Imperative.hs b/src/Terminal/Game/Layer/Imperative.hs
@@ -15,29 +15,43 @@ 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
--- | Game definition datatype, parametrised on your gamestate. The two most
--- important elements are the function dealing with logic and the drawing
--- one. Check @alone@ demo (@cabal run -f examples alone@) to see a simple
--- game in action.
-data Game s =
- Game { gTPS :: TPS,
- -- ^ Game speed in ticks per second. You do not
- -- need high values, since the 2D canvas is coarse
- -- (e.g. 13 TPS is enough for action games).
- gInitState :: s, -- ^ Initial state of the game.
- gLogicFunction :: GEnv -> s -> Event -> s,
- -- ^ Logic function.
- gDrawFunction :: GEnv -> s -> Plane,
- -- ^ Draw function. Just want to blit your game
- -- in the middle? Check 'centerFull'.
- gQuitFunction :: s -> Bool
- -- ^ /Should I quit?/ function.
- }
+-- | Game definition datatype, parametrised on:
+--
+-- * your gamestate @s@; and
+-- * a result when the game is finished @r@. Simple games do not need this,
+-- just fill @r@ with @()@.
+--
+-- The two most important elements are the function dealing with logic and
+-- the drawing one. Check @alone@ demo (@cabal run -f examples alone@) to
+-- see a basic game in action.
+data Game s r = Game {
+ gTPS :: TPS,
+ -- ^ Game speed in ticks per second. You do not
+ -- need high values, since the 2D canvas is coarse
+ -- (e.g. 13 TPS is enough for action games).
+ gInitState :: s, -- ^ Initial state of the game.
+ gLogicFunction :: GEnv -> s -> Event -> Either r s,
+ -- ^ Logic function. @s@ is the game state while @r@
+ -- is some sort of result you want to return when the
+ -- game is finished.
+ --
+ -- If `gLogicFunction` returns 'Right' the game will
+ -- continue; if it returns 'Left' the game is over
+ -- (quit condition).
+ --
+ -- Curious to see how @r@ can be useful? Check
+ -- @cabal run -f examples balls@ and
+ -- @example/MainBalls.hs@.
+ gDrawFunction :: GEnv -> s -> Plane
+ -- ^ Draw function. Just want to blit your game
+ -- in the middle? Check 'centerFull'.
+ }
-- | A blank plane as big as the terminal.
blankPlaneFull :: GEnv -> Plane
@@ -64,18 +78,22 @@ centerFull e p = blankPlaneFull e *** p
-- @
--
-- in your @.cabal@ file and you will be fine!
---
--- Need to inspect state on exit? Check 'playGameS'.
-playGame :: Game s -> IO ()
-playGame g = () <$ runGIO (runGameGeneral g)
+playGame :: Game s r -> IO r
+playGame g = either id (error "`Right` in playGame") <$>
+ runGIO (runGameGeneral g)
--- | As 'playGame', but do not discard state.
-playGameS :: Game s -> IO s
-playGameS g = runGIO (runGameGeneral g)
+-- | As 'playGame', but ignore the result @r@.
+playGame_ :: Game s r -> IO ()
+playGame_ g = () <$ playGame g
-- | Tests a game in a /pure/ environment. Aims to accurately emulate 'GEnv'
--- changes (screen size, FPS) too.
-testGame :: Game s -> GRec -> s
+-- changes (screen size, FPS) too. Returns a result @r@ or a state @s@ in
+-- case the Event stream is exhausted before the game exits.
+--
+-- A useful trick is to call 'recordGame' and press /Ctrl-C/ while playing
+-- (instead of quitting properly). This way @testGame@ will return
+-- @Left s@, a state that you can then inspect.
+testGame :: Game s r -> GRec -> Either r s
testGame g ts =
case runTest (runGameGeneral g) ts of
(Nothing, l) -> error $ "testGame, exception called: " ++
@@ -85,12 +103,15 @@ testGame g ts =
-- more infos on a failed test
(Just s, _) -> s
--- | As 'testGame', but returns 'Game' instead of a bare state.
+-- | As 'testGame', but returns 'Game' instead of result/state.
-- Useful to fast-forward (e.g.: skip menus) before invoking 'playGame'.
-setupGame :: Game s -> GRec -> Game s
+setupGame :: Game s r -> GRec -> Game s r
setupGame g ts = let s' = testGame g ts
- in g { gInitState = s' }
- -- xx qua messi solo [Event]?
+ in case s' of
+ -- If the game is already over, return a mock logic
+ -- function which simply ends the game.
+ Left r -> g { gLogicFunction = \_ _ _ -> Left r }
+ Right s -> g { gInitState = s }
-- | Similar to 'testGame', runs the game given a 'GRec'. Unlike
-- 'testGame', the playthrough will be displayed on screen. Useful when a
@@ -102,13 +123,13 @@ setupGame g ts = let s' = testGame g ts
-- record-time; this can make emulation slightly inaccurate if — e.g. —
-- you replay the game on a smaller terminal than the one you recorded
-- the session on.
-narrateGame :: Game s -> GRec -> IO s
-narrateGame g e = runReplay (runGameGeneral g) e
+narrateGame :: Game s r -> GRec -> IO ()
+narrateGame g e = () <$ runReplay (runGameGeneral g) e
--- | 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 ()
+-- | Play as in 'playGame' and write the session (input stream, etc.) to
+-- @file@. Then you can use this with 'testGame' and 'narrateGame'. Session
+-- will be recorded even if an exception happens while playing.
+recordGame :: Game s r -> FilePath -> IO ()
recordGame g fp =
E.bracket
(CC.newMVar igrec)
@@ -118,9 +139,9 @@ recordGame g fp =
data Config = Config { cMEvents :: CC.MVar [Event],
cTPS :: TPS }
-runGameGeneral :: forall s m. MonadGameIO m =>
- Game s -> m s
-runGameGeneral (Game tps s lf df qf) =
+runGameGeneral :: forall s r m. MonadGameIO m =>
+ Game s r -> m (Either r s)
+runGameGeneral (Game tps s lf df) =
-- init
setupDisplay >>
startEvents tps >>= \(InputHandle ve ts) ->
@@ -133,8 +154,8 @@ runGameGeneral (Game tps s lf df qf) =
(stopEvents ts >>
shutdownDisplay )
where
- game :: MonadGameIO m => Config -> Dimensions -> m s
- game c wds = gameLoop c s lf df qf
+ game :: MonadGameIO m => Config -> Dimensions -> m (Either r s)
+ game c wds = gameLoop c (Right s) lf df
Nothing wds
(creaFPSCalc tps)
@@ -172,35 +193,38 @@ errorPress m = E.catches m [E.Handler errorDisplay,
-- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm
gameLoop :: MonadGameIO m =>
- Config -> -- event source
- s -> -- state
+ Config -> -- event source
+ Either r s -> -- state
(GEnv ->
- s -> Event -> s) -> -- logic function
+ s -> Event ->
+ Either r s) -> -- logic function
(GEnv ->
- s -> Plane) -> -- draw function
- (s -> Bool) -> -- quit? function
- Maybe Plane -> -- last blitted screen
- Dimensions -> -- Term dimensions
- FPSCalc -> -- calculate fps
- m s
-gameLoop c s lf df qf opln td fps =
-
- -- quit?
- checkQuit qf s >>= \qb ->
- if qb
+ s -> Plane) -> -- draw function
+ Maybe Plane -> -- last blitted screen
+ Dimensions -> -- Term dimensions
+ FPSCalc -> -- calculate fps
+ m (Either r s)
+gameLoop c s lf df opln td fps =
+
+ -- Quit?
+ areEventsOver >>= \qb ->
+ -- We will quit in case input stream (events) is exhausted.
+ -- This might happen during test/narrate.
+ if ET.isLeft s || qb
then return s
else
- -- fetch events (if any)
+ -- Fetch events (if any).
+ -- This is safe as we checked for `areEventsOver` above.
pollEvents (cMEvents c) >>= \es ->
-- no events? skip everything
if null es
then sleepABit (cTPS c) >>
- gameLoop c s lf df qf opln td fps
+ gameLoop c s lf df opln td fps
else
- displaySizeErr >>= \td' ->
+ displaySizeErr >>= \td' ->
-- logic
let ge = GEnv td' (calcFPS fps)
@@ -208,7 +232,7 @@ gameLoop c s lf df qf opln td fps =
-- no `Tick` events? You do not need to blit, just update state
if i == 0
- then gameLoop c s' lf df qf opln td fps
+ then gameLoop c s' lf df opln td fps
else
-- FPS calc
@@ -219,22 +243,35 @@ gameLoop c s lf df qf opln td fps =
CM.when resc clearDisplay >>
-- draw
- let opln' | resc = Nothing -- res changed? restart double buffering
+ let
+ opln' | resc = Nothing -- res changed? restart double buffering
| otherwise = opln
- npln = df ge s' in
+ npln = case s' of
+ (Right rs) -> df ge rs
+ (Left _) -> uncurry blankPlane td'
+ -- In case the logic function came to an end
+ -- (Left), just print a blank plane.
+ in
blitPlane opln' npln >>
- gameLoop c s' lf df qf (Just npln) td' fps'
+ gameLoop c s' lf df (Just npln) td' fps'
-- Int = number of `Tick` events
-stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (Integer, s)
+stepsLogic :: Either r s -> (s -> Event -> Either r s) -> [Event] ->
+ (Integer, Either r s)
stepsLogic s lf es = let ies = D.genericLength . filter isTick $ es
- in (ies, foldl lf s es)
+ in (ies, logicFold lf s es)
where
isTick Tick = True
isTick _ = False
+ logicFold :: (s -> Event -> Either r s) ->
+ Either r s -> [Event] -> Either r s
+ logicFold _ (Left r) _ = Left r
+ logicFold wlf (Right ws) wes = CM.foldM wlf ws wes
+
+
-------------------------------------------------------------------------------
-- Frame per Seconds
diff --git a/src/Terminal/Game/Layer/Object/IO.hs b/src/Terminal/Game/Layer/Object/IO.hs
@@ -37,6 +37,10 @@ instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadInput m where
startEvents tps = T.liftIO $ startIOInput tps
pollEvents ve = T.liftIO $ CC.swapMVar ve []
stopEvents ts = T.liftIO $ stopEventsIO ts
+ areEventsOver = return False
+ -- IO monad is the actual game, we never quit bar if
+ -- the logic function returns `Right`.
+
-- filepath = logging
startIOInput :: TPS -> IO InputHandle
@@ -117,14 +121,6 @@ instance {-# OVERLAPS #-}
cleanUpErr m c = MC.finally m c
throwExc t = MC.throwM t
------------
--- Logic --
------------
-
-instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) =>
- MonadLogic m where
- checkQuit fb s = return (fb s)
-
-------------
-- Display --
-------------
diff --git a/src/Terminal/Game/Layer/Object/Interface.hs b/src/Terminal/Game/Layer/Object/Interface.hs
@@ -18,8 +18,7 @@ import qualified Control.Concurrent as CC
-- mtl interface for game
type MonadGameIO m = (MonadInput m, MonadTimer m,
- MonadException m, MonadLogic m,
- MonadDisplay m)
+ MonadException m, MonadDisplay m)
data InputHandle = InputHandle
{ ihKeyMVar :: CC.MVar [Event],
@@ -29,6 +28,13 @@ class Monad m => MonadInput m where
startEvents :: TPS -> m InputHandle
pollEvents :: CC.MVar [Event] -> m [Event]
stopEvents :: [CC.ThreadId] -> m ()
+ areEventsOver :: m Bool
+ -- Why do we need this? For test/narrate purposes. When
+ -- we play a game events are never over, but when we
+ -- test/narrate, it might be than the stream of [Event]
+ -- is exhausted before the state function returns Right.
+ -- We do not want to be stuck in an endless loop in that
+ -- case.
class Monad m => MonadTimer m where
getTime :: m Integer -- to nanoseconds
@@ -40,10 +46,6 @@ class Monad m => MonadException m where
cleanUpErr :: m a -> m b -> m a
throwExc :: ATGException -> m a
-class Monad m => MonadLogic m where
- -- decide whether it's time to quit
- checkQuit :: (s -> Bool) -> s -> m Bool
-
class Monad m => MonadDisplay m where
setupDisplay :: m ()
clearDisplay :: m ()
@@ -55,3 +57,4 @@ displaySizeErr :: (MonadDisplay m, MonadException m) => m Dimensions
displaySizeErr = displaySize >>= \case
Nothing -> throwExc CannotGetDisplaySize
Just d -> return d
+
diff --git a/src/Terminal/Game/Layer/Object/Narrate.hs b/src/Terminal/Game/Layer/Object/Narrate.hs
@@ -22,9 +22,7 @@ instance MonadInput Narrate where
startEvents fps = T.liftIO $ startEvents fps
pollEvents _ = S.state getPolled
stopEvents ts = T.liftIO $ stopEvents ts
-
-instance MonadLogic Narrate where
- checkQuit _ _ = S.gets isOver
+ areEventsOver = S.gets isOver
runReplay :: Narrate a -> GRec -> IO a
runReplay (Narrate s) k = S.evalStateT s k
diff --git a/src/Terminal/Game/Layer/Object/Primitive.hs b/src/Terminal/Game/Layer/Object/Primitive.hs
@@ -85,7 +85,7 @@ addPolled es (GRec p s) = GRec (es S.<| p) s
getPolled :: GRec -> ([Event], GRec)
getPolled (GRec (ps S.:|> p) d) = (p, GRec ps d)
-getPolled _ = error "getEvents: empty Seq"
+getPolled _ = error "getPolled: empty Seq"
isOver :: GRec -> Bool
isOver (GRec S.Empty _) = True
diff --git a/src/Terminal/Game/Layer/Object/Record.hs b/src/Terminal/Game/Layer/Object/Record.hs
@@ -29,6 +29,7 @@ instance MonadInput Record where
pollEvents ve = T.liftIO (pollEvents ve) >>= \es ->
modMRec addPolled es
stopEvents ts = T.liftIO (stopEvents ts)
+ areEventsOver = T.liftIO areEventsOver
instance MonadDisplay Record where
setupDisplay = T.liftIO setupDisplay
diff --git a/src/Terminal/Game/Layer/Object/Test.hs b/src/Terminal/Game/Layer/Object/Test.hs
@@ -58,6 +58,7 @@ instance MonadInput Test where
return mockHandle
pollEvents _ = S.state getPolled
stopEvents _ = S.tell [TStopEvents]
+ areEventsOver = S.gets isOver
instance MonadTimer Test where
getTime = return 1
@@ -68,9 +69,6 @@ instance MonadException Test where
throwExc e = S.tell [TException e] >>
E.throwError ()
-instance MonadLogic Test where
- checkQuit _ _ = S.gets isOver
-
instance MonadDisplay Test where
setupDisplay = () <$ S.tell [TSetupDisplay]
clearDisplay = return ()
diff --git a/test/Terminal/Game/Layer/ImperativeSpec.hs b/test/Terminal/Game/Layer/ImperativeSpec.hs
@@ -13,6 +13,12 @@ import qualified Control.Exception as E
import qualified Test.QuickCheck as Q
import qualified GHC.Exts as X
+-- Test for state.
+stateTest :: Show r => Game s r -> GRec -> s
+stateTest g r = either em id (testGame g r)
+ where
+ em wr = error $ "stateTest: " ++ show wr
+
spec :: Spec
spec = do
@@ -20,33 +26,35 @@ spec = do
let nd = error "<not-defined>"
s :: (Integer, Bool, Integer)
s = (0, False, 0)
- lf (t, True, i) Tick = (t+1, True, i+1)
- lf (t, b, i) Tick = (t+1, b, i )
- lf (t, _, i) (KeyPress _) = (t, True, i )
- qf (3, _, _) = True
- qf _ = False
+ lf (t, True, i) Tick = Right (t+1, True, i+1)
+ lf (t, b, i) Tick = Right (t+1, b, i )
+ lf (t, _, i) (KeyPress _) = Right (t, True, i )
es = [Tick, KeyPress 'c', KeyPress 'c', Tick, Tick]
- g = Game nd s (const lf) nd qf
+ g :: Game (Integer, Bool, Integer) ()
+ g = Game nd s (const lf) nd
it "does not confuse input and logic" $
- testGame g (createGRec (80, 24) es) `shouldBe` (3, True, 2)
+ stateTest g (createGRec (80, 24) es) `shouldBe` (3, True, 2)
describe "testGame" $ do
it "tests a game" $ do
r <- readRecord "test/records/alone-record-test.gr"
- testGame aloneInARoom r `shouldBe` MyState (20, 66) Stop True
+ stateTest aloneInARoom r `shouldBe` MyState (20, 66) Stop
+ it "tests a game exiting correctly" $ do
+ r <- readRecord "test/records/alone-record-left.gr"
+ testGame aloneInARoom r `shouldBe` Left ()
it "picks up screen resize events" $ do
r <- readRecord "test/records/balls-dims.gr"
let g = fireworks (mkStdGen 1)
- t = testGame g r
+ t = stateTest g r
length (balls t) `shouldBe` 1
- it "picks up screen resize events" $ do
+ it "picks FPS too" $ do
r <- readRecord "test/records/balls-slow.gr"
let g = fireworks (mkStdGen 1)
- t = testGame g r
+ t = stateTest g r
bslow t `shouldBe` True
it "does not hang on empty/unclosed input" $
let w = createGRec (80, 24) [Tick] in
- testGame aloneInARoom w `shouldBe` MyState (10, 10) Stop False
+ stateTest aloneInARoom w `shouldBe` MyState (10, 10) Stop
modifyMaxSize (const 1000) $
it "does not crash/hang on random input" $ Q.property $
let genEvs = Q.listOf1 Q.arbitrary
@@ -61,3 +69,4 @@ spec = do
e = "testGame, exception called: [TSetupDisplay,TStartEvents,\
\TException CannotGetDisplaySize]"
E.evaluate t `shouldThrow` errorCall e
+
diff --git a/test/records/alone-record-left.gr b/test/records/alone-record-left.gr
Binary files differ.
diff --git a/test/records/alone-record-test.gr b/test/records/alone-record-test.gr
Binary files differ.
diff --git a/test/records/balls-dims.gr b/test/records/balls-dims.gr
Binary files differ.
diff --git a/test/records/balls-slow.gr b/test/records/balls-slow.gr
Binary files differ.
