{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module UI.Game
  ( playGame
  ) where

import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically)
import Control.Monad (void, forever)
import Prelude hiding (Left, Right)

import Brick hiding (Down)
import Brick.BChan
import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Border.Style as BS
import qualified Brick.Widgets.Center as C
import Control.Lens hiding (preview, op, zoom)
import Control.Monad.Extra (orM, unlessM)
import Control.Monad.IO.Class (liftIO)
import qualified Graphics.Vty as V
import qualified Graphics.Vty.CrossPlatform
import qualified Graphics.Vty.Config
import Data.Map (Map)
import qualified Data.Map as M
import Linear.V2 (V2(..))

import Tetris

data UI = UI
  { _game      :: Game
  , _initLevel :: Int
  , _currLevel :: TVar Int
  , _preview   :: Maybe String
  , _locked    :: Bool
  , _paused    :: Bool
  }

makeLenses ''UI

-- | Ticks mark passing of time
data Tick = Tick

-- | Named resources
type Name = ()

data VisualBlock
  = NormalBlock
  | HardDropBlock String

-- App definition and execution

app :: App UI Tick Name
app = App
  { appDraw         = drawUI
  , appChooseCursor = neverShowCursor
  , appHandleEvent  = handleEvent
  , appStartEvent   = pure ()
  , appAttrMap      = const theMap
  }

playGame :: Int          -- ^ Starting level
          -> Maybe String  -- ^ Preview cell (Nothing == no preview)
          -> Bool         -- ^ Enable level progression
          -> IO Game
playGame lvl mp prog = do
  chan <- newBChan 10
  tv <- newTVarIO lvl
  void . forkIO $ forever $ do
    writeBChan chan Tick
    lvl <- readTVarIO tv
    threadDelay $ levelToDelay lvl
  initialGame <- initGame lvl prog  -- Pass the progression parameter
  let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig
  initialVty <- buildVty
  ui <- customMain initialVty buildVty (Just chan) app $ UI
    { _game      = initialGame
    , _initLevel = lvl
    , _currLevel = tv
    , _preview   = mp
    , _locked    = False
    , _paused    = False
    }
  return $ ui ^. game

levelToDelay :: Int -> Int
levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)

-- Handling events

handleEvent :: BrickEvent Name Tick -> EventM Name UI ()
handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
handleEvent (VtyEvent (V.EvKey V.KEsc        [])) = halt
handleEvent (VtyEvent (V.EvKey V.KRight      [])) = exec (shift Right)
handleEvent (VtyEvent (V.EvKey V.KLeft       [])) = exec (shift Left)
handleEvent (VtyEvent (V.EvKey V.KDown       [])) = exec (shift Down)
handleEvent (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right)
handleEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left)
handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down)
handleEvent (VtyEvent (V.EvKey V.KUp         [])) = exec rotate
handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate
handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) =
  unlessM (orM [use paused, use (game . to isGameOver)]) $ do
    zoom game hardDrop
    assign locked True
handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
  unlessM (orM [use locked, use (game . to isGameOver)]) $ do
    modifying paused not
handleEvent (AppEvent Tick                      ) =
  unlessM (orM [use paused, use (game . to isGameOver)]) $ do
    zoom game timeStep
    -- Keep level in sync with ticker (gross)
    lvl <- use $ game . level
    tv <- use $ currLevel
    liftIO . atomically $ writeTVar tv lvl
    assign locked False
handleEvent _ = pure ()

-- | This common execution function is used for all game user input except hard
-- drop and pause. If paused or locked (from hard drop) do nothing, else
-- execute the state computation.
exec :: Tetris () -> EventM Name UI ()
exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game

-- | Restart game at the initially chosen level
restart :: EventM Name UI ()
restart = do
  lvl <- use initLevel
  prog <- use (game . progression)  -- Get current progression setting
  g <- liftIO $ initGame lvl prog   -- Use it when restarting
  assign game g
  assign locked False

-- Drawing

drawUI :: UI -> [Widget Name]
drawUI ui =
  [ C.vCenter $ vLimit 22 $ hBox
      [ padLeft Max $ padRight (Pad 2) $ drawStats (ui ^. game)
      , drawGrid ui
      , padRight Max $ padLeft (Pad 2) $ drawInfo (ui ^. game)
      ]
  ]

drawGrid :: UI -> Widget Name
drawGrid ui =
  hLimit 22
    $ withBorderStyle BS.unicodeBold
    $ B.borderWithLabel (str "Tetris")
    $ case ui ^. paused of
        True  -> C.center $ str "Paused"
        False -> vBox $ [boardHeight, boardHeight - 1 .. 1] <&> \r ->
          foldr (<+>) emptyWidget
            . M.filterWithKey (\(V2 _ y) _ -> r == y)
            $ mconcat
                [ drawBlockCell NormalBlock <$> ui ^. (game . board)
                , blockMap NormalBlock (ui ^. (game . block))
                , case ui ^. preview of
                    Nothing -> M.empty
                    Just s  -> blockMap (HardDropBlock s) (evalTetris hardDroppedBlock (ui ^. game))
                , emptyCellMap
                ]
 where
  blockMap v b =
    M.fromList $ [ (c, drawBlockCell v (b ^. shape)) | c <- coords b ]

emptyCellMap :: Map Coord (Widget Name)
emptyCellMap = M.fromList
  [ (V2 x y, emptyGridCellW) | x <- [1 .. boardWidth], y <- [1 .. boardHeight] ]

emptyGridCellW :: Widget Name
emptyGridCellW = withAttr emptyAttr cw

emptyNextShapeCellW :: Widget Name
emptyNextShapeCellW = withAttr emptyAttr ecw

drawBlockCell :: VisualBlock -> Tetrimino -> Widget Name
drawBlockCell NormalBlock       t = withAttr (tToAttr t) cw
drawBlockCell (HardDropBlock s) t = withAttr (tToAttrH t) (str s)

tToAttr :: Tetrimino -> AttrName
tToAttr I = iAttr
tToAttr O = oAttr
tToAttr T = tAttr
tToAttr S = sAttr
tToAttr Z = zAttr
tToAttr J = jAttr
tToAttr L = lAttr

tToAttrH :: Tetrimino -> AttrName
tToAttrH I = ihAttr
tToAttrH O = ohAttr
tToAttrH T = thAttr
tToAttrH S = shAttr
tToAttrH Z = zhAttr
tToAttrH J = jhAttr
tToAttrH L = lhAttr

cw :: Widget Name
cw = str " ."

ecw :: Widget Name
ecw = str "  "

drawStats :: Game -> Widget Name
drawStats g =
  hLimit 22
    $ withBorderStyle BS.unicodeBold
    $ B.borderWithLabel (str "Stats")
    $ vBox
        [ drawStat "Score" $ g ^. score
        , padTop (Pad 1) $ drawStat "Lines" $ g ^. linesCleared
        , padTop (Pad 1) $ drawStat "Level" $ g ^. level
        , padTop (Pad 1) $ drawProgression (g ^. progression)
        , drawLeaderBoard g
        ]

drawProgression :: Bool -> Widget Name
drawProgression True =
    padLeftRight 1 $ str "Level Mode: " <+>
    withAttr progressionAttr (padLeft Max $ str "ON")
drawProgression False =
    padLeftRight 1 $ str "Level Mode: " <+>
    withAttr fixedAttr (padLeft Max $ str "Fixed")

drawStat :: String -> Int -> Widget Name
drawStat s n = padLeftRight 1 $ str s <+> padLeft Max (str $ show n)

drawLeaderBoard :: Game -> Widget Name
drawLeaderBoard _ = emptyWidget

drawInfo :: Game -> Widget Name
drawInfo g = hLimit 18 -- size of next piece box
  $ vBox
    [ drawNextShape (g ^. nextShape)
    , padTop (Pad 1) drawHelp
    , padTop (Pad 1) (drawGameOver g)
    ]

drawNextShape :: Tetrimino -> Widget Name
drawNextShape t =
  withBorderStyle BS.unicodeBold
    $ B.borderWithLabel (str "Next")
    $ padTopBottom 1
    $ padLeftRight 4
    $ vLimit 4
    $ vBox
    $ [0, -1] <&> \y ->
      hBox [ if V2 x y `elem` coords blk
             then drawBlockCell NormalBlock t
             else emptyNextShapeCellW
           | x <- [-2 .. 1]
           ]
  where blk = Block t (V2 0 0) (relCells t)

drawHelp :: Widget Name
drawHelp =
  withBorderStyle BS.unicodeBold
    $ B.borderWithLabel (str "Help")
    $ padTopBottom 1
    $ vBox
    $ map (uncurry drawKeyInfo)
      [ ("Left"   , "h, ←")
      , ("Right"  , "l, →")
      , ("Down"   , "j, ↓")
      , ("Rotate" , "k, ↑")
      , ("Drop"   , "space")
      , ("Restart", "r")
      , ("Pause"  , "p")
      , ("Quit"   , "q")
      ]

drawKeyInfo :: String -> String -> Widget Name
drawKeyInfo action keys =
  padRight Max (padLeft (Pad 1) $ str action)
    <+> padLeft Max (padRight (Pad 1) $ str keys)

drawGameOver :: Game -> Widget Name
drawGameOver g =
  if isGameOver g
  then padLeftRight 4 $ withAttr gameOverAttr $ str "GAME OVER"
  else emptyWidget

theMap :: AttrMap
theMap = attrMap
  V.defAttr
  [ (iAttr          , tToColor I `on` tToColor I)
  , (oAttr          , tToColor O `on` tToColor O)
  , (tAttr          , tToColor T `on` tToColor T)
  , (sAttr          , tToColor S `on` tToColor S)
  , (zAttr          , tToColor Z `on` tToColor Z)
  , (jAttr          , tToColor J `on` tToColor J)
  , (lAttr          , tToColor L `on` tToColor L)
  , (ihAttr         , fg $ tToColor I)
  , (ohAttr         , fg $ tToColor O)
  , (thAttr         , fg $ tToColor T)
  , (shAttr         , fg $ tToColor S)
  , (zhAttr         , fg $ tToColor Z)
  , (jhAttr         , fg $ tToColor J)
  , (lhAttr         , fg $ tToColor L)
  , (gameOverAttr   , fg V.red `V.withStyle` V.bold)
  , (progressionAttr, fg V.green `V.withStyle` V.bold)
  , (fixedAttr      , fg V.blue `V.withStyle` V.bold)
  ]

tToColor :: Tetrimino -> V.Color
tToColor I = V.cyan
tToColor O = V.yellow
tToColor T = V.magenta
tToColor S = V.green
tToColor Z = V.red
tToColor J = V.blue
tToColor L = V.white

iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName
iAttr = attrName "I"
oAttr = attrName "O"
tAttr = attrName "T"
sAttr = attrName "S"
zAttr = attrName "Z"
jAttr = attrName "J"
lAttr = attrName "L"

ihAttr, ohAttr, thAttr, shAttr, zhAttr, jhAttr, lhAttr :: AttrName
ihAttr = attrName "Ih"
ohAttr = attrName "Oh"
thAttr = attrName "Th"
shAttr = attrName "Sh"
zhAttr = attrName "Zh"
jhAttr = attrName "Jh"
lhAttr = attrName "Lh"

emptyAttr :: AttrName
emptyAttr = attrName "empty"

gameOverAttr :: AttrName
gameOverAttr = attrName "gameOver"

progressionAttr, fixedAttr :: AttrName
progressionAttr = attrName "progression"
fixedAttr = attrName "fixed"