pioneers/src/Main.hs

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

-- 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)
import           Foreign.C                            (CFloat)

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

-- GUI
import qualified Graphics.UI.SDL                      as SDL (Position)
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, UTCTime, diffUTCTime)

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

import qualified Debug.Trace                          as D (trace)

--------------------------------------------------------------------------------
main :: IO ()
main = do
        SDL.withInit [InitVideo, InitAudio] $ do --also: InitNoParachute -> faster, without parachute!
        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
        withOpenGL window $ do
        --TTF.withInit $ do
        (Size fbWidth fbHeight) <- glGetDrawableSize window
        initRendering
        --generate map vertices
        (mapBuffer, vert) <- getMapBufferObject
        (ci, ni, vi, pri, vii, mi, nmi, tli, tlo) <- initShader
        putStrLn "foo"
        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

        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
                }
            env = Env
              { _eventsChan      = eventQueue
              , _windowObject    = window
              , _zDistClosest    = zDistClosest
              , _zDistFarthest   = zDistFarthest
              --, 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
                        }
              , _game                = GameState
                        {
                        }
              }

        putStrLn "init done."
        void $ evalRWST (adjustWindow >> run) env state

        destroyWindow window

-- Render-Pipeline

draw :: Pioneers ()
draw = do
    state <- get
    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
    liftIO $ do
        --(vi,GL.UniformLocation proj) <- initShader
        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
        checkError "foo"
        --set up projection (= copy from state)
        with (distribute frust) $ \ptr ->
              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
        checkError "foo"

        --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 "foo"
              
        --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"


-- 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
    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


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

processEvent :: Event -> Pioneers ()
processEvent e = do
        return ()
        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
                    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]