-------------------------------------------------------------------------------
-- 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 = -- non buffered input
                   SI.hSetBuffering SI.stdin
                                    SI.NoBuffering >>

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