diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,66 @@ +1.9.0.0 +------- + +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. +- Released mar 28 feb 2023, 20:23:02 + +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 + are recorded, not just one. + If your game is running faster when keys are pressed, that probably + means you are updating some world variables on `KeyPress` events too, + while you should do that only on `Tick` events. + 1.8.1.0 ------- diff --git a/ansi-terminal-game.cabal b/ansi-terminal-game.cabal --- a/ansi-terminal-game.cabal +++ b/ansi-terminal-game.cabal @@ -1,5 +1,5 @@ name: ansi-terminal-game -version: 1.8.1.0 +version: 1.9.0.0 synopsis: sdl-like functions for terminal applications, based on ansi-terminal description: Library which aims to replicate standard 2d game @@ -15,14 +15,15 @@ license-file: COPYING author: Francesco Ariis et al. (see AUTHORS) maintainer: fa-ml@ariis.it -copyright: © 2017-2021 Francesco Ariis +copyright: © 2017-2023 Francesco Ariis et al. category: Game 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 --- a/example/Alone.hs +++ b/example/Alone.hs @@ -8,14 +8,12 @@ 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 @@ -- 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 @@ ------------------------------------------------------------------------------- -- 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 @@ -- 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 --- a/example/Balls.hs +++ b/example/Balls.hs @@ -117,33 +117,35 @@ -- 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 @@ 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 --- a/example/MainBalls.hs +++ b/example/MainBalls.hs @@ -7,6 +7,16 @@ -- 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 --- a/example/MainHotReload.hs +++ b/example/MainHotReload.hs @@ -65,7 +65,7 @@ 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 --- a/src/Terminal/Game.hs +++ b/src/Terminal/Game.hs @@ -33,7 +33,7 @@ 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 --- a/src/Terminal/Game/Layer/Imperative.hs +++ b/src/Terminal/Game/Layer/Imperative.hs @@ -15,29 +15,43 @@ 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 @@ -- @ -- -- 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 @@ -- 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 @@ -- 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 @@ 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 @@ (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 @@ -- 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 = + 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? - checkQuit qf s >>= \qb -> - if qb + -- 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 @@ -- 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,21 +243,34 @@ 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 --- a/src/Terminal/Game/Layer/Object/IO.hs +++ b/src/Terminal/Game/Layer/Object/IO.hs @@ -37,7 +37,11 @@ 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 startIOInput tps = @@ -116,14 +120,6 @@ MonadException m where 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 --- a/src/Terminal/Game/Layer/Object/Interface.hs +++ b/src/Terminal/Game/Layer/Object/Interface.hs @@ -18,8 +18,7 @@ -- 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 @@ 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 @@ 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 = 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 --- a/src/Terminal/Game/Layer/Object/Narrate.hs +++ b/src/Terminal/Game/Layer/Object/Narrate.hs @@ -22,9 +22,7 @@ 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 --- a/src/Terminal/Game/Layer/Object/Primitive.hs +++ b/src/Terminal/Game/Layer/Object/Primitive.hs @@ -28,6 +28,15 @@ type FPS = Integer -- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'. +-- +-- Note that all @Keypress@es are recorded and fed to your game-logic +-- function. This means you will not lose a single character, no matter +-- how fast your player is at typing or how low you set 'FPS' to be. +-- +-- Example: in a game where you are controlling a hot-air baloon and have +-- @direction@ and @position@ variables, you most likely want @direction@ +-- to change at every @KeyPress@, while having @position@ only change at +-- @Tick@s. data Event = Tick | KeyPress Char -- ↑↓→← do not work on Windows (are handled by the app, @@ -76,7 +85,7 @@ 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 --- a/src/Terminal/Game/Layer/Object/Record.hs +++ b/src/Terminal/Game/Layer/Object/Record.hs @@ -29,6 +29,7 @@ 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 --- a/src/Terminal/Game/Layer/Object/Test.hs +++ b/src/Terminal/Game/Layer/Object/Test.hs @@ -58,6 +58,7 @@ return mockHandle pollEvents _ = S.state getPolled stopEvents _ = S.tell [TStopEvents] + areEventsOver = S.gets isOver instance MonadTimer Test where getTime = return 1 @@ -67,9 +68,6 @@ cleanUpErr a _ = S.tell [TCleanUpError] >> a throwExc e = S.tell [TException e] >> E.throwError () - -instance MonadLogic Test where - checkQuit _ _ = S.gets isOver instance MonadDisplay Test where setupDisplay = () <$ S.tell [TSetupDisplay] diff --git a/test/Terminal/Game/Layer/ImperativeSpec.hs b/test/Terminal/Game/Layer/ImperativeSpec.hs --- a/test/Terminal/Game/Layer/ImperativeSpec.hs +++ b/test/Terminal/Game/Layer/ImperativeSpec.hs @@ -13,6 +13,12 @@ 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 @@ let nd = error "" 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 @@ 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 new file mode 100644 Binary files /dev/null and b/test/records/alone-record-left.gr differ diff --git a/test/records/alone-record-test.gr b/test/records/alone-record-test.gr Binary files a/test/records/alone-record-test.gr and b/test/records/alone-record-test.gr differ diff --git a/test/records/balls-dims.gr b/test/records/balls-dims.gr Binary files a/test/records/balls-dims.gr and b/test/records/balls-dims.gr differ diff --git a/test/records/balls-slow.gr b/test/records/balls-slow.gr Binary files a/test/records/balls-slow.gr and b/test/records/balls-slow.gr differ