pioneers/src/Render/Render.hs

{-# LANGUAGE BangPatterns, InstanceSigs, ExistentialQuantification #-}
module Render.Render where

import qualified Data.ByteString                            as B
import           Foreign.Marshal.Array                      (withArray)
import           Foreign.Storable
import           Graphics.Rendering.OpenGL.GL
import           Graphics.Rendering.OpenGL.Raw.Core31
import           Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
import           Graphics.GLUtil.BufferObjects        (offset0)
import qualified Linear as L
import           Control.Lens                               ((^.))
import           Control.Monad.RWS.Strict             (liftIO)
import qualified Control.Monad.RWS.Strict as RWS      (get)
import           Data.Distributive                    (distribute, collect)
-- FFI
import           Foreign                              (Ptr, castPtr, with)
import           Foreign.C                            (CFloat)

import           Map.Graphics
import           Types
import           Render.Misc
import           Render.Types
import           Graphics.GLUtil.BufferObjects              (makeBuffer)
import		 Importer.IQM.Parser
import           Importer.IQM.Types

mapVertexShaderFile :: String
mapVertexShaderFile = "shaders/map/vertex.shader"
mapTessControlShaderFile :: String
mapTessControlShaderFile = "shaders/map/tessControl.shader"
mapTessEvalShaderFile :: String
mapTessEvalShaderFile = "shaders/map/tessEval.shader"
mapFragmentShaderFile :: String
mapFragmentShaderFile = "shaders/map/fragment.shader"

objectVertexShaderFile :: String
objectVertexShaderFile = "shaders/mapobjects/vertex.shader"
objectFragmentShaderFile :: String
objectFragmentShaderFile = "shaders/mapobjects/fragment.shader"

uiVertexShaderFile :: String
uiVertexShaderFile = "shaders/ui/vertex.shader"
uiFragmentShaderFile :: String
uiFragmentShaderFile = "shaders/ui/fragment.shader"

initBuffer :: [GLfloat] -> IO BufferObject
initBuffer varray =
        let
                sizeOfVarray = length varray * sizeOfComponent
                sizeOfComponent = sizeOf (head varray)
        in do
           bufferObject <- genObjectName
           bindBuffer ArrayBuffer $= Just bufferObject
           withArray varray $ \buffer ->
              bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw)
           checkError "initBuffer"
           return bufferObject

initMapShader ::
                Int                                -- ^ initial Tessallation-Factor
                -> (BufferObject,NumArrayIndices)  -- ^ Buffer with Data and DataDescriptor
                -> IO GLMapState
initMapShader tessFac (buf, vertDes) = do
   ! vertexSource <- B.readFile mapVertexShaderFile
   ! tessControlSource <- B.readFile mapTessControlShaderFile
   ! tessEvalSource <- B.readFile mapTessEvalShaderFile
   ! fragmentSource <- B.readFile mapFragmentShaderFile
   vertexShader <- compileShaderSource VertexShader vertexSource
   checkError "compile Vertex"
   tessControlShader <- compileShaderSource TessControlShader tessControlSource
   checkError "compile TessControl"
   tessEvalShader <- compileShaderSource TessEvaluationShader tessEvalSource
   checkError "compile TessEval"
   fragmentShader <- compileShaderSource FragmentShader fragmentSource
   checkError "compile Frag"
   program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader]
   checkError "compile Program"

   currentProgram $= Just program

   projectionMatrixIndex <- get (uniformLocation program "ProjectionMatrix")
   checkError "projMat"

   viewMatrixIndex <- get (uniformLocation program "ViewMatrix")
   checkError "viewMat"

   modelMatrixIndex <- get (uniformLocation program "ModelMatrix")
   checkError "modelMat"

   normalMatrixIndex <- get (uniformLocation program "NormalMatrix")
   checkError "normalMat"

   tessLevelInner <- get (uniformLocation program "TessLevelInner")
   checkError "TessLevelInner"

   tessLevelOuter <- get (uniformLocation program "TessLevelOuter")
   checkError "TessLevelOuter"


   vertexIndex <- get (attribLocation program "Position")
   vertexAttribArray vertexIndex $= Enabled
   checkError "vertexInd"

   normalIndex <- get (attribLocation program "Normal")
   vertexAttribArray normalIndex $= Enabled
   checkError "normalInd"

   colorIndex <- get (attribLocation program "Color")
   vertexAttribArray colorIndex $= Enabled
   checkError "colorInd"

   att <- get (activeAttribs program)

   putStrLn $ unlines $ "Attributes: ":map show att
   putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)]

   tex <- genObjectName
   overTex <- genObjectName

   texts <- genObjectNames 6

   smap <- genObjectName
   
   testobj <- parseIQM "sample.iqm"

   let
	objs = [MapObject testobj (L.V3 0 10 0) (MapObjectState ())]

   ! vertexSource' <- B.readFile objectVertexShaderFile
   ! fragmentSource' <- B.readFile objectFragmentShaderFile
   vertexShader' <- compileShaderSource VertexShader vertexSource'
   checkError "compile Object-Vertex"
   fragmentShader' <- compileShaderSource FragmentShader fragmentSource'
   checkError "compile Object-Fragment"
   objProgram <- createProgramUsing [vertexShader', fragmentShader']
   checkError "compile Object-Program"
   
   currentProgram $= Just objProgram

   checkError "initShader"
   return GLMapState
        { _mapProgram         = program
        , _shdrColorIndex     = colorIndex
        , _shdrNormalIndex    = normalIndex
        , _shdrVertexIndex    = vertexIndex
        , _shdrProjMatIndex   = projectionMatrixIndex
        , _shdrViewMatIndex   = viewMatrixIndex
        , _shdrModelMatIndex  = modelMatrixIndex
        , _shdrNormalMatIndex = normalMatrixIndex
        , _shdrTessInnerIndex = tessLevelInner
        , _shdrTessOuterIndex = tessLevelOuter
        , _renderedMapTexture = tex
        , _stateTessellationFactor = tessFac
        , _stateMap           = buf
        , _mapVert            = vertDes
        , _overviewTexture    = overTex
        , _mapTextures        = texts
        , _shadowMapTexture   = smap
	, _mapObjects         = objs
	, _objectProgram      = objProgram
        }

initHud :: IO GLHud
initHud = do
   ! vertexSource <- B.readFile "shaders/ui/vertex.shader"
   ! fragmentSource <- B.readFile "shaders/ui/fragment.shader"
   vertexShader <- compileShaderSource VertexShader vertexSource
   checkError "compile UI-Vertex"
   fragmentShader <- compileShaderSource FragmentShader fragmentSource
   checkError "compile UI-Fragment"
   program <- createProgramUsing [vertexShader, fragmentShader]
   checkError "compile Program"

   tex <- genObjectName

   currentProgram $= Just program

   backIndex <- get (uniformLocation program "tex[0]")
   texIndex <- get (uniformLocation program "tex[1]")
   checkError "ui-tex"

   -- simple triangle over the whole screen.
   let vertexBufferData = reverse [-1, -1, 1, -1, -1, 1, 1, 1] :: [GLfloat]

   vertexIndex <- get (attribLocation program "position")
   vertexAttribArray vertexIndex $= Enabled
   checkError "vertexInd"

   ebo <- makeBuffer ElementArrayBuffer ([0..3] :: [GLuint])
   vbo <- makeBuffer ArrayBuffer        vertexBufferData

   att <- get (activeAttribs program)

   putStrLn $ unlines $ "Attributes: ":map show att
   putStrLn $ unlines $ ["Indices: ", show texIndex]

   checkError "initHud"
   return GLHud
        { _hudTexture           = tex
        , _hudTexIndex          = texIndex
        , _hudBackIndex         = backIndex
        , _hudVertexIndex       = vertexIndex
        , _hudVert              = 4
        , _hudVBO               = vbo
        , _hudEBO               = ebo
        , _hudProgram           = program
        }




initRendering :: IO ()
initRendering = do
        clearColor $= Color4 0.6 0.7 0.8 1
        depthFunc $= Just Less
        glCullFace gl_BACK
        checkError "initRendering"

{-renderOverview :: Pioneers ()
renderOverview = do
    liftIO $ do
        ---- RENDER OVERVIEW MAP ------------------------------------------


        bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer)
        bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
        framebufferRenderbuffer
                Framebuffer
                DepthAttachment
                Renderbuffer
                (state ^. gl.glRenderbuffer)
        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)

        framebufferTexture2D
                Framebuffer
                (ColorAttachment 0)
                Texture2D
                (state ^. gl.glMap.renderedMapTexture)
                0

        -- Render to FrameBufferObject
        drawBuffers $= [FBOColorAttachment 0]
        checkError "setup Render-Target"

        clear [ColorBuffer, DepthBuffer]
        checkError "clear buffer"


        currentProgram $= Just (state ^. gl.glMap.mapProgram)

        checkError "setting up buffer"
        --set up projection (= copy from state)
        with (distribute frust) $ \ptr ->
              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
        checkError "copy projection"

        --set up camera
        let ! cam = getCam camPos zDist' xa ya
        with (distribute cam) $ \ptr ->
              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
        checkError "copy cam"

        --set up normal--Mat transpose((model*camera)^-1)
        let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
                                             (Just a) -> a
                                             Nothing  -> L.eye3) :: L.M33 CFloat
            nmap = collect id normal' :: L.M33 CFloat --transpose...

        with (distribute nmap) $ \ptr ->
              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))

        checkError "nmat"

        glUniform1f tli (fromIntegral tessFac)
        glUniform1f tlo (fromIntegral tessFac)

        bindBuffer ArrayBuffer $= Just map'
        vertexAttribPointer ci $= fgColorIndex
        vertexAttribArray ci   $= Enabled
        vertexAttribPointer ni $= fgNormalIndex
        vertexAttribArray ni   $= Enabled
        vertexAttribPointer vi $= fgVertexIndex
        vertexAttribArray vi   $= Enabled
        checkError "beforeDraw"

        glPatchParameteri gl_PATCH_VERTICES 3

        cullFace $= Just Front

        glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
        checkError "draw map"
-}


-- | renders an IQM-Model at Position with scaling
renderIQM :: IQM -> L.V3 CFloat -> L.V3 CFloat -> IO ()
renderIQM m p@(L.V3 x y z) s@(L.V3 sx sy sz) = do
	return ()

renderObject :: MapObject -> IO ()
renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) = 
	renderIQM model pos (L.V3 1 1 1)
		
drawMap :: Pioneers ()
drawMap = do
    state <- RWS.get
    let 
        vi       = state ^. gl.glMap.shdrVertexIndex
        ni       = state ^. gl.glMap.shdrNormalIndex
        ci       = state ^. gl.glMap.shdrColorIndex
        numVert  = state ^. gl.glMap.mapVert
        map'     = state ^. gl.glMap.stateMap
        tessFac  = state ^. gl.glMap.stateTessellationFactor
        (UniformLocation tli)   = state ^. gl.glMap.shdrTessInnerIndex
        (UniformLocation tlo)   = state ^. gl.glMap.shdrTessOuterIndex
    liftIO $ do
        glUniform1f tli (fromIntegral tessFac)
        glUniform1f tlo (fromIntegral tessFac)

        bindBuffer ArrayBuffer $= Just map'
        vertexAttribPointer ci $= fgColorIndex
        vertexAttribArray ci   $= Enabled
        vertexAttribPointer ni $= fgNormalIndex
        vertexAttribArray ni   $= Enabled
        vertexAttribPointer vi $= fgVertexIndex
        vertexAttribArray vi   $= Enabled
        checkError "beforeDraw"

        glPatchParameteri gl_PATCH_VERTICES 3

        cullFace $= Just Front

        glDrawArrays gl_PATCHES 0 (fromIntegral numVert)

        checkError "draw map"

	---- RENDER MAPOBJECTS --------------------------------------------
	
	currentProgram $= Just (state ^. gl.glMap.objectProgram)

	mapM_ renderObject (state ^. gl.glMap.mapObjects)

        -- set sample 1 as target in renderbuffer
        {-framebufferRenderbuffer
                DrawFramebuffer              --write-only
                (ColorAttachment 1)          --sample 1
                Renderbuffer                 --const
                rb                              --buffer-}

render :: Pioneers ()
render = do
    state <- RWS.get
    let xa       = state ^. camera.xAngle
        ya       = state ^. camera.yAngle
        frust    = state ^. camera.Types.frustum
        camPos   = state ^. camera.camObject
        zDist'   = state ^. camera.zDist
        (UniformLocation proj)  = state ^. gl.glMap.shdrProjMatIndex
        (UniformLocation nmat)  = state ^. gl.glMap.shdrNormalMatIndex
        (UniformLocation vmat)  = state ^. gl.glMap.shdrViewMatIndex
    liftIO $ do
        ---- RENDER MAP IN TEXTURE ------------------------------------------

        bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer)
        {-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
        framebufferRenderbuffer
                Framebuffer
                DepthAttachment
                Renderbuffer
                (state ^. gl.glRenderbuffer)-}
        
        -- SHADOWMAP
        textureBinding Texture2D $= Just (state ^. gl.glMap.shadowMapTexture)
        framebufferTexture2D 
                Framebuffer
                DepthAttachment
                Texture2D
                (state ^. gl.glMap.shadowMapTexture)
                0

        drawBuffer $= NoBuffers --color-buffer is not needed but must(?) be set up
        checkError "setup Render-Target"

        clear [DepthBuffer]
        checkError "clearing shadowmap-buffer"
        
        --TODO: simplified program for shadows?
        currentProgram $= Just (state ^. gl.glMap.mapProgram)
        checkError "setting up shadowmap-program"

        --set up projection (= copy from state)
        --TODO: Fix
        with (distribute frust) $ \ptr ->
              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
        checkError "copy shadowmap-projection"

        --set up camera
        --TODO: Fix
        let ! cam = getCam camPos zDist' xa ya
        with (distribute cam) $ \ptr ->
              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
        checkError "copy shadowmap-cam"

        --set up normal--Mat transpose((model*camera)^-1)
        --needed?
        let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
                                             (Just a) -> a
                                             Nothing  -> L.eye3) :: L.M33 CFloat
            nmap = collect id normal' :: L.M33 CFloat --transpose...

        with (distribute nmap) $ \ptr ->
              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))

        checkError "nmat"
    drawMap
    liftIO $ do
        checkError "draw ShadowMap"

        -- COLORMAP
        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
        framebufferTexture2D
                Framebuffer
                (ColorAttachment 0)
                Texture2D
                (state ^. gl.glMap.renderedMapTexture)
                0

        -- Render to FrameBufferObject
        drawBuffers $= [FBOColorAttachment 0]
        checkError "setup Render-Target"

        clear [ColorBuffer, DepthBuffer]
        checkError "clear buffer"


        currentProgram $= Just (state ^. gl.glMap.mapProgram)

        checkError "setting up buffer"
        --set up projection (= copy from state)
        with (distribute frust) $ \ptr ->
              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
        checkError "copy projection"

        --set up camera
        let ! cam = getCam camPos zDist' xa ya
        with (distribute cam) $ \ptr ->
              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
        checkError "copy cam"

        --set up normal--Mat transpose((model*camera)^-1)
        let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
                                             (Just a) -> a
                                             Nothing  -> L.eye3) :: L.M33 CFloat
            nmap = collect id normal' :: L.M33 CFloat --transpose...

        with (distribute nmap) $ \ptr ->
              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))

        checkError "nmat"

    drawMap --draw map -> put to another function for readability
    liftIO $ do

        ---- COMPOSE RENDERING --------------------------------------------
        -- Render to BackBuffer (=Screen)
        bindFramebuffer Framebuffer $= defaultFramebufferObject
        drawBuffer $= BackBuffers
        -- Drawing HUD
        clear [ColorBuffer, DepthBuffer]
        checkError "clear buffer"

        let hud    = state ^. gl.glHud
            stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2
            vad    = VertexArrayDescriptor 2 Float stride offset0
        currentProgram $= Just (hud ^. hudProgram)

        activeTexture  $= TextureUnit 0
        textureBinding Texture2D $= Just (hud ^. hudTexture)
        uniform (hud ^. hudTexIndex) $= Index1 (0::GLint)

        activeTexture  $= TextureUnit 1
        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
        uniform (hud ^. hudBackIndex) $= Index1 (1::GLint)

        bindBuffer ArrayBuffer $= Just (hud ^. hudVBO)
        vertexAttribPointer (hud ^. hudVertexIndex) $= (ToFloat, vad)
        vertexAttribArray   (hud ^. hudVertexIndex) $= Enabled

        bindBuffer ElementArrayBuffer $= Just (hud ^. hudEBO)
        drawElements TriangleStrip 4 UnsignedInt offset0


        {-let winRenderer = env ^. renderer
        tryWithTexture
                (state ^. hudTexture)                          --maybe tex
                (\tex -> renderCopy winRenderer tex Nothing Nothing) --function with "hole"
                                                       --Nothing == whole source-tex, whole dest-tex
                (return ())                                       --fail-case-}