{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
module Main where

import Data.Functor.Compose
import Control.Comonad.UI

import Control.Comonad.Env
import qualified SDL.Framerate as Framerate
import Data.Word
import Data.Functor.Combine
import Data.Semigroup
import Data.Foldable
import Control.Comonad.Store
import Data.Functor.Apply
import Foreign.C.Types
import Control.Comonad.Traced hiding ((<>))
import Control.Lens
import Control.Lens.Internal.Zoom
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Monad.Writer hiding ((<>))
import Data.Colour
import Data.Colour.Names
import qualified Data.Map as M
import Data.Maybe
import Linear
import qualified SDL
import qualified SDL.Primitive as SDL
import Data.Functor.Pair

newtype SDLImage = SDLImage
    { runSDLImage :: SDL.Renderer -> IO ()
    } deriving (Monoid,Semigroup)

type SDLUI m e = UI m e SDLImage

data GameEvent = SDLEvent SDL.Event | Tick
  deriving (Eq,Show)
makePrisms ''GameEvent

runSDLUI ::
       (Comonad w, Pairing w m)
    => (w (SDLUI m GameEvent) -> Bool)
    -> w (SDLUI m GameEvent)
    -> IO ()
runSDLUI stop start =
    Framerate.with 60 $ \manager -> do
        SDL.initializeAll
        window <- SDL.createWindow "floatMe" SDL.defaultWindow
        renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
        let draw (SDLImage f) = do
                SDL.rendererDrawColor renderer SDL.$=
                    V4 0 0 (maxBound :: Word8) maxBound
                SDL.clear renderer
                f renderer
                SDL.present renderer
        runUI
            (Framerate.delay_ manager >>
             (\es -> Tick : map SDLEvent es) <$> SDL.pollEvents)
            draw
            stop
            start


data GameGrid a = GameGrid
  { _gridSize :: V2 Int
  , _gridItems :: M.Map (V2 Int) a
  } deriving (Functor,Eq,Show)
makeLenses ''GameGrid


data RotationDirection = Clockwise | AntiClockwise
  deriving (Eq,Show)

rotationMatrix :: RotationDirection -> V2 (V2 Int)
rotationMatrix Clockwise = V2 (V2 0 1) (V2 (-1) 0)
rotationMatrix AntiClockwise = V2 (V2 0 (-1)) (V2 1 0)

data Tetromino = Tetromino
    { _centerPeice :: V2 Int
    , _firstPeice :: V2 Int
    , _secondPeice :: V2 Int
    , _thirdPeice :: V2 Int
    , _tetrominoColour :: Colour Double
    , _tetrominoOffset :: V2 Int
    } deriving (Eq, Show)
makeLenses ''Tetromino

data Tile = NoTile | Tile (Colour Double)
  deriving (Eq,Show)
makePrisms ''Tile

atGrid :: V2 Int -> Lens' (GameGrid Tile) Tile
atGrid p = gridItems . at p . non NoTile

rotateTetromino :: RotationDirection -> Tetromino -> Tetromino
rotateTetromino rd t =
    let m = rotationMatrix rd
    in t & firstPeice %~ (m !*) & secondPeice %~ (m !*) & thirdPeice %~ (m !*)

placeTetromino :: MonadState (GameGrid Tile) m => Tetromino -> m Bool
placeTetromino t =
    let p1 = t ^. centerPeice + t ^. tetrominoOffset
        p2 = t ^. firstPeice + t ^. tetrominoOffset
        p3 = t ^. secondPeice + t ^. tetrominoOffset
        p4 = t ^. thirdPeice + t ^. tetrominoOffset
        c = t ^. tetrominoColour
    in fmap (maybe False (const True)) $ runMaybeT $ do
           forM_ [p1, p2, p3, p4] $ \p -> use (atGrid p) >>= guard . (== NoTile)
           forM_ [p1, p2, p3, p4] $ \p -> gridItems . at p .= Just (Tile c)

removeRow :: MonadState (GameGrid Tile) m => Int -> m Bool
removeRow n = do
    nA <- use (gridSize . _x)
    canRemove <-
        or <$>
        (forM
             [V2 n y | y <- [0 .. nA - 1]]
             (\p -> gets (has (gridItems . ix p . _Tile))))
    when canRemove $
        forM_ [V2 n y | y <- [0 .. nA - 1]] (\p -> gridItems . ix p .= NoTile)
    return canRemove

data GameAction
    = AdvanceTime
    | MoveLeft
    | MoveRight
    | Rotate RotationDirection
    | PlaceTetromino
    deriving (Eq, Show)

gameActionInputs  :: GameEvent -> GameAction
gameActionInputs Tick = AdvanceTime

data GameState = GameState
    { _currentTetromino :: Tetromino
    , _gameGrid :: GameGrid Tile
    , _gameScore :: Int
    } deriving (Eq,Show)
makeLenses ''GameState

updateGameState :: GameAction -> State GameState ()
updateGameState AdvanceTime = do
    numRows <- use (gameGrid . gridSize . _y)
    scoreToAdd <- zoom gameGrid (length . filter id <$> mapM removeRow [0 .. numRows - 1])
    gameScore += scoreToAdd
updateGameState MoveLeft = currentTetromino . tetrominoOffset . _x -= 1
updateGameState MoveRight = currentTetromino . tetrominoOffset . _x += 1
updateGameState (Rotate dir) = currentTetromino %= rotateTetromino dir
updateGameState PlaceTetromino = do
  tetr <- use currentTetromino
  zoom gameGrid $ placeTetromino tetr 
  -- This is instead of reseting
  currentTetromino . tetrominoOffset . _y .= 0

tileUI :: (Monad m) => V2 CInt -> Tile -> SDLUI m e
tileUI offset NoTile = mempty
tileUI offset (Tile col) =
    UI (SDLImage $ \r ->
            SDL.fillRectangle
                r
                (offset + V2 (-16) (-16))
                (offset + V2 16 16)
                (V4 maxBound maxBound 0 maxBound))
        (const $ return ())

gridUI :: Monad m => GameGrid Tile -> SDLUI m e
gridUI s = tiles
  where
    tiles =
        foldMap
            (\c ->
                 tileUI ((16 *) . fromIntegral <$> c) $
                 fromJust (s ^? gridItems . ix c))
            allCoords
    allCoords =
        [ V2 x y
        | x <- [0 .. s ^. gridSize . _x - 1]
        , y <- [0 .. s ^. gridSize . _y - 1]
        ]

gameUI :: GameState -> SDLUI (StateT GameState Identity) GameAction
gameUI gs =
    gridUI (gs ^. gameGrid) <> UI mempty updateGameState <>
    tetrominoUI (gs ^. currentTetromino)
  where
    tetrominoUI tr =
        foldMap
            (\c ->
                 tileUI
                     (((16 *) . fromIntegral) <$> (c + tr ^. tetrominoOffset))
                     (Tile (tr ^. tetrominoColour)))
            [ tr ^. centerPeice
            , tr ^. firstPeice
            , tr ^. secondPeice
            , tr ^. thirdPeice
            ]

totalUI ::
       GameState
    -> Store (GameState, Bool) (SDLUI (State (GameState, Bool)) GameAction)
totalUI startState =
    store gameUI startState `combineUI`
    store (\_ -> mempty :: SDLUI (State Bool) GameAction) False

main = runSDLUI (snd . pos) (lmap gameActionInputs <$> totalUI startGameState)
  where
    startGameState =
        GameState
        { _currentTetromino =
              Tetromino
              { _centerPeice = pure 0
              , _firstPeice = V2 1 0
              , _secondPeice = V2 0 1
              , _thirdPeice = V2 1 1
              , _tetrominoColour = blue
              , _tetrominoOffset = pure 0
              }
        , _gameGrid =
              GameGrid
              { _gridSize = V2 10 20
              , _gridItems =
                    M.fromList
                        [(V2 x y, NoTile) | x <- [0 .. 9], y <- [0 .. 19]]
              }
        , _gameScore = 0
        }
