fixed compiler warnings.
most of them .. not all are my modules.
This commit is contained in:
Stefan Dresselhaus
143
src/Main.hs
143
src/Main.hs
@ -1,17 +1,13 @@
|
||||
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
|
||||
module Main where
|
||||
|
||||
import Data.Int (Int8)
|
||||
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D)
|
||||
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
|
||||
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
|
||||
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D)
|
||||
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(..))
|
||||
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter)
|
||||
|
||||
-- Monad-foo and higher functional stuff
|
||||
import Control.Monad (unless, void, when, join, liftM)
|
||||
import Control.Monad (unless, when, join)
|
||||
import Control.Arrow ((***))
|
||||
|
||||
-- data consistency/conversion
|
||||
@ -19,10 +15,7 @@ import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.STM (TQueue,
|
||||
newTQueueIO)
|
||||
|
||||
import Control.Monad.RWS.Strict (RWST, ask, asks,
|
||||
evalRWST, get, liftIO,
|
||||
modify, put)
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
|
||||
import Control.Monad.Trans.State (evalStateT)
|
||||
import Data.Functor ((<$>))
|
||||
import Data.Distributive (distribute, collect)
|
||||
@ -31,10 +24,8 @@ import Data.Monoid (mappend)
|
||||
-- FFI
|
||||
import Foreign (Ptr, castPtr, with, sizeOf)
|
||||
import Foreign.C (CFloat)
|
||||
import Foreign.C.Types (CInt)
|
||||
import Foreign.Marshal.Array (pokeArray)
|
||||
import Foreign.Marshal.Alloc (allocaBytes)
|
||||
import Data.Word (Word8)
|
||||
|
||||
-- Math
|
||||
import Control.Lens ((^.), (.~), (%~))
|
||||
@ -42,8 +33,6 @@ import qualified 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
|
||||
@ -54,58 +43,53 @@ 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,
|
||||
import Render.Misc (checkError, createFrustum, getCam, curb,
|
||||
genColorData)
|
||||
import Render.Render (initRendering,
|
||||
initMapShader,
|
||||
initHud)
|
||||
import UI.Callbacks
|
||||
import UI.GUIOverlay
|
||||
import Types
|
||||
import Importer.IQM.Parser
|
||||
import Data.Attoparsec.Char8 (parseTest)
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
--import ThirdParty.Flippers
|
||||
|
||||
import qualified Debug.Trace as D (trace)
|
||||
-- import qualified Debug.Trace as D (trace)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
testParser :: IO ()
|
||||
testParser = do
|
||||
f <- B.readFile "sample.iqm"
|
||||
f <- B.readFile "sample.iqm"
|
||||
parseTest (evalStateT parseIQM 0) f
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute!
|
||||
main =
|
||||
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --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
|
||||
,WindowResizable -- and resizable
|
||||
,WindowInputFocus -- focused (=> active)
|
||||
,WindowMouseFocus -- Mouse into it
|
||||
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
|
||||
] $ \window -> do
|
||||
withOpenGL window $ do
|
||||
|
||||
] $ \window' -> do
|
||||
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
|
||||
|
||||
(Size fbWidth fbHeight) <- glGetDrawableSize window
|
||||
|
||||
(Size fbWidth fbHeight) <- glGetDrawableSize window'
|
||||
initRendering
|
||||
--generate map vertices
|
||||
(mapBuffer, vert) <- getMapBufferObject
|
||||
(mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
|
||||
print window
|
||||
print window'
|
||||
eventQueue <- newTQueueIO :: IO (TQueue Event)
|
||||
putStrLn "foo"
|
||||
now <- getCurrentTime
|
||||
@ -114,9 +98,9 @@ main = do
|
||||
--TTF.setFontStyle font TTFNormal
|
||||
--TTF.setFontHinting font TTFHNormal
|
||||
|
||||
glHud <- initHud
|
||||
let zDistClosest = 1
|
||||
zDistFarthest = zDistClosest + 50
|
||||
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
|
||||
@ -129,7 +113,7 @@ main = do
|
||||
, _left = False
|
||||
, _right = False
|
||||
}
|
||||
glMap = GLMapState
|
||||
glMap' = GLMapState
|
||||
{ _shdrVertexIndex = vi
|
||||
, _shdrNormalIndex = ni
|
||||
, _shdrColorIndex = ci
|
||||
@ -147,11 +131,9 @@ main = do
|
||||
}
|
||||
env = Env
|
||||
{ _eventsChan = eventQueue
|
||||
, _windowObject = window
|
||||
, _zDistClosest = zDistClosest
|
||||
, _zDistFarthest = zDistFarthest
|
||||
--, _renderer = renderer
|
||||
--, envFont = font
|
||||
, _windowObject = window'
|
||||
, _zDistClosest = zDistClosest'
|
||||
, _zDistFarthest = zDistFarthest'
|
||||
}
|
||||
state = State
|
||||
{ _window = WindowState
|
||||
@ -188,8 +170,8 @@ main = do
|
||||
{ _arrowsPressed = aks
|
||||
}
|
||||
, _gl = GLState
|
||||
{ _glMap = glMap
|
||||
, _glHud = glHud
|
||||
{ _glMap = glMap'
|
||||
, _glHud = glHud'
|
||||
, _glRenderbuffer = renderBuffer
|
||||
, _glFramebuffer = frameBuffer
|
||||
}
|
||||
@ -203,8 +185,8 @@ main = do
|
||||
|
||||
putStrLn "init done."
|
||||
uncurry mappend <$> evalRWST (adjustWindow >> run) env state
|
||||
putStrLn "shutdown complete."
|
||||
|
||||
putStrLn "shutdown complete."
|
||||
|
||||
--SDL.glDeleteContext mainGlContext
|
||||
--SDL.destroyRenderer renderer
|
||||
--destroyWindow window
|
||||
@ -214,31 +196,28 @@ main = do
|
||||
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
|
||||
(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
|
||||
when (state ^. ui . uiHasChanged) prepareGUI
|
||||
liftIO $ do
|
||||
--bind renderbuffer and set sample 0 as target
|
||||
--GL.bindRenderbuffer GL.Renderbuffer GL.$= rb
|
||||
--GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject
|
||||
--GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject
|
||||
--checkError "bind renderbuffer"
|
||||
|
||||
--checkError "clear renderbuffer"
|
||||
@ -251,7 +230,7 @@ draw = do
|
||||
|
||||
-- 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
|
||||
@ -260,14 +239,14 @@ draw = do
|
||||
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"
|
||||
@ -314,7 +293,8 @@ draw = do
|
||||
checkError "beforeDraw"
|
||||
|
||||
glPatchParameteri gl_PATCH_VERTICES 3
|
||||
glPolygonMode gl_FRONT gl_LINE
|
||||
|
||||
GL.cullFace GL.$= Just GL.Front
|
||||
|
||||
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
|
||||
checkError "draw map"
|
||||
@ -345,11 +325,11 @@ draw = do
|
||||
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
|
||||
|
||||
@ -393,14 +373,14 @@ run = do
|
||||
| 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
|
||||
let
|
||||
multc = cos $ state ^. camera.yAngle
|
||||
mults = sin $ state ^. camera.yAngle
|
||||
modx x' = x' - 0.2 * kxrot * multc
|
||||
@ -419,23 +399,24 @@ run = do
|
||||
-}
|
||||
|
||||
mt <- liftIO $ do
|
||||
let double = fromRational.toRational :: (Real a) => a -> Double
|
||||
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"]
|
||||
title <- return $ unwords ["Pioneers @ ",show ((round . double $ 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
|
||||
shouldClose' <- return $ state ^. window.shouldClose
|
||||
unless shouldClose' run
|
||||
|
||||
getArrowMovement :: Pioneers (Int, Int)
|
||||
getArrowMovement = do
|
||||
state <- get
|
||||
aks <- return $ state ^. (keyboard.arrowsPressed)
|
||||
let
|
||||
aks <- return $ state ^. (keyboard.arrowsPressed)
|
||||
let
|
||||
horz = left' + right'
|
||||
vert = up'+down'
|
||||
left' = if aks ^. left then -1 else 0
|
||||
@ -447,7 +428,6 @@ getArrowMovement = do
|
||||
adjustWindow :: Pioneers ()
|
||||
adjustWindow = do
|
||||
state <- get
|
||||
env <- ask
|
||||
let fbWidth = state ^. window.width
|
||||
fbHeight = state ^. window.height
|
||||
fov = 90 --field of view
|
||||
@ -466,7 +446,7 @@ adjustWindow = do
|
||||
renderBuffer <- GL.genObjectName
|
||||
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
||||
GL.renderbufferStorage
|
||||
GL.Renderbuffer -- use the only available renderbuffer
|
||||
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
|
||||
@ -521,7 +501,7 @@ processEvent e = do
|
||||
_ ->
|
||||
return ()
|
||||
--liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
|
||||
Keyboard movement _ isRepeated key -> --up/down window(ignored) true/false actualKey
|
||||
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
|
||||
@ -551,7 +531,7 @@ processEvent e = do
|
||||
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
||||
_ ->
|
||||
return ()
|
||||
MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do
|
||||
MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do
|
||||
state <- get
|
||||
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
|
||||
modify $ (mouse.isDragging .~ True)
|
||||
@ -559,10 +539,10 @@ processEvent e = do
|
||||
. (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) ->
|
||||
MouseButton _ _{-mouseId-} button state (SDL.Position x y) ->
|
||||
case button of
|
||||
LeftButton -> do
|
||||
let pressed = state == Pressed
|
||||
@ -577,10 +557,9 @@ processEvent e = do
|
||||
when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
|
||||
_ ->
|
||||
return ()
|
||||
MouseWheel _ mouseId hscroll vscroll -> do
|
||||
env <- ask
|
||||
MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do
|
||||
state <- get
|
||||
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user