ansi-terminal-game 0.3.1.0 → 0.4.0.0

raw patch · 26 files changed

+1111/−489 lines, 26 filesdep +QuickCheckdep +exceptionsdep +minttynew-component:exe:alonenew-component:exe:alone-playbackbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, exceptions, mintty, temporary

API changes (from Hackage documentation)

Files

• ansi-terminal-game.cabal +46/−35
• changes.txt +7/−0
• example/Alone.hs +29/−22
• example/Main.hs +13/−0
• example/Playback.hs +29/−0
• platform-dep/non-win/Terminal/Game/Input.hs +0/−9
• platform-dep/non-win/Terminal/Game/Utils.hs +14/−0
• platform-dep/windows/Terminal/Game/Input.hs +0/−22
• platform-dep/windows/Terminal/Game/Utils.hs +31/−0
• src/Terminal/Game.hs +77/−33
• src/Terminal/Game/Animation.hs +13/−2
• src/Terminal/Game/Draw.hs +13/−6
• src/Terminal/Game/Layer/Imperative.hs +136/−57
• src/Terminal/Game/Layer/Object.hs +21/−252
• src/Terminal/Game/Layer/Object/Display.hs +0/−19
• src/Terminal/Game/Layer/Object/GameIO.hs +21/−0
• src/Terminal/Game/Layer/Object/IO.hs +270/−0
• src/Terminal/Game/Layer/Object/Interface.hs +89/−0
• src/Terminal/Game/Layer/Object/Narrate.hs +86/−0
• src/Terminal/Game/Layer/Object/Record.hs +39/−0
• src/Terminal/Game/Layer/Object/Test.hs +82/−0
• src/Terminal/Game/Plane.hs +57/−28
• test/Terminal/Game/DrawSpec.hs +4/−1
• test/Terminal/Game/Layer/ImperativeSpec.hs +25/−2
• test/Terminal/Game/PlaneSpec.hs +9/−1
• test/alone-recors-test.gr binary

@@ -1,5 +1,5 @@ name:                ansi-terminal-game-version:             0.3.1.0+version:             0.4.0.0 synopsis:            sdl-like functions for terminal applications, based on                      ansi-terminal description:         Library which aims to replicate standard 2d game@@ -16,10 +16,11 @@ copyright:           © 2017-2019 Francesco Ariis category:            Game build-type:          Simple-extra-source-files:  changes.txt+extra-source-files:  changes.txt,+                     test/alone-recors-test.gr cabal-version:       >=1.10 -flag example+flag examples   description:       builds examples   default:           False @@ -28,9 +29,14 @@   other-modules:       Terminal.Game.Animation,                        Terminal.Game.Layer.Imperative,                        Terminal.Game.Layer.Object,-                       Terminal.Game.Layer.Object.Display,+                       Terminal.Game.Layer.Object.GameIO,+                       Terminal.Game.Layer.Object.Interface,+                       Terminal.Game.Layer.Object.IO,+                       Terminal.Game.Layer.Object.Narrate,+                       Terminal.Game.Layer.Object.Record,+                       Terminal.Game.Layer.Object.Test,                        Terminal.Game.Draw,-                       Terminal.Game.Input,+                       Terminal.Game.Utils,                        Terminal.Game.Plane,                        Terminal.Game.Timer   build-depends:       base == 4.*,@@ -39,8 +45,11 @@                        bytestring == 0.10.*,                        cereal == 0.5.*,                        clock == 0.7.*,+                       exceptions == 0.10.*,                        linebreak == 1.0.*,+                       mintty == 0.1.*,                        mtl == 2.2.*,+                       QuickCheck == 2.13.*,                        split == 0.2.*,                        terminal-size == 0.3.*,                        timers-tick == 0.4.*@@ -48,8 +57,6 @@   default-language:    Haskell2010   ghc-options:         -Wall -  -- horrible horrible horrible hack to make unbuffered input-  -- work on Windows   if os(windows)     hs-source-dirs: platform-dep/windows   if !os(windows)@@ -57,17 +64,23 @@  test-suite test   default-language:    Haskell2010-  hs-Source-Dirs:      test, src+  hs-Source-Dirs:      test, src, example   main-is:             Test.hs-  other-modules:       Terminal.Game,+  other-modules:       Alone,+                       Terminal.Game,                        Terminal.Game.Animation,                        Terminal.Game.Draw,                        Terminal.Game.DrawSpec,                        Terminal.Game.Layer.Imperative,                        Terminal.Game.Layer.ImperativeSpec,                        Terminal.Game.Layer.Object,-                       Terminal.Game.Layer.Object.Display,-                       Terminal.Game.Input,+                       Terminal.Game.Layer.Object.GameIO,+                       Terminal.Game.Layer.Object.Interface,+                       Terminal.Game.Layer.Object.IO,+                       Terminal.Game.Layer.Object.Narrate,+                       Terminal.Game.Layer.Object.Record,+                       Terminal.Game.Layer.Object.Test,+                       Terminal.Game.Utils,                        Terminal.Game.Plane,                        Terminal.Game.PlaneSpec   build-depends:       base == 4.*,@@ -76,8 +89,10 @@                        bytestring == 0.10.*,                        cereal == 0.5.*,                        clock == 0.7.*,+                       exceptions == 0.10.*,                        linebreak == 1.0.*,                        mtl == 2.2.*,+                       QuickCheck == 2.13.*,                        split == 0.2.*,                        terminal-size == 0.3.*,                        timers-tick == 0.4.*@@ -86,38 +101,34 @@   type:                exitcode-stdio-1.0   ghc-options:         -Wall -  -- horrible horrible horrible hack to make unbuffered input-  -- work on Windows, part II   if os(windows)     hs-source-dirs: platform-dep/windows   if !os(windows)     hs-source-dirs: platform-dep/non-win -executable alone-in-a-room-    if flag(example)-      build-depends:    base == 4.*,-                        ansi-terminal-game+executable alone+    if flag(examples)+      build-depends:  base == 4.*,+                      ansi-terminal-game     else-      buildable:        False+      buildable:      False      hs-source-dirs:   example-    main-is:          Alone.hs+    main-is:          Main.hs+    other-modules:    Alone     default-language: Haskell2010-        -- With the -threaded option, only foreign calls with the unsafe-        -- attribute will block all other threads.     ghc-options:      -threaded-                      -- -O2 non rende le cose più veloci-    -- Senza threaded non compila su windows-    -- required on win before ghc 8.4?-    ---    -- geekosaur dice-    --    geekosaur f-a, a. heh. so the thoguht I had turned out to-    --           be correct:-    --           Control.Concurent.rtsSupportsBoundThreads (because-    --           green threads can't be usefully bound)-    --    geekosaur so if that produces True, it's using the-    --              threaded runtime; if False, you can say-    --              something useful instead of hanging --- per time profiling--- cabal new-run -f example alone-in-a-room --enable-profiling -- +RTS -p+executable alone-playback+    if flag(examples)+      build-depends:  base == 4.*,+                      ansi-terminal-game,+                      temporary == 1.3.*+    else+      buildable:      False++    hs-source-dirs:   example+    main-is:          Playback.hs+    other-modules:    Alone+    default-language: Haskell2010+    ghc-options:      -threaded

@@ -1,3 +1,10 @@+0.4.0.0+-------++- Exposed new functions in API.+- Greatly improved haddock documentation.+- Released Tue 25 Jun 2019 16:08:53 CEST+ 0.2.1.0 ------- 

@@ -1,39 +1,46 @@-module Main where+module Alone where +-- Alone in a room, game definition (logic & draw)  import Terminal.Game -main :: IO ()-main = do-    runGame (GameState (10, 10) Stop False)-            logicFun-            drawFun-            (\gs -> gsQuit gs)-            10-    return ()-        -- xxx no () in iok0 +-- this is the game specification+aloneInARoom :: Game MyState+aloneInARoom =+    Game { gScreenWidth  = gw,+           gScreenHeight = gh,+           gFPS          = 13, +           gInitState     = MyState (10, 10) Stop False,+           gLogicFunction = logicFun,+           gDrawFunction  = drawFun,+           gQuitFunction  = gsQuit }+    where+          (gh, gw) = snd boundaries++ ----------- -- TYPES -- ----------- -data GameState = GameState { gsCoord :: Coords,-                             gsMove  :: Move,-                             gsQuit  :: Bool }+data MyState = MyState { gsCoord :: Coords,+                         gsMove  :: Move,+                         gsQuit  :: Bool }+             deriving (Show, Eq)  data Move = N | S | E | W | Stop           deriving (Show, Eq)  boundaries :: (Coords, Coords)-boundaries = ((1, 1), (25, 80))+boundaries = ((1, 1), (24, 80))   ----------- -- LOGIC -- ----------- -logicFun :: GameState -> Event -> GameState+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 }@@ -71,15 +78,15 @@ -- DRAW -- ---------- -drawFun :: GameState -> Plane-drawFun (GameState (r, c) _ _) =-                           blankPlane mw     mh     &-                (1, 1)   % box '_'    mw     mh     &-                (2, 2)   % box ' '    (mw-2) (mh-2) &+drawFun :: MyState -> Plane+drawFun (MyState (r, c) _ _) =+                           blankPlane mw     mh            &+                (1, 1)   % box '_'    mw     mh            &+                (2, 2)   % box ' '    (mw-2) (mh-2)        &                 (15, 20) % textBox "Tap WASD to move, tap again to stop."-                                   10 4             &+                                   10 4                    &                 (20, 60) % textBox "Press Q to quit."-                                   8 10             &+                                   8 10 # color Blue Vivid &                 (r, c) % cell '@' # invert     where           mh :: Height

@@ -0,0 +1,13 @@+module Main where+++import Alone ( aloneInARoom )++import Terminal.Game++-- plays the game normally++main :: IO ()+main = playGame aloneInARoom++

@@ -0,0 +1,29 @@+module Main where+++import Alone ( aloneInARoom )++import Terminal.Game++import System.IO.Temp ( emptySystemTempFile )++-- plays the game and, once you quit, shows a replay of the session++main :: IO ()+main = do+        tf <- emptySystemTempFile "alone-record.gr"+        playback tf++playback :: FilePath -> IO ()+playback f = do+        prompt "Press <Enter> to play the game."+        recordGame aloneInARoom f+        prompt "Press <Enter> to watch playback."+        es <- readRecord f+        narrateGame aloneInARoom es+        prompt "Playback over! Press <Enter> to quit."+    where+          prompt :: String -> IO ()+          prompt s = putStrLn s >> () <$ getLine++

@@ -1,9 +0,0 @@------------------------------------------------------------------------------------ Nonbuffering getChar--- 2017 Francesco Ariis GPLv3                                             80cols-----------------------------------------------------------------------------------module Terminal.Game.Input where--inputCharTerminal :: IO Char-inputCharTerminal = getChar

@@ -0,0 +1,14 @@+--------------------------------------------------------------------------------+-- Nonbuffering getChar+-- 2017 Francesco Ariis GPLv3                                             80cols+--------------------------------------------------------------------------------++module Terminal.Game.Utils ( inputCharTerminal,+                             isWin32Console )+                           where++inputCharTerminal :: IO Char+inputCharTerminal = getChar++isWin32Console :: IO Bool+isWin32Console = return False

@@ -1,22 +0,0 @@------------------------------------------------------------------------------------ Nonbuffering getChar--- 2017 Francesco Ariis GPLv3                                             80cols----------------------------------------------------------------------------------{-# LANGUAGE ForeignFunctionInterface #-}---- see .cabal conditionals for more info--module Terminal.Game.Input where--import qualified Foreign.C.Types as FT-import qualified Data.Char       as C--inputCharTerminal :: IO Char-inputCharTerminal = getCharWindows---- no idea but unsafe breaks it-getCharWindows :: IO Char-getCharWindows = fmap (C.chr . fromEnum) c_getch-foreign import ccall safe "conio.h getch"-  c_getch :: IO FT.CInt-

@@ -0,0 +1,31 @@+--------------------------------------------------------------------------------+-- Nonbuffering getChar et al+-- 2017 Francesco Ariis GPLv3                                             80cols+--------------------------------------------------------------------------------+{-# LANGUAGE ForeignFunctionInterface #-}++-- see .cabal conditionals for more info++-- horrible horrible horrible hack to make unbuffered input+-- work on Windows (and win32console check)++module Terminal.Game.Utils (inputCharTerminal,+                            isWin32Console )+                           where++import qualified Data.Char             as C+import qualified Foreign.C.Types       as FT+import qualified System.Console.MinTTY as M++inputCharTerminal :: IO Char+inputCharTerminal = getCharWindows++-- no idea but unsafe breaks it+getCharWindows :: IO Char+getCharWindows = fmap (C.chr . fromEnum) c_getch+foreign import ccall safe "conio.h getch"+  c_getch :: IO FT.CInt++-- not perfect, but it is what it is (on win, non minTTY)+isWin32Console :: IO Bool+isWin32Console = not <$> M.isMinTTY

@@ -10,64 +10,108 @@ -- -- Machinery and utilities for 2D terminal games. ----- Before continuing, __please read this__: to use @ansi-terminal-game@,--- you need to compile your programs with @-threaded@; if you do not do--- this the program will crash at start-up. Just add:------ @---      ghc-options:      -threaded--- @------ in your @.cabal@ file and you will be fine!+-- New? Start from 'Game'. -- --------------------------------------------------------------------------------  -- Basic col-on-black ASCII terminal, operations. -- Only module to be imported. --- todo add docs [release]+-- todo test that handlers are closed in case of errr [test] -module Terminal.Game ( -- * Game Loop-                       MonadGameIO,+-- xxx timer in contrib o altro modulo?+-- xxx qptain e jimreed, implement normal movement++module Terminal.Game ( -- * Running                        FPS,-                       runGame,                        Event(..),-                       -- * Plane+                       Game(..),+                       playGame,++                       -- * Game Logic+                       -- | Some convenient function dealing with+                       -- Timers ('Timed') and 'Animation's.+                       --+                       -- Usage of these is not mandatry: 'Game' is+                       -- parametrised over any state @s@, you are free+                       -- to implement game logic as you prefer.++                       -- ** Timers+                       Timed,+                       creaTimer, creaBoolTimer,+                       creaTimerLoop, creaBoolTimerLoop,+                       fetchFrame, isExpired,++                       -- ** Animations+                       Animation,+                       -- xxx elimina animation?+                       -- xxx o di certo Loop e ExpBehaviour+                       Loop(..), ExpBehaviour(..),+                       creaAnimation,+                       tick, reset,+                       fetchAniFrame, isAniExpired,+                       getFrames,++                       -- * Drawing+                       -- | To get to the gist of drawing, check the+                       -- documentation of '%'.++                       -- ** Plane                        Plane,                        Coords,                        Row, Column,                        Width, Height,+                       blankPlane,                        stringPlane,                        stringPlaneTrans,-                       blankPlane, addVitrum,-                       pastePlane,-                       planeSize, paperPlane,-                       -- * Draw+                       makeTransparent,+                       makeOpaque,+                       paperPlane,+                       planeSize,++                       -- ** Draw                        Draw,                        (%), (#), (&),                        mergePlanes,                        cell, box, textBox,-                       bold, invert,-                       -- * Animations-                       Animation, Loop(..),-                       creaAni,-                       tick, reset,-                       getFrames,-                       -- * Timers-                       Timed,-                       ExpBehaviour(..),-                       creaTimer,-                       creaBoolTimer,-                       fetchFrame, isExpired,+                       Color(..), ColorIntensity(..),+                       color, bold, invert, -                       -- * Utils-                       -- screenSize+                       -- * Testing+                       testGame,+                       recordGame,+                       readRecord,+                       narrateGame,+                       errorPress++                       -- * Cross platform+                       -- $threaded                      )     where +import System.Console.ANSI import Terminal.Game.Layer.Imperative import Terminal.Game.Layer.Object-import Terminal.Game.Layer.Object.Display () import Terminal.Game.Plane import Terminal.Game.Draw import Terminal.Game.Animation++-- $threaded+-- Good practices for cross-compatibility:+--+-- * choose game dimensions of no more than __24 rows__ and __80 columns__.+--   This ensures compatibility with the trickiest terminals (i.e. Win32+--   console);+--+-- * use __ASCII characters__ only. Again this is for Win32 console+--   compatibility, until+--   [this GHC bug](https://gitlab.haskell.org/ghc/ghc/issues/7593) gets+--   fixed;+--+-- * employ colour sparingly: as some users will play your game in a+--   light-background terminal and some in a dark one, choose only colours+--   that go well with either (blue, red, etc.);+--+-- * some terminals/multiplexers (i.e. tmux) do not make a distinction+--   between vivid/dull, do not base your game mechanics on that+--   difference.

@@ -21,10 +21,21 @@ -- import qualified Data.ByteString as BS -- import qualified Data.Bifunctor as BF +-- | An @Animation@ is a series of timed time-separated 'Plane's. type Animation = T.Timed Plane -creaAni :: Loop -> [(Integer, Plane)] -> Animation-creaAni = creaTimedRes+-- | Creates an 'Animation'.+creaAnimation :: Loop -> [(Integer, Plane)] -> Animation+creaAnimation = creaTimedRes++-- | Alias for 'fetchFrame'.+fetchAniFrame :: Animation -> Plane+fetchAniFrame = fetchFrame++-- | Alias for 'isExpired'.+isAniExpired :: Animation -> Bool+isAniExpired = isExpired+  ------------------- -- SERIALISATION --

@@ -14,13 +14,15 @@  import Text.LineBreak -import qualified Data.Function as F ( (&) )-import qualified Data.List     as L+import qualified Data.Function       as F ( (&) )+import qualified Data.List           as L+import qualified System.Console.ANSI as CA  ----------- -- TYPES -- ----------- +-- | A drawing function, usually executed with the help of '%'. type Draw = Plane -> Plane  @@ -33,8 +35,8 @@ -- -- @ --  d :: Plane---  d =          blankPlane (100, 100) &---      (3, 4) % box '_' (3, 5)        &+--  d =          blankPlane 100 100  &+--      (3, 4) % box '_' 3 5         & --      (a, b) % cell \'A\' '#' bold -- @ (%) :: Coords -> Plane -> Draw@@ -73,6 +75,10 @@ -- STYLES -- ------------ +-- | Set foreground color.+color :: CA.Color -> CA.ColorIntensity -> Plane -> Plane+color c i p = mapPlane (colorCell c i) p+ -- | Apply bold style to 'Plane'. bold :: Plane -> Plane bold p = mapPlane boldCell p@@ -102,7 +108,8 @@ --     where --           (w, h) = pSize p --- assumes ' ' are transparent+-- xxx li vogliamo davvero transparent?+-- | A text-box. Assumes ' ' are transparent. textBox :: String -> Width -> Height -> Plane textBox cs w h = transparent     where@@ -117,7 +124,7 @@                     rf cr ln = zip (zip (repeat cr) [1..]) ln            out         = seqCellsDim w h (f hcs)-          transparent = addVitrum ' ' out+          transparent = makeTransparent ' ' out   -----------------

@@ -10,66 +10,153 @@  import Terminal.Game.Layer.Object -import qualified Control.Monad.Reader as R 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 +-- xxx also when it goes to crash screen, it says press any key to+--     continue, yet only enter works -type Game m a = R.ReaderT Config m a+-- | Game definition datatype, parametrised on your gamestate. The two+-- most important elements are the function dealing with logic and the+-- drawing one. Check @alone@ (you can compile it with @cabal+-- new-run -f examples alone@) to see a simple game in action.+data Game s = Game {+        gScreenWidth   :: Width,           -- ^Gamescreen size, width.+        gScreenHeight  :: Height,          -- ^Gamescreen size, height.+        gFPS           :: FPS,             -- ^Frames per second.+        gInitState     :: s,               -- ^Initial state of the game.+        gLogicFunction :: s -> Event -> s, -- ^Logic function.+        gDrawFunction  :: s -> Plane,      -- ^Draw function.+        gQuitFunction  :: s -> Bool        -- ^\"Should I quit?\" function.+      } +-- | Entry point for the game execution, should be called in @main@.+--+-- You __must__ compile your programs with @-threaded@; if you do not do+-- this the game will crash at start-up. Just add:+--+-- @+-- ghc-options:      -threaded+-- @+--+--   in your @.cabal@ file and you will be fine!+playGame :: Game s -> IO ()+playGame g = () <$ runGIO (runGameGeneral g)++-- | Tests a game in a /pure/ environment. You can+-- supply the 'Event's yourself or use 'recordGame' to obtain them.+testGame :: Game s -> [Event] -> s+testGame g es = fst $ runTest (runGameGeneral g) (Env False es)++-- | Similar to 'testGame', runs the game given a list of 'Events'. Unlike+-- 'testGame', the playthrough will be displayed on screen. Useful when a+-- test fails and you want to see how.+--+-- See this in action with  @cabal new-run -f examples alone-playback@.+narrateGame :: Game s -> [Event] -> IO s+narrateGame g e = runReplay (runGameGeneral g) e+    -- xxx replaygame is very difficult to test++-- -- | Play as in 'playGame' and write the session to @file@. Useful to+-- -- produce input for 'testGame' and 'replayGame'.+-- recordGame :: Game s -> FilePath -> IO s+-- recordGame g fp =+--         CC.newMVar []                   >>= \ve ->+--         runRecord (runGameGeneral g) ve >>= \s ->+--         writeMoves fp ve                >>+--         return s++-- | Play as in 'playGame' and write the session to @file@. Useful to+-- produce input for 'testGame' and 'replayGame'. Session will be+-- recorded even if an exception happens while playing.+recordGame :: Game s -> FilePath -> IO ()+recordGame g fp =+        E.bracket+          (CC.newMVar [])+          (\ve -> writeMoves fp ve)+          (\ve -> () <$ runRecord (runGameGeneral g) ve)+ data Config = Config { cMEvents :: CC.MVar [Event],                        cFPS     :: FPS              } --- | Entry point for the game, should be called in @main@. The two--- most important functions are the one dealing with logic and the--- blitting one. Check @alone-in-a-room@ (you can compiler it with--- @cabal new-build -f examples@) to see a simple game in action.-runGame :: forall s m. MonadGameIO m =>-           s                 -- ^Initial state of the game.-        -> (s -> Event -> s) -- ^Logic function.-        -> (s -> Plane)      -- ^Draw function.-        -> (s -> Bool)       -- ^\"Should I quit?\" function.-        -> FPS               -- ^Frames per second.-        -> m s-runGame s lf df qf fps =-            startEvents fps                   >>= \ve ->-            R.runReaderT game (Config ve fps)+runGameGeneral :: forall s m. MonadGameIO m =>+                  Game s -> m s+runGameGeneral (Game gw gh fps s lf df qf) =+            -- init+            sizeAssert gw gh >>+            setupDisplay     >>+            startEvents fps  >>= \(InputHandle ve ts) ->++            -- do it!+            let c = Config ve fps in+            cleanUpErr (game c)+                            -- this under will be run regardless+                       (stopEvents ts >>+                        shutdownDisplay  )     where-          game :: MonadGameIO m => Game m s-          game = R.ask >>= \c ->-                 R.lift (setupDisplay-                        (gameLoop c s lf df qf Nothing (0,0)-                                  (initFPSCounter 10)))+          game :: MonadGameIO m => Config -> m s+          game c = gameLoop gw gh c+                            s lf df qf+                            Nothing (0,0)  +-- | Wraps an @IO@ computation so that any 'error' gets displayed along+-- with a @\<press any key to quit\>@ prompt.+-- Some terminals shut-down immediately upon program end: 'errorPress'+-- makes it easier to beta-test games on those terminals.+errorPress :: IO a -> IO a+errorPress m = E.catch m errorDisplay+    where+          errorDisplay :: E.ErrorCall -> IO a+          errorDisplay (E.ErrorCallWithLocation cs l) =+              putStrLn "ERROR REPORT\n"      >>+              putStrLn (cs ++ "\n\n")        >>+              putStrLn "Stack trace info:\n" >>+              putStrLn (l ++ "\n")           >>++              putStrLn "\n <Press any key to quit>"    >>+              SI.hSetBuffering SI.stdin SI.NoBuffering >>+              getChar                                  >>+              errorWithoutStackTrace "errorPress"+++-----------+-- LOGIC --+-----------+ -- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm gameLoop :: MonadGameIO m     =>+            Width             -> -- gamewidth+            Height            -> -- gameheight             Config            -> -- event source             s                 -> -- state             (s -> Event -> s) -> -- logic function             (s -> Plane)      -> -- draw function             (s -> Bool)       -> -- quit? function             Maybe Plane       -> -- last blitted screen-            -- FPSCounter     -> -- FPS counter             (Width, Height)   -> -- Term Dimensions-            FPSCounter        -> -- FPS counter             m s-gameLoop c s lf df qf opln td fc =--        -- fetch events (if any)-        pollEvents (cMEvents c) >>= \es ->+gameLoop gw gh c s lf df qf opln td =          -- quit?-        if qf s+        checkQuit qf s >>= \qb ->+        if qb           then return s         else +        -- fetch events (if any)+        pollEvents (cMEvents c) >>= \es ->+            -- xxx test poll events si rompe se lo sposto su+         -- no events? skip everything         if null es           then sleepABit (cFPS c)               >>-               gameLoop c s lf df qf opln td fc+               gameLoop gw gh c s lf df qf opln td+               -- xxx reader monad qui         else          -- logic@@ -81,15 +168,14 @@         CM.when resc clearDisplay >>          -- draw-        -- xxx solo se è tick e non kpress?-        let opln' | resc = Nothing   -- res changed? restart double buffering+        -- xxx solo se è tick e non kpress? [loop]+        let opln' | resc = Nothing -- res changed? restart double buffering                   | otherwise = opln-            npln  = df s'-            cFps  = getCurrFPS fc     in-        blitPlane tw th opln' npln cFps >>-        tickCounter fc                  >>= \fc' ->+            gpl   = blankPlane gw gh+            npln  = pastePlane (df s') gpl (1, 1) in+        blitPlane tw th opln' npln >> -        gameLoop c s' lf df qf (Just npln) td' fc'+        gameLoop gw gh c s' lf df qf (Just npln) td'   stepsLogic :: s -> (s -> Event -> s) -> [Event] -> s@@ -97,29 +183,22 @@   -------------------- FPS COUNTER --+-- ANCILLARIES -- ----------------- --- poll fps every x frames, current fps, stored time, current fps-data FPSCounter = FPSCounter Integer Integer Integer Integer+sizeAssert :: MonadDisplay m => Width -> Height -> m ()+sizeAssert gw gh =+        displaySize >>= \(sw, sh) -> --- poll utctime every x ticks-initFPSCounter :: Integer -> FPSCounter-initFPSCounter x = FPSCounter x 0 0 0+        let errMess =+               "This games requires a screen of " ++ show gw +++               " columns and " ++ show gh ++ " rows.\n" +++               "Yours only has " ++ show sw ++ " columns and " +++               show sh ++ " rows!\n\n" +++               "Please resize your terminal and relaunch " +++               "the game!\n"+        in -tickCounter :: MonadGameIO m => FPSCounter -> m FPSCounter-tickCounter (FPSCounter g e t1 cf)-        | g > e  = return (FPSCounter g (e+1) t1 cf)-        | g == e = getTime >>= \t2 ->-                   let dtn = t2 - t1-                       fr  = fi dtn / fi (g+1)-                       fps = round $ fi (10^(9::Integer)) / fr in-                       --- xxx no div-                   return (FPSCounter g 0 t2 fps)-        | otherwise = error "tickCounter: g < e"-    where-          fi :: Integer -> Double-          fi = fromIntegral+        CM.when (gw > sw || gh > sh)+                (error errMess) -getCurrFPS :: FPSCounter -> Integer-getCurrFPS (FPSCounter _ _ _ cFps) = cFps

@@ -4,262 +4,31 @@ -- 2019 Francesco Ariis GPLv3 ------------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleInstances #-}--module Terminal.Game.Layer.Object where--import Terminal.Game.Input-import Terminal.Game.Plane--import qualified Control.Concurrent as CC-import qualified System.Clock       as SC---- xxx elimina, sono ansi shit-import Terminal.Game.Draw-import qualified System.IO                    as SI-import qualified System.Console.ANSI          as CA-import qualified Control.Exception            as E-import qualified Control.Monad                as CM-import qualified System.Console.Terminal.Size as TS-import qualified Data.List.Split              as LS--type MonadGameIO m = (MonadInput m, MonadTimer m, MonadDisplay m)--------------------- Game input ----------------------- | Frames per second.-type FPS = Integer---- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'.-data Event = Tick-           | KeyPress Char--class Monad m => MonadInput m where-    startEvents :: FPS -> m (CC.MVar [Event])-    pollEvents  :: CC.MVar [Event] ->-                   m [Event]--instance MonadInput IO where-    startEvents fps = startIOInput fps-    pollEvents ve = CC.swapMVar ve []--startIOInput :: FPS -> IO (CC.MVar [Event])-startIOInput fps = -- non buffered input-                   SI.hSetBuffering SI.stdin-                                    SI.NoBuffering >>--                   CC.newMVar []                   >>= \ve ->-                   CC.forkIO (addTick ve fps)      >>-                   CC.forkIO (addKeypress ve)      >>-                   return ve---- modifica il timer-addTick :: CC.MVar [Event] -> FPS -> IO ()-addTick ve fps = addEvent ve Tick           >>-                 CC.threadDelay delayAmount >>-                 addTick ve fps-    where-          delayAmount :: Int-          delayAmount = fromIntegral $ quot oneTickSec fps---- get action char-addKeypress :: CC.MVar [Event] -> IO ()-addKeypress ve = -- vedi platform-dep/-                 inputCharTerminal        >>= \c ->-                 addEvent ve (KeyPress c) >>-                 addKeypress ve--addEvent :: CC.MVar [Event] -> Event -> IO ()-addEvent ve e = CC.modifyMVar_ ve (return . (++[e]))--instance MonadInput ((->) [Event]) where-    startEvents _ = error "startEvent in (->) instance"-    pollEvents _ = id----------------------- Game timing ----------------------class Monad m => MonadTimer m where-    getTime :: m Integer     -- to nanoseconds-    sleepABit :: FPS -> m () -- useful not to hammer cpu while polling--instance MonadTimer IO where-    getTime = SC.toNanoSecs <$> SC.getTime SC.Monotonic-    sleepABit fps =-        CC.threadDelay (fromIntegral $ quot oneTickSec (fps*10))--instance MonadTimer ((->) [Event]) where-    getTime = const 1-    sleepABit _ = const ()------------------------------------------------- MONADDISPLAY------------------------------------------------ xxx move out monaddisplay m dipende da event! circular!--class Monad m => MonadDisplay m where-    setupDisplay :: m s -> m s-    clearDisplay :: m ()-    displaySize :: m (Integer, Integer)-    blitPlane :: Width -> Height -> Maybe Plane -> Plane -> Integer -> m ()--------------------- Instances --------------------instance MonadDisplay ((->) [Event]) where-    setupDisplay s = s-    clearDisplay = const ()-    displaySize = const (0, 0)-    blitPlane _ _ _ _ _ = const ()---instance MonadDisplay IO where-    setupDisplay = setupDisplayIO-    clearDisplay = clearScreen-    displaySize = displaySizeIO-    blitPlane = blitPlaneIO---setupDisplayIO :: IO s -> IO s-setupDisplayIO m = E.finally (initPart >> m)-                             cleanAndExit -- this will be run regardless-                                          -- of exception--displaySizeIO :: IO (Integer, Integer)-displaySizeIO =-        TS.size >>= \ts ->-        let (TS.Window h w) = maybe (error "cannot get TERM size") id ts-        in return (w, h)---- th tw: terminal width and height--- pn: new plane, po: old plane--- fps sono gli fps attuali, puoi stamparli come preferisci (o non stamparli)--- wo, ho: dimensions of the terminal. If they change, reinit double buffering-blitPlaneIO :: Width -> Height -> Maybe Plane -> Plane -> Integer -> IO ()-blitPlaneIO tw th mpo pn cFps =--        -- old plane-        let-            (pw, ph) = planeSize pn-            bp  = blankPlane pw ph-            po  = pastePlane (maybe bp id mpo) bp (1, 1)-        in--        -- new plane-        let pn'  = pastePlane pn bp (1, 1)-            pn'' = pastePlane (textBox (show cFps) 100 100) pn' (1, 2)-        in--        -- reset formatting and print everything-        -- CA.setSGR [CA.Reset, CA.SetColor CA.Background CA.Dull CA.Black] >>-        CA.setSGR [CA.Reset] >>-        blitMap po pn'' tw th----------------------- ANCILLARIES ----------------------initPart :: IO ()-initPart = -- check thread support-           CM.unless CC.rtsSupportsBoundThreads-                     (error errMes)                  >>-           -- init-           SI.hSetBuffering SI.stdout SI.NoBuffering >>-           SI.hSetEcho SI.stdin False                >>--           -- initial setup/checks-           CA.hideCursor >>-           clearScreen-    where-          errMes = unlines-            ["\nError: you *must* compile this program with -threaded!",-             "Just add",-             "",-             "    ghc-options:      -threaded",-             "",-             "in your .cabal file (executale section) and you will be fine!"]---- clears screen-clearScreen :: IO ()-clearScreen = CA.setCursorPosition 0 0 >>-              CA.setSGR [CA.Reset]     >>-              displaySize              >>= \(w, h) ->-              CM.replicateM_ (fromIntegral $ w*h) (putChar ' ')--cleanAndExit :: IO ()-cleanAndExit = CA.setSGR [CA.Reset]     >>-               CA.clearScreen           >>-               CA.setCursorPosition 0 0 >>-               CA.showCursor---- plane + term w/h-blitMap :: Plane -> Plane -> Width -> Height -> IO ()-blitMap po pn tw th = CM.when (planeSize po /= planeSize pn)-                              (error "blitMap: different plane sizes")      >>-                      CA.setCursorPosition (fi cr) (fi cc)                  >>-                      blitToTerminal cc (orderedCells po) (orderedCells pn)-    where-          (pw, ph) = planeSize pn--          cr = div (th - ph) 2-          cc = div (tw - pw) 2--          fi = fromIntegral--orderedCells :: Plane -> [[Cell]]-orderedCells p = LS.chunksOf (fromIntegral w) cells-    where-          cells  = map snd $ assocsPlane p-          (w, _) = planeSize p----- ordered sequence of cells, both old and new, like they were a String to--- print to screen-blitToTerminal :: Column -> [[Cell]] -> [[Cell]] -> IO ()-blitToTerminal rc ocs ncs = mapM_ blitLine oldNew-    where-          oldNew :: [[(Cell, Cell)]]-          oldNew = zipWith zip ocs ncs+module Terminal.Game.Layer.Object ( module Export ) where -          blitLine :: [(Cell, Cell)] -> IO ()-          blitLine ccs = CM.foldM blitCell 0 ccs              >>-                         CA.cursorDown 1                      >>-                         CA.setCursorColumn (fromIntegral rc)+import Terminal.Game.Layer.Object.Interface as Export+import Terminal.Game.Layer.Object.GameIO    as Export+import Terminal.Game.Layer.Object.Narrate   as Export+import Terminal.Game.Layer.Object.Record    as Export+import Terminal.Game.Layer.Object.Test      as Export -          -- k is "spaces to skip"-          blitCell :: Int -> (Cell, Cell) -> IO Int-          blitCell k (clo, cln)-                | cln == clo = return (k+1)-                | otherwise  = moveIf k         >>= \k' ->-                               putCellStyle cln >>-                               return k'+-- DESIGN NOTES -- -          moveIf :: Int -> IO Int-          moveIf k | k == 0    = return k-                   | otherwise = CA.cursorForward k >>-                                 return 0+-- The classes are described in 'Interface'. -putCellStyle :: Cell -> IO ()-putCellStyle c = CA.setSGR ([CA.Reset] ++ sgrb ++ sgrr) >>-                 putChar (cellChar c)-    where-          sgrb | isBold c  = [CA.SetConsoleIntensity CA.BoldIntensity]-               | otherwise = []+-- The implemented monads are four:+--     - GameIO (via MonadIO): playing the game+--     - Test: testing the game in a pure manner+--     - Record: playing the game and record the Events in a file+--     - Replay: replay a game using a set of Events.+--+-- The last two monads (Record/Replay) take advantage of "overlapping+-- instances". Instead of reimplementing most of what happens in MonadIO,+-- they'll just touch the classes from interface which behaviour they+-- will modify; being more specific, they will be chosen instead of plain+-- IO. -          sgrr | isReversed c = [CA.SetSwapForegroundBackground True]-               | otherwise    = []+-- xxx cambia questa descrizione --- ANCILLARIES --+-- xxx resize term to be smaller and see characters broken [ibispi] -oneTickSec :: Integer-oneTickSec = 10 ^ (6 :: Integer)

@@ -1,19 +0,0 @@----------------------------------------------------------------------------------- Layer 2 (mockable IO), as per--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html--- 2019 Francesco Ariis GPLv3----------------------------------------------------------------------------------module Terminal.Game.Layer.Object.Display where---- import Terminal.Game.Plane--- import Terminal.Game.Draw---- import qualified System.IO                    as SI--- import qualified System.Console.ANSI          as CA--- import qualified Control.Exception            as E--- import qualified Control.Monad                as CM--- import qualified System.Console.Terminal.Size as TS--- import qualified Data.List.Split              as LS--- import qualified Control.Concurrent           as CC-

@@ -0,0 +1,21 @@+-------------------------------------------------------------------------------+-- Layer 2 (mockable IO), as per+-- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html+-- 2019 Francesco Ariis GPLv3+-------------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+++module Terminal.Game.Layer.Object.GameIO where++import qualified Control.Monad.Catch          as MC+import qualified Control.Monad.Trans          as T+++newtype GameIO a = GameIO { runGIO :: IO a }+                 deriving (Functor, Applicative, Monad,+                           T.MonadIO,+                           MC.MonadThrow, MC.MonadCatch, MC.MonadMask)++

@@ -0,0 +1,270 @@+-------------------------------------------------------------------------------+-- Layer 2 (mockable IO), as per+-- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html+-- 2019 Francesco Ariis GPLv3+-------------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Terminal.Game.Layer.Object.IO where++import Terminal.Game.Layer.Object.Interface++import Terminal.Game.Plane+import Terminal.Game.Utils+++import qualified Control.Concurrent           as CC+import qualified Control.Monad                as CM+import qualified Control.Monad.Catch          as MC+import qualified Control.Monad.Trans          as T+import qualified Data.List.Split              as LS+import qualified System.Clock                 as SC+import qualified System.Console.ANSI          as CA+import qualified System.Console.Terminal.Size as TS+import qualified System.IO                    as SI++-- Most General MonadIO operations.++----------------+-- Game input --+----------------++instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadInput m where+    startEvents fps = T.liftIO $ startIOInput Nothing fps+    pollEvents ve = T.liftIO $ CC.swapMVar ve []+    stopEvents ts = T.liftIO $ stopEventsIO ts++-- xxx astrai da qui?+-- filepath = logging+startIOInput :: Maybe (CC.MVar [Event]) -> FPS -> IO InputHandle+startIOInput mr fps =+            -- non buffered input+            SI.hSetBuffering SI.stdin SI.NoBuffering  >>+            SI.hSetBuffering SI.stdout SI.NoBuffering >>+            SI.hSetEcho SI.stdin False                >>+                -- all the buffering settings has to+                -- happen here. If i move them to display,+                -- you need to press enter before playing+                -- the game on some machines.++            -- event and log variables+            CC.newMVar [] >>= \ve ->++            CC.forkIO (addTick mr ve fps) >>= \te ->+            CC.forkIO (addKeypress mr ve) >>= \tk ->+            return (InputHandle ve [te, tk])++-- modifica il timer+-- mr: maybe recording+addTick :: Maybe (CC.MVar [Event]) -> CC.MVar [Event] -> FPS -> IO ()+addTick mr ve fps = addEvent mr ve Tick        >>+                    CC.threadDelay delayAmount >>+                    addTick mr ve fps+    where+          delayAmount :: Int+          delayAmount = fromIntegral $ quot oneTickSec fps++-- get action char+-- mr: maybe recording+addKeypress :: Maybe (CC.MVar [Event]) -> CC.MVar [Event] -> IO ()+addKeypress mr ve = -- vedi platform-dep/+                    inputCharTerminal           >>= \c ->+                    addEvent mr ve (KeyPress c) >>+                    addKeypress mr ve++-- mr: maybe recording+addEvent :: Maybe (CC.MVar [Event]) -> CC.MVar [Event] -> Event -> IO ()+addEvent mr ve e | (Just d) <- mr = vf d >> vf ve+                 | otherwise      =         vf ve+    where+          vf d = CC.modifyMVar_ d (return . (++[e]))++stopEventsIO :: [CC.ThreadId] -> IO ()+stopEventsIO ts = mapM_ CC.killThread ts++-----------------+-- Game timing --+-----------------++instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadTimer m where+    getTime = T.liftIO $ SC.toNanoSecs <$> SC.getTime SC.Monotonic+    sleepABit fps = T.liftIO $+        CC.threadDelay (fromIntegral $ quot oneTickSec (fps*10))++--------------------+-- Error handling --+--------------------++instance {-# OVERLAPS #-} (Monad m, T.MonadIO m, MC.MonadMask m) =>+          MonadException m where+    cleanUpErr m c = MC.finally m c+++-----------+-- Logic --+-----------++instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) =>+          MonadLogic m where+    checkQuit fb s = return (fb s)+++-------------+-- Display --+-------------++instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadDisplay m where+    setupDisplay = T.liftIO initPart+    clearDisplay = T.liftIO clearScreen+    displaySize = T.liftIO displaySizeIO+    blitPlane w h mp p = T.liftIO (blitPlaneIO w h mp p)+    shutdownDisplay = T.liftIO cleanAndExit++displaySizeIO :: IO (Integer, Integer)+displaySizeIO =+        TS.size        >>= \ts ->+            -- cannot use ansi-terminal, on Windows you get+            -- "ConsoleException 87" (too much scrolling)+        isWin32Console >>= \bw ->+        let (TS.Window h w) = maybe (error "cannot get TERM size") id ts+            h' | bw        = h - 1+               | otherwise = h+               -- win32 console has 1 less row available than displayes+               -- (it will scroll and make a mess otherwise)+        in return (w, h')++-- th tw: terminal width and height+-- pn: new plane, po: old plane+-- wo, ho: dimensions of the terminal. If they change, reinit double buffering+blitPlaneIO :: Width -> Height -> Maybe Plane -> Plane -> IO ()+blitPlaneIO tw th mpo pn =++        -- old plane+        let+            (pw, ph) = planeSize pn+            bp  = blankPlane pw ph+            po  = pastePlane (maybe bp id mpo) bp (1, 1)+        in++        -- new plane+        let pn'  = pastePlane pn bp (1, 1)+        in++            -- trimming is foundamental, as blitMap could otherwise print+            -- outside terminal boundaries and scroll to its death+            -- (error 87 on Win32 console).++        CA.setSGR [CA.Reset] >>+        blitMap po pn' tw th+++-----------------+-- ANCILLARIES --+-----------------++initPart :: IO ()+initPart = -- check thread support+           CM.unless CC.rtsSupportsBoundThreads+                     (error errMes)             >>++           -- initial setup/checks+           CA.hideCursor >>++           -- text encoding+           SI.mkTextEncoding "UTF-8//TRANSLIT" >>= \te ->+                -- todo [urgent] change this, and document that+                -- some chars do not work on win+           SI.hSetEncoding SI.stdout te        >>++           clearScreen+    where+          errMes = unlines+            ["\nError: you *must* compile this program with -threaded!",+             "Just add",+             "",+             "    ghc-options:      -threaded",+             "",+             "in your .cabal file (executale section) and you will be fine!"]++-- clears screen+clearScreen :: IO ()+clearScreen = CA.setCursorPosition 0 0 >>+              CA.setSGR [CA.Reset]     >>+              displaySizeIO            >>= \(w, h) ->+              CM.replicateM_ (fromIntegral $ w*h) (putChar ' ')++cleanAndExit :: IO ()+cleanAndExit = CA.setSGR [CA.Reset]     >>+               CA.clearScreen           >>+               CA.setCursorPosition 0 0 >>+               CA.showCursor++-- plane + term w/h+blitMap :: Plane -> Plane -> Width -> Height -> IO ()+blitMap po pn tw th =+            CM.when (planeSize po /= planeSize pn)+                    (error "blitMap: different plane sizes")      >>+            CA.setCursorPosition (fi cr) (fi cc)                  >>+                -- setCursorPosition is *zero* based!+            blitToTerminal cc (orderedCells po) (orderedCells pn)+    where+          (pw, ph) = planeSize pn++          cr = div (th - ph) 2+          cc = div (tw - pw) 2++          fi = fromIntegral++orderedCells :: Plane -> [[Cell]]+orderedCells p = LS.chunksOf (fromIntegral w) cells+    where+          cells  = map snd $ assocsPlane p+          (w, _) = planeSize p+++-- ordered sequence of cells, both old and new, like they were a String to+-- print to screen.+-- Remember that this Column is *zero* based+blitToTerminal :: Column -> [[Cell]] -> [[Cell]] -> IO ()+blitToTerminal rc ocs ncs = mapM_ blitLine oldNew+    where+          oldNew :: [[(Cell, Cell)]]+          oldNew = zipWith zip ocs ncs++          blitLine :: [(Cell, Cell)] -> IO ()+          blitLine ccs = CM.foldM blitCell 0 ccs              >>+                         CA.cursorDown 1                      >>+                         CA.setCursorColumn (fromIntegral rc)++          -- k is "spaces to skip"+          blitCell :: Int -> (Cell, Cell) -> IO Int+          blitCell k (clo, cln)+                | cln == clo = return (k+1)+                | otherwise  = moveIf k         >>= \k' ->+                               putCellStyle cln >>+                               return k'++          moveIf :: Int -> IO Int+          moveIf k | k == 0    = return k+                   | otherwise = CA.cursorForward k >>+                                 return 0++putCellStyle :: Cell -> IO ()+putCellStyle c = CA.setSGR ([CA.Reset] ++ sgrb ++ sgrr ++ sgrc) >>+                 putChar (cellChar c)+    where+          sgrb | isBold c  = [CA.SetConsoleIntensity CA.BoldIntensity]+               | otherwise = []++          sgrr | isReversed c = [CA.SetSwapForegroundBackground True]+               | otherwise    = []++          sgrc | Just (k, i) <- cellColor c = [CA.SetColor CA.Foreground i k]+               | otherwise                  = []++oneTickSec :: Integer+oneTickSec = 10 ^ (6 :: Integer)

@@ -0,0 +1,89 @@+-------------------------------------------------------------------------------+-- Layer 2 (mockable IO), as per+-- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html+-- 2019 Francesco Ariis GPLv3+-------------------------------------------------------------------------------++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}++module Terminal.Game.Layer.Object.Interface where++import Terminal.Game.Plane++import qualified Control.Concurrent as CC+import qualified Data.Serialize     as S+import qualified GHC.Generics       as G+import qualified Test.QuickCheck    as Q+++-- mtl inferface for game++type MonadGameIO m = (MonadInput m, MonadTimer m,+                      MonadException m, MonadLogic m,+                      MonadDisplay m)+++----------------+-- Game input --+----------------++-- | Frames per second.+type FPS = Integer++-- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'.+data Event = Tick+           | KeyPress Char+           deriving (Show, Eq, G.Generic)++instance S.Serialize Event where++instance Q.Arbitrary Event where+  arbitrary = Q.oneof [ pure Tick,+                        KeyPress <$> Q.arbitrary ]++data InputHandle = InputHandle+            { ihKeyMVar    :: CC.MVar [Event],+              ihOpenThreds :: [CC.ThreadId] }++class Monad m => MonadInput m where+    startEvents :: FPS -> m InputHandle+    pollEvents  :: CC.MVar [Event] -> m [Event]+    stopEvents :: [CC.ThreadId] -> m ()++-----------------+-- Game timing --+-----------------++class Monad m => MonadTimer m where+    getTime :: m Integer     -- to nanoseconds+    sleepABit :: FPS -> m () -- useful not to hammer cpu while polling++--------------------+-- Error handling --+--------------------++-- if a fails, do b (useful for cleaning up)+class Monad m => MonadException m where+    cleanUpErr :: m a -> m b -> m a++-----------+-- Logic --+-----------++-- if a fails, do b (useful for cleaning up)+class Monad m => MonadLogic m where+    -- decide whether it's time to quit+    checkQuit :: (s -> Bool) -> s -> m Bool++-------------+-- Display --+-------------++class Monad m => MonadDisplay m where+    setupDisplay :: m ()+    clearDisplay :: m ()+    displaySize :: m (Integer, Integer) -- w, h+    blitPlane :: Width -> Height -> Maybe Plane -> Plane -> m ()+    shutdownDisplay :: m ()+

@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++module Terminal.Game.Layer.Object.Narrate where++-- Record Monad, for when I need to play the game and record Events+-- (keypresses and ticks) in a file++import Terminal.Game.Layer.Object.Interface+import Terminal.Game.Layer.Object.IO++import qualified Control.Concurrent   as CC+import qualified Control.Monad        as CM+import qualified Control.Monad.Catch  as MC+import qualified Control.Monad.Reader as R+import qualified Control.Monad.Trans  as T -- MonadIO+import qualified Data.ByteString      as BS+import qualified Data.Serialize       as S+import qualified System.IO            as SI+++newtype Narrate a = Narrate (R.ReaderT [Event] IO a)+                deriving (Functor, Applicative, Monad,+                          T.MonadIO,+                          MC.MonadThrow, MC.MonadCatch, MC.MonadMask)++runReplay :: Narrate a -> [Event] -> IO a+runReplay (Narrate r) e = R.runReaderT r e++-- | Reads a file containing a recorded session.+readRecord :: FilePath -> IO [Event]+readRecord fp = S.decode <$> BS.readFile fp >>= \case+                  Left e  -> error $ "readRecord could not decode: " +++                                    show e+                  Right r -> return r++-- class Monad m => MonadInput m where+--     startEvents :: FPS -> m (CC.MVar [Event], [CC.ThreadId])+--     pollEvents  :: CC.MVar [Event] ->+--                    m [Event]+--     stopEvents :: [CC.ThreadId] -> m ()++instance MonadInput Narrate where+    startEvents fps = Narrate $+                        R.ask >>= \e ->+                        T.liftIO $ startNarrate e fps+    pollEvents ve = T.liftIO $ CC.swapMVar ve []+    stopEvents ts = T.liftIO $ stopEventsIO ts+        -- xxx questi puoi fare dispatch tramite TC?++-- xxx ma narrate deve finire?+instance MonadLogic Narrate where+    checkQuit fs s = Narrate $ R.ask >>= \case+                         [] -> return True+                         _  -> return $ fs s+++++-- xxx astrai da qui?+-- filepath = logging+startNarrate :: [Event] -> FPS -> IO InputHandle+startNarrate env fps =++                   -- non buffered input+                   SI.hSetBuffering SI.stdin SI.NoBuffering  >>+                   SI.hSetBuffering SI.stdout SI.NoBuffering >>+                   SI.hSetEcho SI.stdin False                >>+                   -- xxx astrai this++                   CC.newMVar []                 >>= \ve ->+                   CC.forkIO (addEnv ve env fps) >>= \te ->+                   return (InputHandle ve [te])++addEnv :: CC.MVar [Event] -> [Event] -> FPS -> IO ()+addEnv _  []     _   = error "fine"+                        -- xxx occhio qui+addEnv ve (e:es) fps = addEvent Nothing ve e >>+                       CM.when (e == Tick)+                            (CC.threadDelay delayAmount) >>+                       addEnv ve es fps+    where+          delayAmount :: Int+          delayAmount = fromIntegral $ quot oneTickSec fps++

@@ -0,0 +1,39 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Terminal.Game.Layer.Object.Record where++-- Record Monad, for when I need to play the game and record Events+-- (keypresses and ticks) in a file++import Terminal.Game.Layer.Object.Interface+import Terminal.Game.Layer.Object.IO++import qualified Control.Concurrent   as CC+import qualified Control.Monad.Catch  as MC+import qualified Control.Monad.Reader as R+import qualified Control.Monad.Trans  as T -- MonadIO+import qualified Data.ByteString      as BS+import qualified Data.Serialize       as S++-- record the key pressed in a game session++newtype Record a = Record (R.ReaderT (CC.MVar [Event]) IO a)+                deriving (Functor, Applicative, Monad,+                          T.MonadIO,+                          MC.MonadThrow, MC.MonadCatch, MC.MonadMask)++runRecord :: Record a -> CC.MVar [Event] -> IO a+runRecord (Record r) me = R.runReaderT r me++instance MonadInput Record where+    startEvents fps = Record $+                        R.ask >>= \ve ->+                        T.liftIO $ startIOInput (Just ve) fps+    pollEvents ve = T.liftIO $ CC.swapMVar ve []+    stopEvents ts = T.liftIO $ stopEventsIO ts+        -- xxx questi puoi fare dispatch tramite TC?++writeMoves :: FilePath -> CC.MVar [Event] -> IO ()+writeMoves fp ve = CC.readMVar ve                >>= \es ->+                   BS.writeFile fp (S.encode es)+

@@ -0,0 +1,82 @@+-------------------------------------------------------------------------------+-- Layer 2 (mockable IO), as per+-- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html+-- 2019 Francesco Ariis GPLv3+-------------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++module Terminal.Game.Layer.Object.Test where++-- Test (pure) MonadGame* typeclass implementation for testing purposes.++import Terminal.Game.Layer.Object.Interface++import qualified Control.Monad.RWS as S+++-----------+-- TYPES --+-----------++data Env = Env { eLogging :: Bool,+                 eEvents  :: [Event] }++data TestEvent = TCleanUpError+               | TQuitGame+               | TSetupDisplay+               | TShutdownDisplay+               | TStartGame+               | TStartEvents+               | TStopEvents+        deriving (Eq, Show)++newtype Test a = Test (S.RWS Env [TestEvent] [Event] a)+               deriving (Functor, Applicative, Monad,+                         S.MonadWriter [TestEvent])++runTest :: Test a -> Env -> (a, [TestEvent])+runTest (Test m) e = S.evalRWS m e (eEvents e)+++-----------+-- CLASS --+-----------++tconst :: a -> Test a+tconst a = Test $ return a++mockHandle :: InputHandle+mockHandle = InputHandle (error "mock handle keyMvar")+                         (error "mock handle threads")++instance MonadInput Test where+    startEvents _ = S.tell [TStartEvents] >>+                    return mockHandle+    pollEvents _ = Test $ S.state (\s -> (s, []))+    stopEvents _ = S.tell [TStopEvents] >>+                   return ()++instance MonadTimer Test where+    getTime = return 1+    sleepABit _ = return ()++instance MonadException Test where+    cleanUpErr a _ = S.tell [TCleanUpError] >> a++instance MonadLogic Test where+    -- if eof, quit+    checkQuit fs s = Test $ S.get >>= \case+                               [] -> return True+                               _  -> return (fs s)+    -- xxx astrai anche per narrate++instance MonadDisplay Test where+    setupDisplay = () <$ S.tell [TSetupDisplay]+    clearDisplay = return ()+    displaySize = return (110, 11110)+        -- xxx no display size but check display size+    blitPlane _ _ _ _ = return ()+    shutdownDisplay = () <$ S.tell [TShutdownDisplay]+

@@ -9,28 +9,34 @@ 
 module Terminal.Game.Plane where
 
-import qualified GHC.Generics as G
-import qualified Data.Array as A
-import qualified Data.List as L
-import qualified Data.List.Split as LS
-import qualified Data.Tuple as T
+import qualified Data.Array          as A
+import qualified Data.List           as L
+import qualified Data.List.Split     as LS
+import qualified Data.Tuple          as T
+import qualified GHC.Generics        as G
+import qualified System.Console.ANSI as CA
 
 
 ----------------
 -- DATA TYPES --
 ----------------
 
-type Width  = Integer
-type Height = Integer
+-- | 'Row's and 'Column's are 1-based (top-left position is @1 1@).
+type Coords = (Row, Column)
 type Row    = Integer
 type Column = Integer
-type Coords = (Row, Column) -- row, column, from TL (TL = 1, 1)
 
+-- | Expressed in 'Column's.
+type Width  = Integer
+-- | Expressed in 'Row's.
+type Height = Integer
+
 type Bold     = Bool
 type Reversed = Bool
 
 -- can be an ASCIIChar or a special, transparent character
-data Cell = CellChar Char Bold Reversed
+data Cell = CellChar Char Bold
+                     Reversed (Maybe (CA.Color, CA.ColorIntensity))
           | Transparent
           deriving (Show, Eq, Ord, G.Generic)
 
@@ -44,15 +50,19 @@ ----------
 
 creaCell :: Char -> Cell
-creaCell ch = CellChar ch False False
+creaCell ch = CellChar ch False False Nothing
 
+colorCell :: CA.Color -> CA.ColorIntensity -> Cell -> Cell
+colorCell k i (CellChar c b r _) = CellChar c b r (Just (k, i))
+colorCell _ _ Transparent        = Transparent
+
 boldCell :: Cell -> Cell
-boldCell (CellChar c _ r) = CellChar c True r
-boldCell Transparent      = Transparent
+boldCell (CellChar c _ r k) = CellChar c True r k
+boldCell Transparent        = Transparent
 
 reverseCell :: Cell -> Cell
-reverseCell (CellChar c b _) = CellChar c b True
-reverseCell Transparent      = Transparent
+reverseCell (CellChar c b _ k) = CellChar c b True k
+reverseCell Transparent        = Transparent
 
 -- | Creates 'Plane' from 'String', good way to import ASCII
 -- art/diagrams.
@@ -67,21 +77,26 @@ blankPlane :: Width -> Height -> Plane
 blankPlane w h = listPlane (h, w) (repeat $ creaCell ' ')
 
--- add transparency to a plane, matching a given character
-addVitrum :: Char -> Plane -> Plane
-addVitrum tc p = mapPlane f p
+-- | Adds transparency to a plane, matching a given character
+makeTransparent :: Char -> Plane -> Plane
+makeTransparent tc p = mapPlane f p
     where
           f cl | cellChar cl == tc = Transparent
                | otherwise         = cl
 
+-- | Changes every transparent cell in the 'Plane' to an opaque @' '@
+-- character.
+makeOpaque :: Plane -> Plane
+makeOpaque p = let (w, h) = planeSize p
+               in pastePlane p (blankPlane w h) (1, 1)
 
+
+
 -----------
 -- SLICE --
 -----------
 
--- paste one plane over the other at a certain position (p1 gets over p2).
--- Remember that coordinates start from bottom left!
--- Maybe char = possible transparency
+-- | Paste one plane over the other at a certain position (p1 gets over p2).
 pastePlane :: Plane -> Plane -> Coords -> Plane
 pastePlane p1 p2 (r, c) = updatePlane p2 filtered
     where
@@ -98,30 +113,44 @@           solid (_, Transparent) = False
           solid _                = True
 
+-- | Trims 'Plane' @p@ dimensions to @w@ and @h@, if needed.
+trimPlane :: Plane -> Width -> Height -> Plane
+trimPlane p wt ht = pastePlane p (blankPlane w h) (1, 1)
+    where
+          (wp, hp) = planeSize p
 
+          w = min wt wp
+          h = min ht hp
+
 -------------
 -- INQUIRE --
 -------------
 
+-- | Dimensions or a plane.
 planeSize :: Plane -> (Width, Height)
 planeSize p = T.swap . snd $ A.bounds (fromPlane p)
 
 cellChar :: Cell -> Char
-cellChar (CellChar ch _ _) = ch
-cellChar Transparent       = ' '
+cellChar (CellChar c _ _ _) = c
+cellChar Transparent        = ' '
 
+cellColor :: Cell -> Maybe (CA.Color, CA.ColorIntensity)
+cellColor (CellChar _ _ _ k) = k
+cellColor Transparent        = Nothing
+
 isBold :: Cell -> Bool
-isBold (CellChar _ b _) = b
-isBold _                = False
+isBold (CellChar _ b _ _) = b
+isBold _                  = False
 
 isReversed :: Cell -> Bool
-isReversed (CellChar _ _ r) = r
-isReversed _                = False
+isReversed (CellChar _ _ r _) = r
+isReversed _                  = False
 
 assocsPlane :: Plane -> [(Coords, Cell)]
 assocsPlane p = A.assocs (fromPlane p)
 
--- an '\n' divided (and ended) String ready to be written on file
+-- | A String (@\n@ divided and ended) representing the 'Plane'. Useful
+-- for debugging/testing purposes.
 paperPlane :: Plane -> String
 paperPlane p = unlines . LS.chunksOf w .
                map cellChar . A.elems $ fromPlane p
@@ -169,6 +198,6 @@ 
           vitrous :: Plane
           vitrous = case mc of
-                      Just c  -> addVitrum c plane
+                      Just c  -> makeTransparent c plane
                       Nothing -> plane
 

@@ -12,4 +12,7 @@     it "piles multiple planes together" $       mergePlanes (stringPlane "aa")                   [((1,2), cell 'b')] `shouldBe` stringPlane "ab"-+    it "works in the middle too" $+      mergePlanes (stringPlane "aaa\naaa\naaa")+                  [((2,2), cell 'b')] `shouldBe`+                    stringPlane "aaa\naba\naaa"

@@ -1,13 +1,20 @@ module Terminal.Game.Layer.ImperativeSpec where +import Terminal.Game.Layer.Imperative+import Terminal.Game.Layer.Object.Interface+import Terminal.Game.Layer.Object.Narrate+import Alone+ import Test.Hspec-import Terminal.Game+import Test.Hspec.QuickCheck+import Test.QuickCheck   spec :: Spec 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  )@@ -15,8 +22,24 @@       qf (3, _,    _) = True       qf _            = False       es = [Tick, KeyPress 'c', KeyPress 'c', Tick, Tick]+      g = Game 10 10 nd s lf nd qf    describe "runGame" $ do     it "does not confuse input and logic" $-      runGame s lf nd qf nd es `shouldBe` (3, True, 2)+      testGame g es `shouldBe` (3, True, 2)++  describe "testGame" $ do+    r <- runIO $ readRecord "test/alone-recors-test.gr"+    it "tests a game" $+        testGame aloneInARoom r `shouldBe` MyState (20, 66) Stop True+    it "does not hang on empty/unclosed input" $+        testGame aloneInARoom [Tick] `shouldBe` MyState (10, 10) Stop False+    modifyMaxSize (const 1000) $+      it "does not crash/hang on random input" $ property $+        \e -> let a = testGame aloneInARoom e in a == a++  -- todo recordGame untestable? [test]+  -- describe "recordGame" $ do+  --   it "does write on file even when an exception occours" $+  --     testGame g es `shouldBe` (3, True, 2) 

@@ -22,13 +22,21 @@     it "pastes a simple plane onto another" $       pastePlane (cell 'a') (cell 'b') (1,1) `shouldBe` cell 'a' +  describe "trimPlane" $ do+    it "trims a plane" $+      trimPlane (stringPlane "ab\nc") 1 2 `shouldBe` stringPlane "a\nc"+    it "leaves it untouched on bigger dimensions" $+      trimPlane (stringPlane "ab\nc") 1 3 `shouldBe` stringPlane "a\nc"+    it "other dimesion too" $+      trimPlane (stringPlane "ab\nc") 8 9 `shouldBe` stringPlane "ab\nc"+   describe "stringPlane" $ do     it "creates plane from spec" $       stringPlane ".\n.." `shouldBe` testPlane    describe "stringPlaneTrans" $ do     it "allows transparency" $-      stringPlaneTrans '.' ".\n.." `shouldBe` addVitrum '.' testPlane+      stringPlaneTrans '.' ".\n.." `shouldBe` makeTransparent '.' testPlane    describe "updatePlane" $ do     let ma = listPlane (2,1) (map creaCell "ab")

binary file changed (absent → 194 bytes)