-------------------------------------------------------------------------------
-- 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) =>
          MonadException m where
    cleanUpErr m c = MC.finally m c


-----------
-- 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 (Integer, Integer)
displaySizeIO =
        TS.size        >>= \ts ->
            -- cannot use ansi-terminal, on Windows you get
            -- "ConsoleException 87" (too much scrolling)
        isWin32Console >>= \bw ->
        let (TS.Window h w) = maybe (error "cannot get TERM size") id ts
            h' | bw        = h - 1
               | otherwise = h
               -- win32 console has 1 less row available than displayes
               -- (it will scroll and make a mess otherwise)
        in return (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 (executale section) and you will be fine!"]

-- clears screen
clearScreen :: IO ()
clearScreen = CA.setCursorPosition 0 0 >>
              CA.setSGR [CA.Reset]     >>
              displaySizeIO            >>= \(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)