------------------------------------------------------------------------------- -- 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)