pioneers/src/Main.hs

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

import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding)
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter)

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

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

import           Control.Monad.RWS.Strict             (ask, evalRWST, get, liftIO, modify)
import           Data.Functor                         ((<$>))
import           Data.Monoid                          (mappend)

-- FFI
import           Foreign.Marshal.Array                (pokeArray)
import           Foreign.Marshal.Alloc                (allocaBytes)

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

-- GUI
import qualified Graphics.UI.SDL                      as SDL

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

-- Our modules
import           Render.Misc                          (checkError, createFrustum, curb,
                                                       genColorData)
import           Render.Render                        (initRendering,
                                                       initMapShader,
                                                       initHud, render)
import           Render.Types
import           UI.Callbacks
import           Map.Graphics
import           Types
import           Importer.IQM.Parser
--import           Data.Attoparsec.Char8 (parseTest)
--import qualified Data.ByteString as B

-- import qualified Debug.Trace                          as D (trace)

--------------------------------------------------------------------------------

testParser :: String -> IO ()
testParser a = putStrLn . show  =<< parseIQM a
{-do
        f <- B.readFile a
        putStrLn "reading in:"
        putStrLn $ show f
        putStrLn "parsed:"
        parseTest parseIQM f-}

--------------------------------------------------------------------------------

main :: IO ()
main =
    SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
      SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl     -- we want openGL
                                                                             ,SDL.WindowShown      -- window should be visible
                                                                             ,SDL.WindowResizable  -- and resizable
                                                                             ,SDL.WindowInputFocus -- focused (=> active)
                                                                             ,SDL.WindowMouseFocus -- Mouse into it
                                                                             --,WindowInputGrabbed-- never let go of input (KB/Mouse)
                                                                             ] $ \window' -> do
       SDL.withOpenGL window' $ 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

        (SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
        initRendering
        --generate map vertices
        glMap' <- initMapShader 4 =<< getMapBufferObject
        eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
        now <- getCurrentTime
        --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' + 50
            --TODO: Move near/far/fov to state for runtime-changability & central storage
            fov           = 90  --field of view
            near          = 1   --near plane
            far           = 500 --far plane
            ratio         = fromIntegral fbWidth / fromIntegral fbHeight
            frust         = createFrustum fov near far ratio
            (guiMap, guiRoots) = createGUI
            aks = ArrowKeyState {
                  _up       = False
                , _down     = False
                , _left     = False
                , _right    = False
            }
            env = Env
              { _eventsChan      = eventQueue
              , _windowObject    = window'
              , _zDistClosest    = zDistClosest'
              , _zDistFarthest   = zDistFarthest'
              }
            state = State
              { _window              = WindowState
                        { _width               = fbWidth
                        , _height              = fbHeight
                        , _shouldClose         = False
                        }
              , _camera              = CameraState
                        { _xAngle              = pi/6
                        , _yAngle              = pi/2
                        , _zDist               = 10
                        , _frustum             = frust
                        , _camObject           = createFlatCam 25 25
                        }
              , _io                  = IOState
                        { _clock               = now
                        , _tessClockFactor     = 0
                        }
              , _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
                        , _uiMap = guiMap
                        , _uiRoots = guiRoots
                        }
              }

        putStrLn "init done."
        uncurry mappend <$> evalRWST (adjustWindow >> run) env state
        putStrLn "shutdown complete."

        --SDL.glDeleteContext mainGlContext
        --SDL.destroyRenderer renderer
        --destroyWindow window

-- Main game loop

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

    -- draw Scene
    draw
    liftIO $ SDL.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.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)))

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

    (mt,tc,sleepAmount,frameTime) <- liftIO $ do
        let 	double = fromRational.toRational :: (Real a) => a -> Double
		targetFramerate = 60.0
		targetFrametime = 1.0/targetFramerate
		targetFrametimeμs = targetFrametime * 1000000.0
        now <- getCurrentTime
        let diff  = diffUTCTime now (state ^. io.clock) -- get time-diffs
            title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
            ddiff = double diff
        SDL.setWindowTitle (env ^. windowObject) title
        let 	sleepAmount = floor ((targetFrametime - double diff)*1000000) :: Int -- get time until next frame in microseconds
                clockFactor = (state ^. io.tessClockFactor)
		tessChange
			| (clockFactor < (75*targetFrametime)) && (state ^. gl.glMap.stateTessellationFactor < 5) = ((+)1 :: Int -> Int) 
										-- > last 100 frames had > 25% leftover (on avg.)
			| (clockFactor > (110*targetFrametime)) && (state ^. gl.glMap.stateTessellationFactor > 1) = (flip (-) 1 :: Int -> Int)
									-- > last 100 frames had < 90% of target-fps
			| otherwise = ((+)0 :: Int -> Int)              -- 0ms > x > 10% -> keep settings
        when (sleepAmount > 0) $ threadDelay sleepAmount
	now' <- getCurrentTime
        return (now',tessChange,sleepAmount,ddiff)
    -- set state with new clock-time
    --liftIO $ putStrLn $ unwords ["clockFactor:",show (state ^. io.tessClockFactor),"\ttc:", show (tc (state ^. gl.glMap.stateTessellationFactor)),"\tsleep ",show frameTime,"ms"]
    modify $ (io.clock .~ mt)
           . (gl.glMap.stateTessellationFactor %~ tc)
           . (io.tessClockFactor %~ (((+) frameTime).((*) 0.99)))
    -- liftIO $ putStrLn $ concat $ ["TessFactor at: ",show (state ^. gl.glMap.stateTessellationFactor), " - slept for ",show sleepAmount, "μs."]
    shouldClose' <- return $ state ^. window.shouldClose
    unless shouldClose' run

draw :: Pioneers ()
draw = do
    state <- get
    when (state ^. ui . uiHasChanged) prepareGUI
    render

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
    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.renderedMapTexture
                       smaptexid = state ^. gl.glMap.shadowMapTexture
                   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)
                   allocaBytes (2048*2048) $ \ptr -> do
                        let smapdata = genColorData (2048*2048) [0]
                        pokeArray ptr smapdata
                        textureBinding Texture2D GL.$= Just smaptexid
                        textureFilter  Texture2D GL.$= ((Nearest,Nothing), Nearest)
                        texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D 2048 2048) 0
                                                (GL.PixelData GL.DepthComponent GL.UnsignedByte ptr)
                   checkError "setting up HUD-Tex"
                   return renderBuffer
    modify $ gl.glRenderbuffer .~ rb
    modify $ ui.uiHasChanged .~ True

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

processEvent :: SDL.Event -> Pioneers ()
processEvent e = do
    eventCallback e
    -- env <- ask
    case SDL.eventData e of
         SDL.Window _ winEvent -> -- windowID event
            case winEvent of
                SDL.Closing ->
                        modify $ window.shouldClose .~ True
                SDL.Resized {SDL.windowResizedTo=size} -> do
                        modify $ (window . width .~ SDL.sizeWidth size)
                               . (window . height .~ SDL.sizeHeight size)
                        adjustWindow
                SDL.SizeChanged ->
                        adjustWindow
                _ -> return ()
         _ -> return ()