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: 0.2.1.0 +version: 0.3.0.0 synopsis: sdl-like functions for terminal applications, based on ansi-terminal description: Library which aims to replicate standard 2d game @@ -7,15 +7,13 @@ setting. Aims to be cross compatible (based on "ansi-terminal", no unix-only dependencies), practical. - This is a proof of concept release, used to implement - @http://www.ariis.it/static/articles/animascii/page.html@ - . See example folder for some minimal programs. + See example folder for some minimal programs. homepage: none-yet license: GPL-3 license-file: LICENSE author: Francesco Ariis maintainer: fa-ml@ariis.it -copyright: © 2017-2018 Francesco Ariis +copyright: © 2017-2019 Francesco Ariis category: Game build-type: Simple extra-source-files: changes.txt @@ -27,14 +25,14 @@ library exposed-modules: Terminal.Game - other-modules: Terminal.Game.ANSI, - Terminal.Game.Plane, + other-modules: Terminal.Game.Animation, + Terminal.Game.Layer.Imperative, + Terminal.Game.Layer.Object, + Terminal.Game.Layer.Object.Display, Terminal.Game.Draw, - Terminal.Game.Animation, Terminal.Game.Input, - Terminal.Game.Timer, - Terminal.Game.GameLoop - Terminal.Game.Utils + Terminal.Game.Plane, + Terminal.Game.Timer build-depends: base == 4.*, ansi-terminal == 0.8.*, array == 0.5.*, @@ -42,11 +40,13 @@ cereal == 0.5.*, clock == 0.7.*, linebreak == 1.0.*, + mtl == 2.2.*, split == 0.2.*, terminal-size == 0.3.*, timers-tick == 0.4.* hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -- horrible horrible horrible hack to make unbuffered input -- work on Windows @@ -57,16 +57,42 @@ test-suite test default-language: Haskell2010 - ghc-options: -Wall - HS-Source-Dirs: test, src + hs-Source-Dirs: test, src main-is: Test.hs - build-depends: base==4.*, - array, - linebreak + other-modules: 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.Plane, + Terminal.Game.PlaneSpec + build-depends: base == 4.*, + ansi-terminal == 0.8.*, + array == 0.5.*, + bytestring == 0.10.*, + cereal == 0.5.*, + clock == 0.7.*, + linebreak == 1.0.*, + mtl == 2.2.*, + split == 0.2.*, + terminal-size == 0.3.*, + timers-tick == 0.4.* -- the above plus hspec , hspec 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.*, @@ -77,9 +103,21 @@ hs-source-dirs: example main-is: Alone.hs default-language: Haskell2010 - -- With the -threaded option, only foreign calls with the unsafe - -- attribute will block all other threads. - -- TODO [breaking] [severe] [u:3] senza threaded non compila sin windows - -- required on win before ghc 8.4? + -- 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 diff --git a/example/Alone.hs b/example/Alone.hs --- a/example/Alone.hs +++ b/example/Alone.hs @@ -1,40 +1,43 @@ module Main where --- alone in a room: a scary game --- vai a dormire --- scary room --- escape --- blink exit, blink enemies --- pit --- randomly generated import Terminal.Game main :: IO () -main = gameLoop "Alone in a room" - (GameState (10, 10) Stop False) - logicFun - drawFun - (\gs -> gsQuit gs) - 5 +main = do + runGame (GameState (10, 10) Stop False) + logicFun + drawFun + (\gs -> gsQuit gs) + 10 + return () + -- xxx no () in iok0 --- STATE -- -data GameState = GameState { gsCoord :: (Integer, Integer), +----------- +-- TYPES -- +----------- + +data GameState = GameState { gsCoord :: Coords, gsMove :: Move, gsQuit :: Bool } data Move = N | S | E | W | Stop deriving (Show, Eq) -logicFun :: GameState -> Maybe Char -> IO GameState -logicFun gs (Just 'q') = return $ gs { gsQuit = True } -logicFun (GameState cs m b) Nothing = - return $ GameState (pos m cs) m b -- xxx duplicated code -logicFun (GameState cs m b) (Just c) = - let m' = move m c - in return $ GameState (pos m' cs) m' b +boundaries :: (Coords, Coords) +boundaries = ((1, 1), (25, 80)) + +----------- +-- LOGIC -- +----------- + +logicFun :: GameState -> Event -> GameState +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 } + -- SCI movement move :: Move -> Char -> Move move N 'w' = Stop @@ -47,22 +50,39 @@ move _ 'd' = E move m _ = m --- todo add boundaries pos :: Move -> (Integer, Integer) -> (Integer, Integer) -pos Stop cs = cs -pos N (r, c) = (r-1, c ) -pos S (r, c) = (r+1, c ) -pos E (r, c) = (r , c+1) -pos W (r, c) = (r , c-1) +pos m oldcs | oob newcs = oldcs + | otherwise = newcs + where + newcs = new m oldcs + new Stop cs = cs + new N (r, c) = (r-1, c ) + new S (r, c) = (r+1, c ) + new E (r, c) = (r , c+1) + new W (r, c) = (r , c-1) + ((lr, lc), (hr, hc)) = boundaries + oob (r, c) = r <= lr || c <= lc || + r >= hr || c >= hc + + +---------- -- DRAW -- +---------- drawFun :: GameState -> Plane drawFun (GameState (r, c) _ _) = - blankPlane 80 25 & - (1, 1) % box '_' 80 25 & - (2, 2) % box ' ' 78 23 & - (15, 20) % textBox "tap WASD to move, tap again to stop" - 10 4 & - (r, c) % cell '@' + 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 & + (20, 60) % textBox "Press Q to quit." + 8 10 & + (r, c) % cell '@' # invert + where + mh :: Height + mw :: Width + (mh, mw) = snd boundaries + diff --git a/src/Terminal/Game.hs b/src/Terminal/Game.hs --- a/src/Terminal/Game.hs +++ b/src/Terminal/Game.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Terminal.Game --- Copyright : © 2017-2018 Francesco Ariis +-- Copyright : © 2017-2019 Francesco Ariis -- License : GPLv3 (see LICENSE file) -- -- Maintainer : Francesco Ariis @@ -10,70 +10,64 @@ -- -- 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! +-- -------------------------------------------------------------------------------- -- Basic col-on-black ASCII terminal, operations. -- Only module to be imported. --- todo color [release] --- todo resize screen corruption [grave] --- add docs [release] +-- todo add docs [release] module Terminal.Game ( -- * Game Loop - gameLoop, + MonadGameIO, + FPS, + runGame, + Event(..), -- * Plane - Plane, -- types - Coords, Width, Height, - stringPlane, -- crea + Plane, + Coords, + Row, Column, + Width, Height, + stringPlane, + stringPlaneTrans, blankPlane, addVitrum, - copyPlane, pastePlane, -- slice - planeSize, paperPlane, -- info + pastePlane, + planeSize, paperPlane, -- * Draw - (%), (&), cell, -- draw - box, textBox, + Draw, + (%), (#), (&), + mergePlanes, + cell, box, textBox, + bold, invert, -- * Animations - Animation, Loop(..), -- types + Animation, Loop(..), creaAni, - tick, reset, -- operate - -- xxx metti fetchframe in - -- documentation - -- e anche isexpired + tick, reset, getFrames, - encodeAni, -- serialise - decodeAni, -- * Timers - Timed, -- types + Timed, ExpBehaviour(..), - creaTimer, -- crea + creaTimer, creaBoolTimer, - fetchFrame, isExpired, -- operate + fetchFrame, isExpired, + -- * Utils - screenSize + -- screenSize ) where -import Terminal.Game.GameLoop +import Terminal.Game.Layer.Imperative +import Terminal.Game.Layer.Object +import Terminal.Game.Layer.Object.Display () import Terminal.Game.Plane import Terminal.Game.Draw --- xxx rivedi gli export di animation, encapsula tutto il possibile import Terminal.Game.Animation -import Terminal.Game.Timer -import Terminal.Game.Utils - --- todo text deve essere gestito da una cosa smart, pensa a pp leijin - --- todo [post-first-release] setTitle hSupportsANSI bold? italics? intensity - --- todo geekosaur threaded shit bug - --- 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) --- x hiratara --- [~hiratara@240f:7:4708:1:47a:b8c4:d18a:d063] --- has left Ping timeout: 276 seconds [#haskell] --- geekosaur so if that produces True, it's using the --- threaded runtime; if False, you can say --- something useful instead of hanging - diff --git a/src/Terminal/Game/ANSI.hs b/src/Terminal/Game/ANSI.hs deleted file mode 100644 --- a/src/Terminal/Game/ANSI.hs +++ /dev/null @@ -1,96 +0,0 @@ -------------------------------------------------------------------------------- --- ANSI terminal display --- (C) 2017 Francesco Ariis (GPL v3) -------------------------------------------------------------------------------- - --- Plane to ANSI terminal display - -module Terminal.Game.ANSI where - -import Terminal.Game.Draw -import Terminal.Game.Plane - -import qualified System.Console.ANSI as CA -import qualified Data.List.Split as LS -import qualified Control.Monad as CM -import qualified Data.Array as A - --- xxx elmina 80 cols - --- 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 -blitPlane :: Width -> Height -> Maybe Plane -> Plane -> Integer -> IO () -blitPlane 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 -- ------------------ - --- 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 - -- todo altra funzione invece che un map 2nd? - 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 - - blitLine :: [(Cell, Cell)] -> IO () - blitLine ccs = CM.foldM blitChar 0 ccs >> - CA.cursorDown 1 >> - CA.setCursorColumn (fromIntegral rc) - - -- k is "spaces to skip" - blitChar :: Int -> (Cell, Cell) -> IO Int - blitChar k (clo, cln) - | cln == clo = return (k+1) - | otherwise = moveIf k >>= \k' -> - putChar (cellChar cln) >> - return k' - - moveIf :: Int -> IO Int - moveIf k | k == 0 = return k - | otherwise = CA.cursorForward k >> - return 0 - diff --git a/src/Terminal/Game/Animation.hs b/src/Terminal/Game/Animation.hs --- a/src/Terminal/Game/Animation.hs +++ b/src/Terminal/Game/Animation.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------- -- Animation -- 2018 Francesco Ariis GPLv3 ------------------------------------------------------------------------------- +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE DefaultSignatures #-} +-- {-# LANGUAGE StandaloneDeriving #-} +-- {-# LANGUAGE FlexibleInstances #-} + module Terminal.Game.Animation (module Terminal.Game.Animation, module T ) where @@ -15,13 +16,10 @@ import Control.Timer.Tick as T -import Data.Serialize -import GHC.Generics - -import qualified Data.ByteString as BS -import qualified Data.Bifunctor as BF +-- import Data.Serialize --- todo missing: creaani, creaframe, fetchcurrframe, etc. +-- import qualified Data.ByteString as BS +-- import qualified Data.Bifunctor as BF type Animation = T.Timed Plane @@ -35,19 +33,21 @@ -- deriving instance Generic loc => Generic (Frame loc) -- instance (Generic loc, Serialize loc) => Serialize (Frame loc Integer) -instance Serialize ExpBehaviour -instance Serialize Loop -instance Serialize Cell -instance Serialize Plane -instance Serialize Animation +-- -- xxx vanno messe in timers +-- instance Serialize ExpBehaviour +-- instance Serialize Loop -encodeAni :: FilePath -> Animation -> IO () -encodeAni fp fs = BS.writeFile fp (encode fs) +-- instance Serialize Cell +-- instance Serialize Plane +-- instance Serialize Animation -decodeAni :: FilePath -> IO (Either String Animation) -decodeAni fp = fmap decode (BS.readFile fp) >>= - return . BF.bimap err id - where - err se = fp ++ ": " ++ se +-- encodeAni :: FilePath -> Animation -> IO () +-- encodeAni fp fs = BS.writeFile fp (encode fs) + +-- decodeAni :: FilePath -> IO (Either String Animation) +-- decodeAni fp = fmap decode (BS.readFile fp) >>= +-- return . BF.bimap err id +-- where +-- err se = fp ++ ": " ++ se diff --git a/src/Terminal/Game/Draw.hs b/src/Terminal/Game/Draw.hs --- a/src/Terminal/Game/Draw.hs +++ b/src/Terminal/Game/Draw.hs @@ -7,13 +7,15 @@ -- assumed to be opaque module Terminal.Game.Draw (module Terminal.Game.Draw, - module DF) where + (F.&) + ) where import Terminal.Game.Plane import Text.LineBreak -import Data.Function as DF ( (&) ) +import qualified Data.Function as F ( (&) ) +import qualified Data.List as L ----------- -- TYPES -- @@ -21,26 +23,77 @@ type Draw = Plane -> Plane + +----------------- +-- COMBINATORS -- +----------------- + +-- | Pastes one 'Plane' onto another. To be used along with 'F.&' +-- like this: +-- +-- @ +-- d :: Plane +-- d = blankPlane (100, 100) & +-- (3, 4) % box '_' (3, 5) & +-- (a, b) % cell \'A\' '#' bold +-- @ (%) :: Coords -> Plane -> Draw cds % p1 = \p2 -> pastePlane p1 p2 cds +infixl 4 % - -- most of the drawing is done with % and &, e.g. - -- - -- let d :: Plane - -- d = blankPlane (100, 100) & - -- (3, 4) % box '_' Yellow (3, 5) & - -- (a, b) % butCell '@' Red - -- +-- | Apply style to plane, e.g. +-- +-- > cell 'w' # bold +(#) :: Plane -> Draw -> Plane +p # sf = sf p +infixl 8 # +-- | Shorthand for sequencing 'Plane's, e.g. +-- +-- @ +-- firstPlane & +-- (3, 4) '%' secondPlane & +-- (1, 9) '%' thirdPlane +-- @ +-- +-- is equal to +-- +-- @ +-- mergePlanes firstPlane [((3,4), secondPlane), +-- ((1,9), thirdPlane)] +-- @ +mergePlanes :: Plane -> [(Coords, Plane)] -> Plane +mergePlanes p cps = L.foldl' addPlane p cps + where + addPlane :: Plane -> (Coords, Plane) -> Plane + addPlane bp (cs, tp) = bp F.& cs % tp + + +------------ +-- STYLES -- +------------ + +-- | Apply bold style to 'Plane'. +bold :: Plane -> Plane +bold p = mapPlane boldCell p + +-- | Swap foreground and background colours of 'Plane'. +invert :: Plane -> Plane +invert p = mapPlane reverseCell p + + + ------------- -- DRAWING -- ------------- +-- | A box of dimensions @w h@. box :: Char -> Width -> Height -> Plane box chr w h = seqCellsDim w h cells where cells = [((r, c), chr) | r <- [1..h], c <- [1..w]] +-- | A @1x1@ cell. cell :: Char -> Plane cell ch = box ch 1 1 @@ -57,7 +110,6 @@ hyp = Nothing -- Just english_GB bf = BreakFormat (fromIntegral w) 4 '-' hyp hcs = breakStringLn bf (take (fromIntegral $ w*h) cs) - hl = fromIntegral $ length hcs f :: [String] -> [(Coords, Char)] f css = concatMap (uncurry rf) (zip [1..] css) diff --git a/src/Terminal/Game/GameLoop.hs b/src/Terminal/Game/GameLoop.hs deleted file mode 100644 --- a/src/Terminal/Game/GameLoop.hs +++ /dev/null @@ -1,193 +0,0 @@ -------------------------------------------------------------------------------- --- Input/compute/output loop --- 2017 Francesco Ariis GPLv3 -------------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -module Terminal.Game.GameLoop where - -import Terminal.Game.Plane -import Terminal.Game.Input -import Terminal.Game.ANSI -import Terminal.Game.Utils -import Control.Concurrent - -import qualified System.IO as SI -import qualified Control.Monad as CM -import qualified System.Console.ANSI as CA -import qualified System.Console.Terminal.Size as TS -import qualified System.Clock as SC -import qualified Control.Exception as E - --- todo [release] [study] no full IO for s, but a --- jailed IO (provided by a datatype), both for I --- and for O - --- todo elimina fps ora che li puoi fare on IO - --- | 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. -gameLoop :: String -- ^Terminal title. - -> s -- ^Initial state of the game. - -> (s -> Maybe Char -> IO s) -- ^Logic function. - -> (s -> Plane) -- ^Draw function. - -> (s -> Bool) -- ^\"Should I quit?" function. - -> Integer -- ^Framerate (in fps). - -> IO () -gameLoop t s lf df qf fps = - - E.finally (initPart >> game) - cleanAndExit -- this will be run regardless - -- of exception - where - initPart :: IO () - initPart = -- init - SI.hSetBuffering SI.stdout SI.NoBuffering >> - SI.hSetBuffering SI.stdin SI.NoBuffering >> - SI.hSetEcho SI.stdin False >> - - -- title and initial setup/checks - CA.setTitle t >> - CA.hideCursor >> - blackScreen - - game :: IO () - game = -- mvars & fork - newMVar 1 >>= \frameCounter -> - newMVar Nothing >>= \inputChar -> - forkIO (inputAction inputChar) >> - forkIO (incTimer frameCounter fps) >> - - logicDraw inputChar frameCounter - s lf df qf Nothing - (initFPSCounter 20) (0,0) - - ----------------- --- CONCURRENT -- ----------------- - --- get action char -inputAction :: MVar (Maybe Char) -> IO () -inputAction mc = -- vedi platform-dep/ - inputCharTerminal >>= \c -> - swapMVar mc (Just c) >> - inputAction mc - --- modifica il timer -incTimer :: MVar Integer -> Integer -> IO () -incTimer mi fps = modifyMVar_ mi (return . succ) >> - threadDelay delayAmount >> - incTimer mi fps - where - delayAmount :: Int - delayAmount = fromIntegral $ div (10^6) fps - - --- from http://www.loomsoft.net/resources/alltut/alltut_lesson5.htm -logicDraw :: MVar (Maybe Char) -> MVar Integer -> s -> -- input, ticks, state - (s -> Maybe Char -> IO s) -> -- logic function - (s -> Plane) -> -- draw function - (s -> Bool) -> -- quit? function - Maybe Plane -> -- last blitted screen - FPSCounter -> -- FPS counter - (Width, Height) -> -- Term Dimensions - IO () -logicDraw mc mi s lf df qf opln fc td = - - -- not to hog CPU cycles - -- todo come mai 300 così alto? come influenza i timer? - threadDelay 300 >> - - -- quit? - if qf s - then return () - else - - -- no tick from timer yet? - readMVar mi >>= \k -> - if k <= 0 - then logicDraw mc mi s lf df qf opln fc td - else - - -- do logic - readMVarNothing mc >>= \c -> - modifyMVar mi (\a -> return (a-1, a-1)) >>= \k' -> - lf s c >>= \s' -> - - -- not enough logic done? Skip blitting - if k' > 0 - then logicDraw mc mi s' lf df qf opln fc td - else - - -- clear screen if resolution change - screenSize >>= \td'@(tw, th) -> - let resc = td /= td' in - CM.when resc blackScreen >> - - 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' -> - logicDraw mc mi s' lf df qf (Just npln) fc' td' - - ------------------ --- FPS COUNTER -- ------------------ - --- poll fps every x frames, current fps, stored time, current fps -data FPSCounter = FPSCounter Integer Integer SC.TimeSpec Integer - --- poll utctime every x ticks -initFPSCounter :: Integer -> FPSCounter -initFPSCounter x = FPSCounter x 0 0 0 - -tickCounter :: FPSCounter -> IO FPSCounter -tickCounter (FPSCounter g e t1 cf) - | g > e = return (FPSCounter g (e+1) t1 cf) - | g == e = SC.getTime SC.Monotonic >>= \t2 -> - let dtn = SC.toNanoSecs $ SC.diffTimeSpec t2 t1 - fr = fi dtn / fi (g+1) - fps = round $ fi (10^9) / fr in - --- xxx no div - return (FPSCounter g 0 t2 fps) - | otherwise = error "tickCounter: g < e" - where - fi = fromIntegral - -getCurrFPS :: FPSCounter -> Integer -getCurrFPS (FPSCounter _ _ _ cFps) = cFps - ------------------ --- ANCILLARIES -- ------------------ - --- todo [release] catch any exception in IO and execute this -cleanAndExit :: IO () -cleanAndExit = CA.setSGR [CA.Reset] >> - CA.clearScreen >> - CA.setCursorPosition 0 0 >> - CA.showCursor - -readMVarNothing :: MVar (Maybe a) -> IO (Maybe a) -readMVarNothing mvar = readMVar mvar >>= \ma -> - CM.unless (null ma) - (() <$ swapMVar mvar Nothing) >> - return ma - --- turn screen into black -blackScreen :: IO () -blackScreen = CA.setCursorPosition 0 0 >> - -- CA.setSGR [CA.Reset, - -- CA.SetColor CA.Foreground CA.Dull CA.White, - -- CA.SetColor CA.Background CA.Dull CA.Black] >> - -- è dull black che voglio? - screenSize >>= \(w, h) -> - CM.replicateM_ (fromIntegral $ w*h) (putChar ' ') - diff --git a/src/Terminal/Game/Layer/Imperative.hs b/src/Terminal/Game/Layer/Imperative.hs new file mode 100644 --- /dev/null +++ b/src/Terminal/Game/Layer/Imperative.hs @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------- +-- Layer 1 (imperative), as per +-- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html +-- 2019 Francesco Ariis GPLv3 +------------------------------------------------------------------------------- + +{-# Language ScopedTypeVariables #-} + +module Terminal.Game.Layer.Imperative where + +import Terminal.Game.Layer.Object + +import qualified Control.Monad.Reader as R +import qualified Control.Concurrent as CC +import qualified Control.Monad as CM + +import Terminal.Game.Plane + + +type Game m a = R.ReaderT Config m a + +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) + 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))) + + +-- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm +gameLoop :: MonadGameIO m => + 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 -> + + -- quit? + if qf s + then return s + else + + -- no events? skip everything + if null es + then sleepABit (cFPS c) >> + gameLoop c s lf df qf opln td fc + else + + -- logic + let s' = stepsLogic s lf es in + + -- clear screen if resolution change + displaySize >>= \td'@(tw, th) -> + let resc = td /= td' in + CM.when resc clearDisplay >> + + -- draw + -- xxx solo se è tick e non kpress? + 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' -> + + gameLoop c s' lf df qf (Just npln) td' fc' + + +stepsLogic :: s -> (s -> Event -> s) -> [Event] -> s +stepsLogic s lf es = foldl lf s es + + +----------------- +-- FPS COUNTER -- +----------------- + +-- poll fps every x frames, current fps, stored time, current fps +data FPSCounter = FPSCounter Integer Integer Integer Integer + +-- poll utctime every x ticks +initFPSCounter :: Integer -> FPSCounter +initFPSCounter x = FPSCounter x 0 0 0 + +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 + +getCurrFPS :: FPSCounter -> Integer +getCurrFPS (FPSCounter _ _ _ cFps) = cFps diff --git a/src/Terminal/Game/Layer/Object.hs b/src/Terminal/Game/Layer/Object.hs new file mode 100644 --- /dev/null +++ b/src/Terminal/Game/Layer/Object.hs @@ -0,0 +1,262 @@ +------------------------------------------------------------------------------- +-- 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 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 = 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.hSetBuffering SI.stdin 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 + + 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) >> + putChar (cellChar c) + where + sgrb | isBold c = [CA.SetConsoleIntensity CA.BoldIntensity] + | otherwise = [] + + sgrr | isReversed c = [CA.SetSwapForegroundBackground True] + | otherwise = [] + +-- ANCILLARIES -- + +oneTickSec :: Integer +oneTickSec = 10 ^ (6 :: Integer) diff --git a/src/Terminal/Game/Layer/Object/Display.hs b/src/Terminal/Game/Layer/Object/Display.hs new file mode 100644 --- /dev/null +++ b/src/Terminal/Game/Layer/Object/Display.hs @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------- +-- 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 + diff --git a/src/Terminal/Game/Plane.hs b/src/Terminal/Game/Plane.hs --- a/src/Terminal/Game/Plane.hs +++ b/src/Terminal/Game/Plane.hs @@ -11,7 +11,6 @@ import qualified GHC.Generics as G import qualified Data.Array as A -import qualified Data.Char as C import qualified Data.List as L import qualified Data.List.Split as LS import qualified Data.Tuple as T @@ -27,54 +26,46 @@ type Column = Integer type Coords = (Row, Column) -- row, column, from TL (TL = 1, 1) +type Bold = Bool +type Reversed = Bool + -- can be an ASCIIChar or a special, transparent character -data Cell = CellChar Char +data Cell = CellChar Char Bold Reversed | Transparent deriving (Show, Eq, Ord, G.Generic) --- A place where to blit stuff. Coordinates starts from top left --- corner (1, 1) -newtype Plane = Plane { fromPlane :: (A.Array Coords Cell) } +-- | A two-dimensional surface (Row, Column) where to blit stuff. +newtype Plane = Plane { fromPlane :: A.Array Coords Cell } deriving (Show, Eq, G.Generic) + ---------- -- CREA -- ---------- creaCell :: Char -> Cell -creaCell ch = CellChar ch - --- creates plane from a string, good to import ascii art/diagrams/etc. --- Char indicates transparency, integer = pic width -stringPlane :: Maybe Char -> Integer -> String -> Plane -stringPlane mc w t = vitrous - where - lined = lines t - - h :: Integer - h = L.genericLength lined - - pad :: Integer -> String -> String - pad mw t = take (fromIntegral mw) (t ++ repeat ' ') - - padded :: [String] - padded = map (pad w) lined +creaCell ch = CellChar ch False False - celled :: [Cell] - celled = map creaCell . concat $ padded +boldCell :: Cell -> Cell +boldCell (CellChar c _ r) = CellChar c True r +boldCell Transparent = Transparent - plane :: Plane - plane = Plane $ A.listArray ((1,1), (h, w)) celled +reverseCell :: Cell -> Cell +reverseCell (CellChar c b _) = CellChar c b True +reverseCell Transparent = Transparent - vitrous :: Plane - vitrous = case mc of - Just c -> addVitrum c plane - Nothing -> plane +-- | Creates 'Plane' from 'String', good way to import ASCII +-- art/diagrams. +stringPlane :: String -> Plane +stringPlane t = stringPlaneGeneric Nothing t +-- | Same as 'stringPlane', but with transparent 'Char'. +stringPlaneTrans :: Char -> String -> Plane +stringPlaneTrans c t = stringPlaneGeneric (Just c) t --- creates an empty, opaque Plane (limits: TL, BR) +-- | Creates an empty, opaque 'Plane'. blankPlane :: Width -> Height -> Plane -blankPlane w h = Plane $ A.listArray ((1,1), (h, w)) (repeat $ creaCell ' ') +blankPlane w h = listPlane (h, w) (repeat $ creaCell ' ') -- add transparency to a plane, matching a given character addVitrum :: Char -> Plane -> Plane @@ -88,22 +79,6 @@ -- SLICE -- ----------- --- copies a slice of the plane (bl, tr) -copyPlane :: Plane -> Coords -> Coords -> Plane -copyPlane p (r1, c1) (r2, c2) = - Plane $ A.listArray ((1, 1), (w', h')) (map snd section) - where - inside ((r, c), _) | r >= r1 && r <= r2 && - c >= c1 && c <= c2 = True - | otherwise = False - - (w, h) = planeSize p - - w' = min w c2 - max c1 1 + 1 - h' = min h r2 - max r1 1 + 1 - - section = filter inside (assocsPlane p) - -- 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 @@ -121,7 +96,7 @@ | otherwise = False solid (_, Transparent) = False - solid (_, otherwise) = True + solid _ = True ------------- @@ -132,25 +107,28 @@ planeSize p = T.swap . snd $ A.bounds (fromPlane p) cellChar :: Cell -> Char -cellChar (CellChar ch) = ch -cellChar Transparent = ' ' +cellChar (CellChar ch _ _) = ch +cellChar Transparent = ' ' +isBold :: Cell -> Bool +isBold (CellChar _ b _) = b +isBold _ = False + +isReversed :: Cell -> Bool +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 paperPlane :: Plane -> String paperPlane p = unlines . LS.chunksOf w . - map c2c . A.elems $ fromPlane p + map cellChar . A.elems $ fromPlane p where w :: Int w = fromIntegral . fst . planeSize $ p - c2c :: Cell -> Char - c2c Transparent = ' ' - c2c (CellChar c) = c - - ----------------- -- ANCILLARIES -- ----------------- @@ -162,3 +140,35 @@ -- Array.// updatePlane :: Plane -> [(Coords, Cell)] -> Plane updatePlane (Plane a) kcs = Plane $ a A.// kcs + +listPlane :: Coords -> [Cell] -> Plane +listPlane (r, c) cs = Plane $ A.listArray ((1,1), (r, c)) cs + +stringPlaneGeneric :: Maybe Char -> String -> Plane +stringPlaneGeneric mc t = vitrous + where + lined = lines t + + h :: Integer + h = L.genericLength lined + + w :: Integer + w = maximum (map L.genericLength lined) + + pad :: Integer -> String -> String + pad mw tl = take (fromIntegral mw) (tl ++ repeat ' ') + + padded :: [String] + padded = map (pad w) lined + + celled :: [Cell] + celled = map creaCell . concat $ padded + + plane :: Plane + plane = listPlane (h, w) celled + + vitrous :: Plane + vitrous = case mc of + Just c -> addVitrum c plane + Nothing -> plane + diff --git a/src/Terminal/Game/Utils.hs b/src/Terminal/Game/Utils.hs deleted file mode 100644 --- a/src/Terminal/Game/Utils.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Terminal.Game.Utils where - -import Terminal.Game.Plane - -import qualified System.Console.Terminal.Size as TS - -screenSize :: IO (Width, Height) -screenSize = - TS.size >>= \ts -> - let (TS.Window h w) = maybe (error "cannot get TERM size") id ts - in return (w, h) diff --git a/test/Terminal/Game/DrawSpec.hs b/test/Terminal/Game/DrawSpec.hs new file mode 100644 --- /dev/null +++ b/test/Terminal/Game/DrawSpec.hs @@ -0,0 +1,15 @@ +module Terminal.Game.DrawSpec where + +import Test.Hspec +import Terminal.Game.Plane +import Terminal.Game.Draw + + +spec :: Spec +spec = do + + describe "mergePlanes" $ do + it "piles multiple planes together" $ + mergePlanes (stringPlane "aa") + [((1,2), cell 'b')] `shouldBe` stringPlane "ab" + diff --git a/test/Terminal/Game/Layer/ImperativeSpec.hs b/test/Terminal/Game/Layer/ImperativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Terminal/Game/Layer/ImperativeSpec.hs @@ -0,0 +1,22 @@ +module Terminal.Game.Layer.ImperativeSpec where + +import Test.Hspec +import Terminal.Game + + +spec :: Spec +spec = do + + let nd = error "" + 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 + es = [Tick, KeyPress 'c', KeyPress 'c', Tick, Tick] + + describe "runGame" $ do + it "does not confuse input and logic" $ + runGame s lf nd qf nd es `shouldBe` (3, True, 2) + diff --git a/test/Terminal/Game/PlaneSpec.hs b/test/Terminal/Game/PlaneSpec.hs new file mode 100644 --- /dev/null +++ b/test/Terminal/Game/PlaneSpec.hs @@ -0,0 +1,38 @@ +module Terminal.Game.PlaneSpec where + +import Test.Hspec +import Terminal.Game.Plane +import Terminal.Game.Draw + + +spec :: Spec +spec = do + + let testPlane = blankPlane 2 2 & + (1,1) % box '.' 2 2 & + (1,2) % cell ' ' + + describe "listPlane" $ do + it "creates a plane from string" $ + listPlane (2,2) (map creaCell ". ..") `shouldBe` testPlane + it "ignores extra characters" $ + listPlane (2,2) (map creaCell ". ..abc") `shouldBe` testPlane + + describe "pastePlane" $ do + it "pastes a simple plane onto another" $ + pastePlane (cell 'a') (cell 'b') (1,1) `shouldBe` cell 'a' + + describe "stringPlane" $ do + it "creates plane from spec" $ + stringPlane ".\n.." `shouldBe` testPlane + + describe "stringPlaneTrans" $ do + it "allows transparency" $ + stringPlaneTrans '.' ".\n.." `shouldBe` addVitrum '.' testPlane + + describe "updatePlane" $ do + let ma = listPlane (2,1) (map creaCell "ab") + mb = listPlane (2,1) (map creaCell "xb") + it "updates a Plane" $ + updatePlane ma [((1,1), creaCell 'x')] `shouldBe` mb +