{-# 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
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)
type FPS = Integer
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 =
SI.hSetBuffering SI.stdin
SI.NoBuffering >>
CC.newMVar [] >>= \ve ->
CC.forkIO (addTick ve fps) >>
CC.forkIO (addKeypress ve) >>
return ve
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
addKeypress :: CC.MVar [Event] -> IO ()
addKeypress ve =
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
class Monad m => MonadTimer m where
getTime :: m Integer
sleepABit :: FPS -> m ()
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 ()
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 ()
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
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)
blitPlaneIO :: Width -> Height -> Maybe Plane -> Plane -> Integer -> IO ()
blitPlaneIO tw th mpo pn cFps =
let
(pw, ph) = planeSize pn
bp = blankPlane pw ph
po = pastePlane (maybe bp id mpo) bp (1, 1)
in
let pn' = pastePlane pn bp (1, 1)
pn'' = pastePlane (textBox (show cFps) 100 100) pn' (1, 2)
in
CA.setSGR [CA.Reset] >>
blitMap po pn'' tw th
initPart :: IO ()
initPart =
CM.unless CC.rtsSupportsBoundThreads
(error errMes) >>
SI.hSetBuffering SI.stdout SI.NoBuffering >>
SI.hSetEcho SI.stdin False >>
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!"]
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
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
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)
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 = []
oneTickSec :: Integer
oneTickSec = 10 ^ (6 :: Integer)