ansi-terminal-game-1.3.0.0: src/Terminal/Game/Layer/Object/IO.hs
-------------------------------------------------------------------------------
-- 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, MC.MonadThrow m) =>
MonadException m where
cleanUpErr m c = MC.finally m c
throwExc t = MC.throwM t
-----------
-- Logic --
-----------
instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) =>
MonadLogic m where
checkQuit fb s = return (fb s)
-------------
-- Display --
-------------
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 (Maybe (Width, Height))
displaySizeIO =
TS.size >>= \ts ->
-- cannot use ansi-terminal, on Windows you get
-- "ConsoleException 87" (too much scrolling)
isWin32Console >>= \bw ->
return (fmap (f bw) ts)
where
f :: Bool -> TS.Window Int -> (Width, Height)
f wbw (TS.Window h w) =
let h' | wbw = h - 1
| otherwise = h
in (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 (executable section) and you will be fine!"]
-- clears screen
clearScreen :: IO ()
clearScreen = CA.setCursorPosition 0 0 >>
CA.setSGR [CA.Reset] >>
displaySizeErr >>= \(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 (cr, 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.
-- Coords: initial blitting position
-- Remember that this Column is *zero* based
blitToTerminal :: Coords -> [[Cell]] -> [[Cell]] -> IO ()
blitToTerminal (rr, rc) ocs ncs = CM.foldM_ blitLine rr oldNew
where
oldNew :: [[(Cell, Cell)]]
oldNew = zipWith zip ocs ncs
-- row = previous row
blitLine :: Row -> [(Cell, Cell)] -> IO Row
blitLine pr ccs =
CM.foldM_ blitCell 0 ccs >>
-- have to use setCursorPosition (instead of nextrow) b/c
-- on win there is an auto "go-to-next-line" when reaching
-- column end and on win it does not do so
let wr = pr + 1 in
CA.setCursorPosition (fromIntegral wr)
(fromIntegral rc) >>
return wr
-- 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)