merged .. but colors broken..
This commit is contained in:
Stefan Dresselhaus
105
src/Main.hs
105
src/Main.hs
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Main (main) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -9,15 +10,18 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Text.PrettyPrint
|
||||
import Data.Distributive (distribute)
|
||||
import Foreign (Ptr, castPtr, with)
|
||||
import Foreign.C (CFloat)
|
||||
import Linear as L
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import qualified Graphics.Rendering.OpenGL.Raw.Core31 as GLRaw
|
||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
import qualified Data.Vector.Storable as V
|
||||
|
||||
import Map.Map
|
||||
import Render.Render (initShader)
|
||||
import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError)
|
||||
import Render.Render (initShader, initRendering)
|
||||
import Render.Misc (up, createFrustum, checkError, lookAt)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@ -43,13 +47,15 @@ data State = State
|
||||
, stateDragStartY :: !Double
|
||||
, stateDragStartXAngle :: !Double
|
||||
, stateDragStartYAngle :: !Double
|
||||
, stateFrustum :: [GL.GLfloat]
|
||||
, stateFrustum :: !(M44 CFloat)
|
||||
-- pointer to bindings for locations inside the compiled shader
|
||||
-- mutable because shaders may be changed in the future.
|
||||
, shdrVertexIndex :: !GL.AttribLocation
|
||||
, shdrColorIndex :: !GL.AttribLocation
|
||||
, shdrNormalIndex :: !GL.AttribLocation
|
||||
, shdrVertexIndex :: !GL.AttribLocation
|
||||
, shdrProjMatIndex :: !GL.UniformLocation
|
||||
, shdrViewMatIndex :: !GL.UniformLocation
|
||||
, shdrModelMatIndex :: !GL.UniformLocation
|
||||
-- the map
|
||||
, stateMap :: !GL.BufferObject
|
||||
, mapVert :: !GL.NumArrayIndices
|
||||
@ -105,13 +111,13 @@ main = do
|
||||
|
||||
(fbWidth, fbHeight) <- GLFW.getFramebufferSize win
|
||||
|
||||
initRendering
|
||||
--generate map vertices
|
||||
(mapBuffer, vert) <- getMapBufferObject
|
||||
(ci, ni, vi, pi) <- initShader
|
||||
(ci, ni, vi, pri, vii, mi) <- initShader
|
||||
|
||||
let zDistClosest = 10
|
||||
zDistFarthest = zDistClosest + 20
|
||||
zDist = zDistClosest + ((zDistFarthest - zDistClosest) / 2)
|
||||
fov = 90 --field of view
|
||||
near = 1 --near plane
|
||||
far = 100 --far plane
|
||||
@ -126,8 +132,8 @@ main = do
|
||||
state = State
|
||||
{ stateWindowWidth = fbWidth
|
||||
, stateWindowHeight = fbHeight
|
||||
, stateXAngle = 0
|
||||
, stateYAngle = 0
|
||||
, stateXAngle = pi/6
|
||||
, stateYAngle = pi/2
|
||||
, stateZAngle = 0
|
||||
, stateZDist = 10
|
||||
, stateMouseDown = False
|
||||
@ -136,10 +142,12 @@ main = do
|
||||
, stateDragStartY = 0
|
||||
, stateDragStartXAngle = 0
|
||||
, stateDragStartYAngle = 0
|
||||
, shdrColorIndex = ci
|
||||
, shdrNormalIndex = ni
|
||||
, shdrVertexIndex = vi
|
||||
, shdrProjMatIndex = pi
|
||||
, shdrNormalIndex = ni
|
||||
, shdrColorIndex = ci
|
||||
, shdrProjMatIndex = pri
|
||||
, shdrViewMatIndex = vii
|
||||
, shdrModelMatIndex = mi
|
||||
, stateMap = mapBuffer
|
||||
, mapVert = vert
|
||||
, stateFrustum = frust
|
||||
@ -210,8 +218,7 @@ charCallback tc win c = atomically $ writeTQueue tc $ EventC
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
runDemo :: Env -> State -> IO ()
|
||||
runDemo env state = do
|
||||
void $ evalRWST (adjustWindow >> run) env state
|
||||
runDemo env state = void $ evalRWST (adjustWindow >> run) env state
|
||||
|
||||
run :: Pioneer ()
|
||||
run = do
|
||||
@ -221,13 +228,12 @@ run = do
|
||||
draw
|
||||
liftIO $ do
|
||||
GLFW.swapBuffers win
|
||||
GL.flush -- not necessary, but someone recommended it
|
||||
GLFW.pollEvents
|
||||
GL.finish
|
||||
-- getEvents & process
|
||||
processEvents
|
||||
|
||||
-- update State
|
||||
|
||||
state <- get
|
||||
if stateDragging state
|
||||
then do
|
||||
@ -238,10 +244,21 @@ run = do
|
||||
(x, y) <- liftIO $ GLFW.getCursorPos win
|
||||
let myrot = (x - sodx) / 2
|
||||
mxrot = (y - sody) / 2
|
||||
-- newXAngle = if newXAngle' > 2*pi then 2*pi else
|
||||
newXAngle = if newXAngle' > 0.45*pi then 0.45*pi else
|
||||
-- if newXAngle' < -2*pi then -2*pi else
|
||||
if newXAngle' < 0 then 0 else
|
||||
newXAngle'
|
||||
newXAngle' = sodxa + mxrot/100
|
||||
newYAngle = if newYAngle' > pi then newYAngle'-2*pi else
|
||||
if newYAngle' < -pi then newYAngle'+2*pi else
|
||||
newYAngle'
|
||||
newYAngle' = sodya + myrot/100
|
||||
put $ state
|
||||
{ stateXAngle = sodxa + mxrot
|
||||
, stateYAngle = sodya + myrot
|
||||
{ stateXAngle = newXAngle
|
||||
, stateYAngle = newYAngle
|
||||
}
|
||||
-- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle]
|
||||
else do
|
||||
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
|
||||
(jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
|
||||
@ -249,6 +266,7 @@ run = do
|
||||
{ stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot)
|
||||
, stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot)
|
||||
}
|
||||
|
||||
{-
|
||||
--modify the state with all that happened in mt time.
|
||||
mt <- liftIO GLFW.getTime
|
||||
@ -376,37 +394,44 @@ draw :: Pioneer ()
|
||||
draw = do
|
||||
env <- ask
|
||||
state <- get
|
||||
let xa = stateXAngle state
|
||||
ya = stateYAngle state
|
||||
let xa = fromRational $ toRational $ stateXAngle state
|
||||
ya = fromRational $ toRational $ stateYAngle state
|
||||
za = stateZAngle state
|
||||
(GL.UniformLocation proj) = shdrProjMatIndex state
|
||||
ci = shdrColorIndex state
|
||||
ni = shdrNormalIndex state
|
||||
(GL.UniformLocation proj) = shdrProjMatIndex state
|
||||
(GL.UniformLocation vmat) = shdrViewMatIndex state
|
||||
vi = shdrVertexIndex state
|
||||
ni = shdrNormalIndex state
|
||||
ci = shdrColorIndex state
|
||||
numVert = mapVert state
|
||||
map' = stateMap state
|
||||
frust = stateFrustum state
|
||||
liftIO $ do
|
||||
GLRaw.glClearDepth 1.0
|
||||
GLRaw.glDisable GLRaw.gl_CULL_FACE
|
||||
--lookAtUniformMatrix4fv (0.0,0.0,0.0) (0, 15, 0) up frust proj 1
|
||||
--(vi,GL.UniformLocation proj) <- initShader
|
||||
GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1
|
||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
||||
--set up projection (= copy from state)
|
||||
with (distribute $ frust) $ \ptr ->
|
||||
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
|
||||
-------------
|
||||
--set up camera
|
||||
|
||||
let fov = 90
|
||||
s = recip (tan $ fov * 0.5 * pi / 180)
|
||||
f = 1000
|
||||
n = 1
|
||||
let ! cam = lookAt (cpos ^+^ at') at' up
|
||||
|
||||
let perspective = V.fromList [ s, 0, 0, 0
|
||||
, 0, s, 0, 0
|
||||
, 0, 0, -(f/(f - n)), -1
|
||||
, 0, 0, -((f*n)/(f-n)), 0
|
||||
]
|
||||
at' = V3 5 0 5
|
||||
upmap = (fromQuaternion $
|
||||
axisAngle (V3 0 1 0) (ya::CFloat) :: M33 CFloat)
|
||||
!* (V3 1 0 0)
|
||||
crot' = (
|
||||
(fromQuaternion $
|
||||
axisAngle upmap (xa::CFloat))
|
||||
!*!
|
||||
(fromQuaternion $
|
||||
axisAngle (V3 0 1 0) (ya::CFloat))
|
||||
) :: M33 CFloat
|
||||
cpos = crot' !* (V3 0 0 (-10))
|
||||
|
||||
V.unsafeWith perspective $ \ptr -> GLRaw.glUniformMatrix4fv proj 1 0 ptr
|
||||
|
||||
---------------
|
||||
with (distribute $ cam) $ \ptr ->
|
||||
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
|
||||
GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
|
||||
GL.vertexAttribPointer ci GL.$= fgColorIndex
|
||||
|
||||
Reference in New Issue
Block a user