-------------------------------------------------------------------------------
-- 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.Utils

import Terminal.Game.Layer.Object.Interface
import Terminal.Game.Layer.Object.Primitive
import Terminal.Game.Plane

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 GHC.IO.StdHandles            as GH
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 :: Integer -> m InputHandle
startEvents Integer
tps = IO InputHandle -> m InputHandle
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO InputHandle -> m InputHandle)
-> IO InputHandle -> m InputHandle
forall a b. (a -> b) -> a -> b
$ Integer -> IO InputHandle
startIOInput Integer
tps
    pollEvents :: MVar [Event] -> m [Event]
pollEvents MVar [Event]
ve = IO [Event] -> m [Event]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO [Event] -> m [Event]) -> IO [Event] -> m [Event]
forall a b. (a -> b) -> a -> b
$ MVar [Event] -> [Event] -> IO [Event]
forall a. MVar a -> a -> IO a
CC.swapMVar MVar [Event]
ve []
    stopEvents :: [ThreadId] -> m ()
stopEvents [ThreadId]
ts = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [ThreadId] -> IO ()
stopEventsIO [ThreadId]
ts
    areEventsOver :: m Bool
areEventsOver = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      -- IO monad is the actual game, we never quit bar if
      -- the logic function returns `Right`.


-- filepath = logging
startIOInput :: TPS -> IO InputHandle
startIOInput :: Integer -> IO InputHandle
startIOInput Integer
tps =
            Handle -> BufferMode -> IO ()
SI.hSetBuffering Handle
SI.stdin BufferMode
SI.NoBuffering  IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            Handle -> BufferMode -> IO ()
SI.hSetBuffering Handle
SI.stdout BufferMode
SI.NoBuffering IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            Handle -> Bool -> IO ()
SI.hSetEcho Handle
SI.stdin Bool
False                IO () -> IO (MVar [Event]) -> IO (MVar [Event])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                -- all the buffering settings has to happen
                -- at the top of startIOInput. If i move
                -- them to display, you need to press enter
                -- before playing the game on some machines.

            -- event and log variables
            [Event] -> IO (MVar [Event])
forall a. a -> IO (MVar a)
CC.newMVar [] IO (MVar [Event])
-> (MVar [Event] -> IO InputHandle) -> IO InputHandle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MVar [Event]
ve ->

            Integer -> IO Integer
getTimeTick Integer
tps               IO Integer -> (Integer -> IO InputHandle) -> IO InputHandle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
it ->
            IO () -> IO ThreadId
CC.forkIO (MVar [Event] -> Integer -> Integer -> IO ()
addTick MVar [Event]
ve Integer
tps Integer
it) IO ThreadId -> (ThreadId -> IO InputHandle) -> IO InputHandle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ThreadId
te ->
            IO () -> IO ThreadId
CC.forkIO (MVar [Event] -> IO ()
addKeypress MVar [Event]
ve)    IO ThreadId -> (ThreadId -> IO InputHandle) -> IO InputHandle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ThreadId
tk ->
            InputHandle -> IO InputHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar [Event] -> [ThreadId] -> InputHandle
InputHandle MVar [Event]
ve [ThreadId
te, ThreadId
tk])

-- a precise timer, not based on `threadDelay`
type Elapsed = Integer -- in `Ticks`

-- elapsed from Epoch in ticks
getTimeTick :: TPS -> IO Elapsed
getTimeTick :: Integer -> IO Integer
getTimeTick Integer
tps =
        IO Integer
forall (m :: * -> *). MonadTimer m => m Integer
getTime IO Integer -> (Integer -> IO Integer) -> IO Integer
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
tm ->
        let ns :: Integer
ns = Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
9 :: Integer)
            t1 :: Integer
t1 = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot Integer
ns Integer
tps in
        Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot Integer
tm Integer
t1)

-- mr: maybe recording
addTick :: CC.MVar [Event] -> TPS -> Elapsed -> IO ()
addTick :: MVar [Event] -> Integer -> Integer -> IO ()
addTick MVar [Event]
ve Integer
tps Integer
el =
                -- precise timing. With `treadDelay`, on finer TPS,
                -- ticks take too much (check threadDelay doc).
                Integer -> IO Integer
getTimeTick Integer
tps                   IO Integer -> (Integer -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
t ->
                Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
CM.replicateM_ (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
tInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
el)
                               (MVar [Event] -> Event -> IO ()
addEvent MVar [Event]
ve Event
Tick) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

                -- sleep some
                Integer -> IO ()
forall (m :: * -> *). MonadTimer m => Integer -> m ()
sleepABit Integer
tps IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                MVar [Event] -> Integer -> Integer -> IO ()
addTick MVar [Event]
ve Integer
tps Integer
t

-- get action char
-- mr: maybe recording
addKeypress :: CC.MVar [Event] -> IO ()
addKeypress :: MVar [Event] -> IO ()
addKeypress MVar [Event]
ve = -- vedi platform-dep/
                 IO Char
inputCharTerminal        IO Char -> (Char -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Char
c ->
                 MVar [Event] -> Event -> IO ()
addEvent MVar [Event]
ve (Char -> Event
KeyPress Char
c) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 MVar [Event] -> IO ()
addKeypress MVar [Event]
ve

-- mr: maybe recording
addEvent :: CC.MVar [Event] -> Event -> IO ()
addEvent :: MVar [Event] -> Event -> IO ()
addEvent MVar [Event]
ve Event
e = MVar [Event] -> IO ()
vf MVar [Event]
ve
    where
          vf :: MVar [Event] -> IO ()
vf MVar [Event]
d = MVar [Event] -> ([Event] -> IO [Event]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
CC.modifyMVar_ MVar [Event]
d ([Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Event] -> IO [Event])
-> ([Event] -> [Event]) -> [Event] -> IO [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++[Event
e]))

stopEventsIO :: [CC.ThreadId] -> IO ()
stopEventsIO :: [ThreadId] -> IO ()
stopEventsIO [ThreadId]
ts = (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
CC.killThread [ThreadId]
ts

-----------------
-- Game timing --
-----------------

instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadTimer m where
    getTime :: m Integer
getTime = IO Integer -> m Integer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Integer
SC.toNanoSecs (TimeSpec -> Integer) -> IO TimeSpec -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
SC.getTime Clock
SC.Monotonic
    sleepABit :: Integer -> m ()
sleepABit Integer
tps = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        Int -> IO ()
CC.threadDelay (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot Integer
oneTickSec (Integer
tpsInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
10))

--------------------
-- Error handling --
--------------------

instance {-# OVERLAPS #-}
        (Monad m, T.MonadIO m, MC.MonadMask m, MC.MonadThrow m) =>
          MonadException m where
    cleanUpErr :: forall a b. m a -> m b -> m a
cleanUpErr m a
m m b
c = m a -> m b -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
MC.finally m a
m m b
c
    throwExc :: forall a. ATGException -> m a
throwExc ATGException
t = ATGException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
MC.throwM ATGException
t

-------------
-- Display --
-------------

instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadDisplay m where
    setupDisplay :: m ()
setupDisplay = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO IO ()
initPart
    clearDisplay :: m ()
clearDisplay = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO IO ()
clearScreen
    displaySize :: m (Maybe Dimensions)
displaySize = IO (Maybe Dimensions) -> m (Maybe Dimensions)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO IO (Maybe Dimensions)
displaySizeIO
    blitPlane :: Maybe Plane -> Plane -> m ()
blitPlane Maybe Plane
mp Plane
p = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (Maybe Plane -> Plane -> IO ()
blitPlaneIO Maybe Plane
mp Plane
p)
    shutdownDisplay :: m ()
shutdownDisplay = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO IO ()
cleanAndExit

displaySizeIO :: IO (Maybe Dimensions)
displaySizeIO :: IO (Maybe Dimensions)
displaySizeIO =
        IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
TS.size        IO (Maybe (Window Int))
-> (Maybe (Window Int) -> IO (Maybe Dimensions))
-> IO (Maybe Dimensions)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe (Window Int)
ts ->
            -- cannot use ansi-terminal, on Windows you get
            -- "ConsoleException 87" (too much scrolling)
            -- and it does not work for mintty and it is
            -- inefficient as it gets (attempts to scroll past
            -- bottom right)
        IO Bool
isWin32Console IO Bool -> (Bool -> IO (Maybe Dimensions)) -> IO (Maybe Dimensions)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
bw ->
            -- cmd.exe is present on Win10 `C:\Windows\system32\cmd.exe`
            -- — and default — too. So this is needed for the foreseeable
            -- future.

        Maybe Dimensions -> IO (Maybe Dimensions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Window Int -> Dimensions)
-> Maybe (Window Int) -> Maybe Dimensions
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Window Int -> Dimensions
f Bool
bw) Maybe (Window Int)
ts)
    where
          f :: Bool -> TS.Window Int -> Dimensions
          f :: Bool -> Window Int -> Dimensions
f Bool
wbw (TS.Window Int
h Int
w) =
                let h' :: Int
h' | Bool
wbw       = Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                       | Bool
otherwise = Int
h
                in (Int
w, Int
h')

-- pn: new plane, po: old plane
-- wo, ho: dimensions of the terminal. If they change, reinit double buffering
blitPlaneIO :: Maybe Plane -> Plane -> IO ()
blitPlaneIO :: Maybe Plane -> Plane -> IO ()
blitPlaneIO Maybe Plane
mpo Plane
pn =

        -- remember that Nothing will be passed:
        -- - at the beginning of the game (first blit)
        -- - when resolution changes (see gameLoop)
        -- so do not duplicate hasResChanged checks here!

        -- old plane
        let
            (Int
pw, Int
ph) = Plane -> Dimensions
planeSize Plane
pn
            bp :: Plane
bp  = Int -> Int -> Plane
blankPlane Int
pw Int
ph
            po :: Plane
po  = Plane -> Plane -> Dimensions -> Plane
pastePlane (Plane -> (Plane -> Plane) -> Maybe Plane -> Plane
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Plane
bp Plane -> Plane
forall a. a -> a
id Maybe Plane
mpo) Plane
bp (Int
1, Int
1)
        in

        -- new plane
        let pn' :: Plane
pn'  = Plane -> Plane -> Dimensions -> Plane
pastePlane Plane
pn Plane
bp (Int
1, Int
1)
        in

            -- trimming is foundamental, as blitMap could otherwise print
            -- outside terminal boundaries and scroll to its death
            -- (error 87 on Win32 console).

        [SGR] -> IO ()
CA.setSGR [SGR
CA.Reset] IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        Plane -> Plane -> IO ()
blitMap Plane
po Plane
pn'


-----------------
-- ANCILLARIES --
-----------------

initPart :: IO ()
initPart :: IO ()
initPart = -- check thread support
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
CM.unless Bool
CC.rtsSupportsBoundThreads
                     ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
errMes)             IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

           -- initial setup/checks
           IO ()
CA.hideCursor IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
           Handle -> IO Bool
CA.hNowSupportsANSI Handle
GH.stdout IO Bool -> IO TextEncoding -> IO TextEncoding
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
             -- On Windows, tries to turn ANSI control
             -- characters support on.

           -- text encoding
           [Char] -> IO TextEncoding
SI.mkTextEncoding [Char]
"UTF-8//TRANSLIT" IO TextEncoding -> (TextEncoding -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
te ->
           Handle -> TextEncoding -> IO ()
SI.hSetEncoding Handle
SI.stdout TextEncoding
te        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>

           IO ()
clearScreen
    where
          errMes :: [Char]
errMes = [[Char]] -> [Char]
unlines
            [[Char]
"\nError: you *must* compile this program with -threaded!",
             [Char]
"Just add",
             [Char]
"",
             [Char]
"    ghc-options:      -threaded",
             [Char]
"",
             [Char]
"in your .cabal file (executable section) and you will be fine!"]

-- clears screen
clearScreen :: IO ()
clearScreen :: IO ()
clearScreen = Int -> Int -> IO ()
CA.setCursorPosition Int
0 Int
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              [SGR] -> IO ()
CA.setSGR [SGR
CA.Reset]     IO () -> IO Dimensions -> IO Dimensions
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              IO Dimensions
forall (m :: * -> *).
(MonadDisplay m, MonadException m) =>
m Dimensions
displaySizeErr           IO Dimensions -> (Dimensions -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int
w, Int
h) ->
              Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
CM.replicateM_ (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
h) (Char -> IO ()
putChar Char
' ')

cleanAndExit :: IO ()
cleanAndExit :: IO ()
cleanAndExit = [SGR] -> IO ()
CA.setSGR [SGR
CA.Reset]     IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               IO ()
CA.clearScreen           IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               Int -> Int -> IO ()
CA.setCursorPosition Int
0 Int
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               IO ()
CA.showCursor

-- plane
blitMap :: Plane -> Plane -> IO ()
blitMap :: Plane -> Plane -> IO ()
blitMap Plane
po Plane
pn =
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
CM.when (Plane -> Dimensions
planeSize Plane
po Dimensions -> Dimensions -> Bool
forall a. Eq a => a -> a -> Bool
/= Plane -> Dimensions
planeSize Plane
pn)
                    ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"blitMap: different plane sizes")      IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            Int -> Int -> IO ()
CA.setCursorPosition Int
0 Int
0                              IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                -- setCursorPosition is *zero* based!
            Dimensions -> [[Cell]] -> [[Cell]] -> IO ()
blitToTerminal (Int
0, Int
0) (Plane -> [[Cell]]
orderedCells Plane
po) (Plane -> [[Cell]]
orderedCells Plane
pn)

orderedCells :: Plane -> [[Cell]]
orderedCells :: Plane -> [[Cell]]
orderedCells Plane
p = Int -> [Cell] -> [[Cell]]
forall e. Int -> [e] -> [[e]]
LS.chunksOf (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) [Cell]
cells
    where
          cells :: [Cell]
cells  = ((Dimensions, Cell) -> Cell) -> [(Dimensions, Cell)] -> [Cell]
forall a b. (a -> b) -> [a] -> [b]
map (Dimensions, Cell) -> Cell
forall a b. (a, b) -> b
snd ([(Dimensions, Cell)] -> [Cell]) -> [(Dimensions, Cell)] -> [Cell]
forall a b. (a -> b) -> a -> b
$ Plane -> [(Dimensions, Cell)]
assocsPlane Plane
p
          (Int
w, Int
_) = Plane -> Dimensions
planeSize Plane
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 :: Dimensions -> [[Cell]] -> [[Cell]] -> IO ()
blitToTerminal (Int
rr, Int
rc) [[Cell]]
ocs [[Cell]]
ncs = (Int -> [(Cell, Cell)] -> IO Int)
-> Int -> [[(Cell, Cell)]] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
CM.foldM_ Int -> [(Cell, Cell)] -> IO Int
blitLine Int
rr [[(Cell, Cell)]]
oldNew
    where
          oldNew :: [[(Cell, Cell)]]
          oldNew :: [[(Cell, Cell)]]
oldNew = ([Cell] -> [Cell] -> [(Cell, Cell)])
-> [[Cell]] -> [[Cell]] -> [[(Cell, Cell)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Cell] -> [Cell] -> [(Cell, Cell)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Cell]]
ocs [[Cell]]
ncs

          -- row = previous row
          blitLine :: Row -> [(Cell, Cell)] -> IO Row
          blitLine :: Int -> [(Cell, Cell)] -> IO Int
blitLine Int
pr [(Cell, Cell)]
ccs =
                (Int -> (Cell, Cell) -> IO Int) -> Int -> [(Cell, Cell)] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
CM.foldM_ Int -> (Cell, Cell) -> IO Int
blitCell Int
0 [(Cell, Cell)]
ccs               IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                -- 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 :: Int
wr = Int
pr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in
                Int -> Int -> IO ()
CA.setCursorPosition (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wr)
                                     (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rc) IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
wr

          -- k is "spaces to skip"
          blitCell :: Int -> (Cell, Cell) -> IO Int
          blitCell :: Int -> (Cell, Cell) -> IO Int
blitCell Int
k (Cell
clo, Cell
cln)
                | Cell
cln Cell -> Cell -> Bool
forall a. Eq a => a -> a -> Bool
== Cell
clo = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                | Bool
otherwise  = Int -> IO Int
moveIf Int
k         IO Int -> (Int -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
k' ->
                               Cell -> IO ()
putCellStyle Cell
cln IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                               Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
k'

          moveIf :: Int -> IO Int
          moveIf :: Int -> IO Int
moveIf Int
k | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
k
                   | Bool
otherwise = Int -> IO ()
CA.cursorForward Int
k IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                 Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

putCellStyle :: Cell -> IO ()
putCellStyle :: Cell -> IO ()
putCellStyle Cell
c = [SGR] -> IO ()
CA.setSGR ([SGR
CA.Reset] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++ [SGR]
sgrb [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++ [SGR]
sgrr [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++ [SGR]
sgrc) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 Char -> IO ()
putChar (Cell -> Char
cellChar Cell
c)
    where
          sgrb :: [SGR]
sgrb | Cell -> Bool
isBold Cell
c  = [ConsoleIntensity -> SGR
CA.SetConsoleIntensity ConsoleIntensity
CA.BoldIntensity]
               | Bool
otherwise = []

          sgrr :: [SGR]
sgrr | Cell -> Bool
isReversed Cell
c = [Bool -> SGR
CA.SetSwapForegroundBackground Bool
True]
               | Bool
otherwise    = []

          sgrc :: [SGR]
sgrc | Just (ANSIColorInfo (Color
k, ColorIntensity
i)) <- Cell -> Maybe ColorInfo
cellColor Cell
c = [ConsoleLayer -> ColorIntensity -> Color -> SGR
CA.SetColor ConsoleLayer
CA.Foreground ColorIntensity
i Color
k]
               | Just (RGBColorInfo Colour Float
k)       <- Cell -> Maybe ColorInfo
cellColor Cell
c = [ConsoleLayer -> Colour Float -> SGR
CA.SetRGBColor ConsoleLayer
CA.Foreground Colour Float
k]
               | Just (PaletteColorInfo Word8
k)   <- Cell -> Maybe ColorInfo
cellColor Cell
c = [ConsoleLayer -> Word8 -> SGR
CA.SetPaletteColor ConsoleLayer
CA.Foreground Word8
k]
               | Bool
otherwise                                  = []

oneTickSec :: Integer
oneTickSec :: Integer
oneTickSec = Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
6 :: Integer)