pioneers/src/Main.hs

{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
module Main where

import Data.Int (Int8)
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D)
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D)
import Control.Monad (liftM)
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (textureFilter)
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget2D(Texture2D))
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding)
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..))

-- Monad-foo and higher functional stuff
import           Control.Monad                        (unless, void, when, join)
import Control.Arrow ((***))

-- data consistency/conversion
import           Control.Concurrent                   (threadDelay)
import           Control.Concurrent.STM               (TQueue,
                                                       newTQueueIO)

import           Control.Monad.RWS.Strict             (RWST, ask, asks,
                                                       evalRWST, get, liftIO,
                                                       modify, put)
import           Data.Distributive                    (distribute, collect)

-- FFI
import           Foreign                              (Ptr, castPtr, with, sizeOf)
import           Foreign.C                            (CFloat)
import           Foreign.C.Types                      (CInt)
import           Data.Word                            (Word8)

-- Math
import           Control.Lens                         ((^.), (.~), (%~))
import           Linear                               as L

-- GUI
import           Graphics.UI.SDL                      as SDL
--import           Graphics.UI.SDL.TTF                  as TTF
--import           Graphics.UI.SDL.TTF.Types

-- Render
import qualified Graphics.Rendering.OpenGL.GL         as GL
import           Graphics.Rendering.OpenGL.Raw.Core31
import           Data.Time                            (getCurrentTime, diffUTCTime)
import           Graphics.GLUtil.BufferObjects        (offset0)

import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
-- Our modules
import           Map.Graphics
import           Render.Misc                          (checkError,
                                                       createFrustum, getCam,
                                                       curb, tryWithTexture,
                                                       genColorData)
import           Render.Render                        (initRendering,
                                                       initMapShader,
                                                       initHud)
import           UI.Callbacks
import           UI.GUIOverlay
import           Types

--import           ThirdParty.Flippers

import qualified Debug.Trace                          as D (trace)

--------------------------------------------------------------------------------
main :: IO ()
main = do
        SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute!
{-        (window, renderer) <- SDL.createWindowAndRenderer (Size 1024 600) [WindowOpengl     -- we want openGL
                                                                             ,WindowShown      -- window should be visible
                                                                             ,WindowResizable  -- and resizable 
                                                                             ,WindowInputFocus -- focused (=> active)
                                                                             ,WindowMouseFocus -- Mouse into it
                                                                             --,WindowInputGrabbed-- never let go of input (KB/Mouse)
                                                                             ] -}
        SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl     -- we want openGL
                                                                             ,WindowShown      -- window should be visible
                                                                             ,WindowResizable  -- and resizable 
                                                                             ,WindowInputFocus -- focused (=> active)
                                                                             ,WindowMouseFocus -- Mouse into it
                                                                             --,WindowInputGrabbed-- never let go of input (KB/Mouse)
                                                                             ] $ \window -> do
        --mainGlContext <- SDL.glCreateContext window 
        withOpenGL window $ do
        --TTF.withInit $ do
        
        --Create Renderbuffer & Framebuffer
        -- We will render to this buffer to copy the result into textures
        renderBuffer <- GL.genObjectName
        frameBuffer <- GL.genObjectName
        GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
        GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
        
        (Size fbWidth fbHeight) <- glGetDrawableSize window
        initRendering
        --generate map vertices
        (mapBuffer, vert) <- getMapBufferObject
        (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
        putStrLn $ show window
        eventQueue <- newTQueueIO :: IO (TQueue Event)
        putStrLn "foo"
        now <- getCurrentTime
        putStrLn "foo"
        --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
        --TTF.setFontStyle font TTFNormal
        --TTF.setFontHinting font TTFHNormal

        glHud <- initHud
        let zDistClosest  = 1
            zDistFarthest = zDistClosest + 30
            --TODO: Move near/far/fov to state for runtime-changability & central storage
            fov           = 90  --field of view
            near          = 1   --near plane
            far           = 100 --far plane
            ratio         = fromIntegral fbWidth / fromIntegral fbHeight
            frust         = createFrustum fov near far ratio
            aks = ArrowKeyState {
                  _up       = False
                , _down     = False
                , _left     = False
                , _right    = False
            }
            glMap = GLMapState
                { _shdrVertexIndex      = vi
                , _shdrNormalIndex      = ni
                , _shdrColorIndex       = ci
                , _shdrProjMatIndex     = pri
                , _shdrViewMatIndex     = vii
                , _shdrModelMatIndex    = mi
                , _shdrNormalMatIndex   = nmi
                , _shdrTessInnerIndex   = tli
                , _shdrTessOuterIndex   = tlo
                , _stateTessellationFactor = 4
                , _stateMap             = mapBuffer
                , _mapVert              = vert
                , _mapProgram           = mapprog
                , _mapTexture           = mapTex
                }
            env = Env
              { _eventsChan      = eventQueue
              , _windowObject    = window
              , _zDistClosest    = zDistClosest
              , _zDistFarthest   = zDistFarthest
              --, _renderer        = renderer 
              --, envFont          = font
              }
            state = State
              { _window              = WindowState
                        { _width               = fbWidth
                        , _height              = fbHeight
                        , _shouldClose         = False
                        }
              , _camera              = CameraState
                        { _xAngle              = pi/6
                        , _yAngle              = pi/2
                        , _zDist               = 10
                        , _frustum             = frust
                        , _camPosition         = Types.Position
                                       { Types._x    = 5
                                       , Types._y    = 5
                                       }
                        }
              , _io                  = IOState
                        { _clock               = now
                        }
              , _mouse               = MouseState
                        { _isDown              = False
                        , _isDragging          = False
                        , _dragStartX          = 0
                        , _dragStartY          = 0
                        , _dragStartXAngle     = 0
                        , _dragStartYAngle     = 0
                        , _mousePosition       = Types.Position
                                         { Types._x  = 5
                                         , Types._y  = 5
                                         }
                        }
              , _keyboard            = KeyboardState
                        { _arrowsPressed       = aks
                        }
              , _gl                  = GLState
                        { _glMap               = glMap
                        , _glHud               = glHud
                        , _glRenderbuffer      = renderBuffer
                        , _glFramebuffer       = frameBuffer
                        }
              , _game                = GameState
                        {
                        }
              , _ui                  = UIState
                        { _uiHasChanged        = True
                        }
              }

        putStrLn "init done."
        void $ evalRWST (adjustWindow >> run) env state
        
        --SDL.glDeleteContext mainGlContext
        --SDL.destroyRenderer renderer
        --destroyWindow window

-- Render-Pipeline

draw :: Pioneers ()
draw = do
    state <- get
    env <- ask
    let xa       = state ^. camera.xAngle
        ya       = state ^. camera.yAngle
        (GL.UniformLocation proj)  = state ^. gl.glMap.shdrProjMatIndex   
        (GL.UniformLocation nmat)  = state ^. gl.glMap.shdrNormalMatIndex 
        (GL.UniformLocation vmat)  = state ^. gl.glMap.shdrViewMatIndex   
        (GL.UniformLocation tli)   = state ^. gl.glMap.shdrTessInnerIndex 
        (GL.UniformLocation tlo)   = state ^. gl.glMap.shdrTessOuterIndex 
        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        
        frust    = state ^. camera.frustum           
        camX     = state ^. camera.camPosition.x
        camY     = state ^. camera.camPosition.y
        zDist'   = state ^. camera.zDist
        tessFac  = state ^. gl.glMap.stateTessellationFactor
        window   = env ^. windowObject
        rb       = state ^. gl.glRenderbuffer
    if state ^. ui.uiHasChanged then
        prepareGUI
    else
        return ()
    liftIO $ do
        --bind renderbuffer and set sample 0 as target
        --GL.bindRenderbuffer GL.Renderbuffer GL.$= rb
        --GL.bindFramebuffer  GL.Framebuffer  GL.$= GL.defaultFramebufferObject 
        --checkError "bind renderbuffer"

        --checkError "clear renderbuffer"
        {-GL.framebufferRenderbuffer
                GL.Framebuffer                  --framebuffer
                (GL.ColorAttachment 1)          --sample 1
                GL.Renderbuffer                 --const
                rb                              --buffer
        checkError "setup renderbuffer"-}

        -- draw map
        --(vi,GL.UniformLocation proj) <- initShader
        
        GL.bindFramebuffer GL.Framebuffer GL.$= (state ^. gl.glFramebuffer)
        GL.bindRenderbuffer GL.Renderbuffer GL.$= (state ^. gl.glRenderbuffer)
        GL.framebufferRenderbuffer
                GL.Framebuffer
                GL.DepthAttachment
                GL.Renderbuffer
                (state ^. gl.glRenderbuffer)
        textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
        
        GL.framebufferTexture2D
                GL.Framebuffer
                (GL.ColorAttachment 0)
                GL.Texture2D
                (state ^. gl.glMap.mapTexture)
                0
        
        -- Render to FrameBufferObject
        GL.drawBuffers GL.$= [GL.FBOColorAttachment 0]
        checkError "setup Render-Target"

        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
        checkError "clear buffer"


        GL.currentProgram GL.$= 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 (M44 CFloat)))
        checkError "copy projection"

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

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

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

        checkError "nmat"

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

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

        glPatchParameteri gl_PATCH_VERTICES 3
        glPolygonMode gl_FRONT gl_LINE

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

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

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

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

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

        GL.activeTexture  GL.$= GL.TextureUnit 1
        textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
        GL.uniform (hud ^. hudBackIndex) GL.$= GL.Index1 (1::GL.GLint)
        
        GL.bindBuffer GL.ArrayBuffer GL.$= Just (hud ^. hudVBO)
        GL.vertexAttribPointer (hud ^. hudVertexIndex) GL.$= (GL.ToFloat, vad)
        GL.vertexAttribArray   (hud ^. hudVertexIndex) GL.$= GL.Enabled
        
        GL.bindBuffer GL.ElementArrayBuffer GL.$= Just (hud ^. hudEBO)
        GL.drawElements GL.TriangleStrip 4 GL.UnsignedInt offset0


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

-- Main game loop

run :: Pioneers ()
run = do
    env <- ask

    -- draw Scene
    draw
    liftIO $ glSwapWindow (env ^. windowObject)
    -- getEvents & process
    processEvents

    -- update State

    state <- get
    -- change in camera-angle
    when (state ^. mouse.isDragging) $ do
          let sodx  = state ^. mouse.dragStartX
              sody  = state ^. mouse.dragStartY
              sodxa = state ^. mouse.dragStartXAngle
              sodya = state ^. mouse.dragStartYAngle
              x'    = state ^. mouse.mousePosition.x
              y'    = state ^. mouse.mousePosition.y
              myrot = (x' - sodx) / 2
              mxrot = (y' - sody) / 2
              newXAngle  = curb (pi/12) (0.45*pi) newXAngle'
              newXAngle' = sodxa + mxrot/100
              newYAngle
                  | newYAngle' > pi    = newYAngle' - 2 * pi
                  | newYAngle' < (-pi) = newYAngle' + 2 * pi
                  | otherwise          = newYAngle'
              newYAngle' = sodya + myrot/100
          
          modify $ ((camera.xAngle) .~ newXAngle)
                 . ((camera.yAngle) .~ newYAngle)

    -- get cursor-keys - if pressed
    --TODO: Add sin/cos from stateYAngle
    (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
    let 
        multc = cos $ state ^. camera.yAngle
        mults = sin $ state ^. camera.yAngle
        modx x' = x' - 0.2 * kxrot * multc
                     - 0.2 * kyrot * mults
        mody y' = y' + 0.2 * kxrot * mults
                     - 0.2 * kyrot * multc
    modify $ (camera.camPosition.x %~ modx)
           . (camera.camPosition.y %~ mody)

    {-
    --modify the state with all that happened in mt time.
    mt <- liftIO GLFW.getTime
    modify $ \s -> s
      {
      }
    -}

    mt <- liftIO $ do
        now <- getCurrentTime
        diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs
        title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"]
        setWindowTitle (env ^. windowObject) title
        sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
        threadDelay sleepAmount
        return now
    -- set state with new clock-time
    modify $ io.clock .~ mt
    shouldClose <- return $ state ^. window.shouldClose
    unless shouldClose run

getArrowMovement :: Pioneers (Int, Int)
getArrowMovement = do
        state <- get
        aks <- return $ state ^. (keyboard.arrowsPressed) 
        let 
                horz   = left' + right'
                vert   = up'+down'
                left'  = if aks ^. left  then -1 else 0
                right' = if aks ^. right then  1 else 0
                up'    = if aks ^. up    then -1 else 0
                down'  = if aks ^. down  then  1 else 0
        return (horz,vert)

adjustWindow :: Pioneers ()
adjustWindow = do
    state <- get
    env <- ask
    let fbWidth  = state ^. window.width
        fbHeight = state ^. window.height
        fov           = 90  --field of view
        near          = 1   --near plane
        far           = 100 --far plane
        ratio         = fromIntegral fbWidth / fromIntegral fbHeight
        frust         = createFrustum fov near far ratio
    liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
    modify $ camera.frustum .~ frust
    rb <- liftIO $ do
                   -- bind ints to CInt for lateron.
                   let fbCWidth  = (fromInteger.toInteger) fbWidth
                       fbCHeight = (fromInteger.toInteger) fbHeight
                   -- free old renderbuffer & create new (reuse is NOT advised!)
                   GL.deleteObjectName (state ^. gl.glRenderbuffer)
                   renderBuffer <- GL.genObjectName
                   GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
                   GL.renderbufferStorage
                       GL.Renderbuffer                         -- use the only available renderbuffer 
                                                               -- - must be this constant.
                       GL.DepthComponent'                      -- 32-bit float-rgba-color
                       (GL.RenderbufferSize fbCWidth fbCHeight)  -- size of buffer


                   let hudtexid = state ^. gl.glHud.hudTexture
                       maptexid = state ^. gl.glMap.mapTexture
                   allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
                                                               --default to ugly pink to see if
                                                               --somethings go wrong.
                        let imData = genColorData (fbWidth*fbHeight) [255,0,255,0]
                        --putStrLn $ show imData
                        pokeArray ptr imData
                        -- HUD
                        textureBinding Texture2D GL.$= Just hudtexid
                        textureFilter  Texture2D GL.$= ((Linear', Nothing), Linear')
                        texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
                                                (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
                        -- MAP
                        textureBinding Texture2D GL.$= Just maptexid
                        textureFilter  Texture2D GL.$= ((Linear', Nothing), Linear')
                        texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
                                                (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
                   checkError "setting up HUD-Tex"
                   return renderBuffer
    modify $ gl.glRenderbuffer .~ rb
    modify $ ui.uiHasChanged .~ True

processEvents :: Pioneers ()
processEvents = do
    me <- liftIO pollEvent
    case me of
      Just e -> do
          processEvent e
          processEvents
      Nothing -> return ()

processEvent :: Event -> Pioneers ()
processEvent e = do
        env <- ask
        case eventData e of
            Window _ winEvent ->
                case winEvent of
                    Closing ->
                            modify $ window.shouldClose .~ True
                    Resized {windowResizedTo=size} -> do
                            modify $ (window.width  .~ (sizeWidth  size))
                                   . (window.height .~ (sizeHeight size))
                            adjustWindow
                    SizeChanged ->
                            adjustWindow
                    _ ->
                        return ()
                        --liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
            Keyboard movement _ isRepeated key -> --up/down window(ignored) true/false actualKey
                     -- need modifiers? use "keyModifiers key" to get them
                let aks = keyboard.arrowsPressed in
                case keyScancode key of
                    SDL.R    ->
                        liftIO $ do
                                r <- getRenderer $ env ^. windowObject
                                putStrLn $ unwords ["Renderer: ",show r]
                    Escape   ->
                        modify $ window.shouldClose .~ True
                    SDL.Left  ->
                        modify $ aks.left  .~ (movement == KeyDown)
                    SDL.Right ->
                        modify $ aks.right .~ (movement == KeyDown)
                    SDL.Up    ->
                        modify $ aks.up    .~ (movement == KeyDown)
                    SDL.Down  ->
                        modify $ aks.down  .~ (movement == KeyDown)
                    SDL.KeypadPlus ->
                        when (movement == KeyDown) $ do
                            modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1))
                            state <- get
                            liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
                    SDL.KeypadMinus ->
                        when (movement == KeyDown) $ do
                            modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1)))
                            state <- get
                            liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
                    _ ->
                        return ()
            MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do
                state <- get
                when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
                    modify $ (mouse.isDragging .~ True)
                           . (mouse.dragStartX .~ (fromIntegral x))
                           . (mouse.dragStartY .~ (fromIntegral y))
                           . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
                           . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
                    
                modify $ (mouse.mousePosition. Types.x .~ (fromIntegral x))
                       . (mouse.mousePosition. Types.y .~ (fromIntegral y))
            MouseButton _ mouseId button state (SDL.Position x y) ->
                case button of
                    LeftButton -> do
                        let pressed = state == Pressed
                        modify $ mouse.isDown .~ pressed
                        unless pressed $ do
                            st <- get
                            if st ^. mouse.isDragging then
                                modify $ mouse.isDragging .~ False
                            else
                                clickHandler (UI.Callbacks.Pixel x y)
                    RightButton -> do
                        when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
                    _ ->
                        return ()
            MouseWheel _ mouseId hscroll vscroll -> do
                env <- ask
                state <- get
                let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in 
                  modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
            Quit -> modify $ window.shouldClose .~ True
            -- there is more (joystic, touchInterface, ...), but currently ignored
            _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]