module Main where

import Control.DeepSeq
import GHC.Generics

import Control.Monad (join)
import Control.Monad.Catch (catch)
import Control.Monad.IO.Class
import Data.Int
import Data.Maybe (fromMaybe)
import Data.Proxy

import Control.Wire
import Prelude hiding ((.), id)

import Game.GoreAndAsh
import Game.GoreAndAsh.LambdaCube
import Game.GoreAndAsh.GLFW

import Core
import Matrix

import qualified Graphics.UI.GLFW as GLFW
import qualified Data.Map as Map
import qualified Data.Vector as V

import Codec.Picture as Juicy
import LambdaCube.GL as LambdaCubeGL -- renderer
import LambdaCube.GL.Mesh as LambdaCubeGL

mainPipeline :: PipelineId
mainPipeline = "mainPipeline"

main :: IO ()
main = withModule (Proxy :: Proxy AppMonad) $ do
  gs <- newGameState mainWire
  firstLoop gs `catch` errorExit
  where
    firstLoop gs = do
      (_, gs') <- stepGame gs $ do
        win <- liftIO $ initWindow "Gore&Ash LambdaCube Example 04" 640 640
        setCurrentWindowM $ Just win
        lambdacubeAddPipeline [".", "../shared"] "example04.lc" mainPipeline $ do
          defObjectArray "objects" Triangles $ do
            "position"  @: Attribute_V3F
            "normal"    @: Attribute_V3F
            "uv"        @: Attribute_V2F
          defUniforms $ do
            "modelMat"       @: M44F
            "viewMat"        @: M44F
            "projMat"        @: M44F
            "depthMVP"       @: M44F
            "diffuseTexture" @: FTexture2D
            "lightDir"       @: V3F
            "windowWidth"    @: Int
            "windowHeight"   @: Int

        return ()
      gameLoop gs'

    errorExit e = do
      liftIO $ case e of
        PipeLineCompileFailed _ _ msg -> putStrLn msg
        PipeLineAlreadyRegistered i -> putStrLn $ "Pipeline already registered: " ++ show i
        PipeLineNotFound i -> putStrLn $ "Pipeline is not found: " ++ show i
        StorageNotFound i -> putStrLn $ "Storage is not found: " ++ show i
        PipeLineIncompatible _ msg -> putStrLn $ "Pipeline incompatible: " ++ msg
      fail "terminate: fatal error"

    gameLoop gs = do
      (mg, gs') <- stepGame gs (return ())
      mg `deepseq` if fromMaybe False $ gameExit <$> join mg
        then cleanupGameState gs'
        else gameLoop gs'

initWindow :: String -> Int -> Int -> IO GLFW.Window
initWindow title width height = do
    _ <- GLFW.init
    GLFW.defaultWindowHints
    mapM_ GLFW.windowHint
      [ GLFW.WindowHint'ContextVersionMajor 3
      , GLFW.WindowHint'ContextVersionMinor 3
      , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
      , GLFW.WindowHint'OpenGLForwardCompat True
      ]
    Just win <- GLFW.createWindow width height title Nothing Nothing
    GLFW.makeContextCurrent $ Just win
    return win

data Game = Game {
    gameExit :: Bool
  }
  deriving (Generic)

instance NFData Game

mainWire :: AppWire a (Maybe Game)
mainWire = withInit (const initStorage) (uncurry renderWire)

-- | Initalizes storage and then switches to rendering state
initStorage :: GameMonadT AppMonad (GLStorage, GPUMesh)
initStorage = do
  (sid, storage) <- lambdacubeCreateStorage mainPipeline
  gpuMesh <- liftIO $ LambdaCubeGL.uploadMeshToGPU cubeMesh
  lambdacubeRenderStorageFirst sid
  return (storage, gpuMesh)

-- | Infinitely render given storage
renderWire :: GLStorage -> GPUMesh -> AppWire a (Maybe Game)
renderWire storage gpuMesh = (<|> pure Nothing) $ proc _ -> do
  w <- nothingInhibit . liftGameMonad getCurrentWindowM -< ()
  closed <- isWindowClosed -< ()
  (aspect, width, height) <- updateWinSize -< w
  t <- timeF -< ()
  globalUniforms -< (aspect, t, width, height)
  cube storage gpuMesh -< ()
  wall storage gpuMesh -< ()
  glfwFinishFrame -< w
  returnA -< Just $ Game closed
  where
  -- | Outputs True if user hits close button
  isWindowClosed :: AppWire a Bool
  isWindowClosed = hold . mapE (const True) . windowClosing <|> pure False

  -- | Updates LambdaCube window size
  updateWinSize :: AppWire GLFW.Window (Float, Int32, Int32)
  updateWinSize = liftGameMonad1 $ \win -> do
    (w, h) <- liftIO $ GLFW.getWindowSize win
    lambdacubeUpdateSize (fromIntegral w) (fromIntegral h)
    return (fromIntegral w / fromIntegral h, fromIntegral w, fromIntegral h)

  -- | Updates storage uniforms
  globalUniforms :: AppWire (Float, Float, Int32, Int32) ()
  globalUniforms = liftGameMonad1 $ \(aspect, t, w, h) -> liftIO $
    LambdaCubeGL.updateUniforms storage $ do
      "viewMat" @= return (cameraMatrix t)
      "projMat" @= return (projMatrix aspect)
      "lightDir" @= return lightDirection
      "windowWidth" @= return w
      "windowHeight" @= return h

  -- | Swaps frame
  glfwFinishFrame :: AppWire GLFW.Window ()
  glfwFinishFrame = liftGameMonad1 $ liftIO . GLFW.swapBuffers

-- | Intializes and renders cube
cube :: GLStorage -> GPUMesh -> AppWire a ()
cube storage gpuMesh = withInit (const initCube) (uncurry renderCube)
  where
  initCube :: GameMonadT AppMonad (Object, TextureData)
  initCube = do
    -- upload geometry to GPU and add to pipeline input
    obj <- liftIO $
      LambdaCubeGL.addMeshToObjectArray storage "objects" ["modelMat", "diffuseTexture", "depthMVP"] gpuMesh

    -- load image and upload texture
    texLogoData <- liftIO $ do
      Right img <- Juicy.readImage "../shared/logo.png"
      LambdaCubeGL.uploadTexture2DToGPU img

    return (obj, texLogoData)

  -- | Update object specific uniforms
  renderCube :: Object -> TextureData -> AppWire a ()
  renderCube obj textureData = (timeF >>>) $ liftGameMonad1 $ \t -> liftIO $ do
    let setter = LambdaCubeGL.objectUniformSetter obj
    uniformM44F "modelMat" setter $ modelMatrixCube t
    uniformM44F "depthMVP" setter $ depthMVPCube t
    uniformFTexture2D "diffuseTexture" setter textureData

-- | Initializes and renders wall
wall :: GLStorage -> GPUMesh -> AppWire a ()
wall storage gpuMesh = withInit (const initWall) (uncurry renderWall)
  where
  initWall :: GameMonadT AppMonad (Object, TextureData)
  initWall = do
    -- upload geometry to GPU and add to pipeline input
    obj <- liftIO $
      LambdaCubeGL.addMeshToObjectArray storage "objects" ["modelMat", "diffuseTexture", "depthMVP"] gpuMesh

    -- load image and upload texture
    texLogoData <- liftIO $ do
      Right img <- Juicy.readImage "../shared/brick.jpg"
      LambdaCubeGL.uploadTexture2DToGPU img

    return (obj, texLogoData)

  -- | Update object specific uniforms
  renderWall :: Object -> TextureData -> AppWire a ()
  renderWall obj textureData = liftGameMonad . liftIO $ do
    let setter = LambdaCubeGL.objectUniformSetter obj
    uniformM44F "modelMat" setter modelMatrixWall
    uniformM44F "depthMVP" setter depthMVPWall
    uniformFTexture2D "diffuseTexture" setter textureData

-- geometry data: triangles
cubeMesh :: LambdaCubeGL.Mesh
cubeMesh = Mesh
  { mAttributes   = Map.fromList
      [ ("position",  A_V3F $ V.fromList vertecies)
      , ("normal",    A_V3F $ V.fromList normals)
      , ("uv",        A_V2F $ V.fromList uvs)
      ]
  , mPrimitive    = P_Triangles
  }
  where
  vertecies = [
      v3, v2, v1, v3, v1, v0
    , v4, v7, v6, v4, v6, v5
    , v0, v1, v7, v0, v7, v4
    , v5, v6, v2, v5, v2, v3
    , v2, v6, v7, v2, v7, v1
    , v5, v3, v0, v5, v0, v4
    ]
  normals = concat [
      replicate 6 n0
    , replicate 6 n1
    , replicate 6 n2
    , replicate 6 n3
    , replicate 6 n4
    , replicate 6 n5
    ]
  uvs = concat $ replicate 6 [u1, u2, u3, u1, u3, u0]

  v0 = V3 (-1) (-1) (-1)
  v1 = V3 (-1)   1  (-1)
  v2 = V3   1    1  (-1)
  v3 = V3   1  (-1) (-1)
  v4 = V3 (-1) (-1)   1
  v5 = V3   1  (-1)   1
  v6 = V3   1    1    1
  v7 = V3 (-1)   1    1

  n0 = V3   0    0  (-1)
  n1 = V3   0    0    1
  n2 = V3 (-1)   0    0
  n3 = V3   1    0    0
  n4 = V3   0    1    0
  n5 = V3   0  (-1)   0

  u0 = V2 0 0
  u1 = V2 1 0
  u2 = V2 1 1
  u3 = V2 0 1