ansi-terminal-game-0.3.0.0: src/Terminal/Game/Layer/Object.hs
-------------------------------------------------------------------------------
-- 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)