Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Misc movement

Browse Source 
- Scrollwheel now zooms in/out
- Arrow-Keys now move map correctly
- removed most Debug-Output
This commit is contained in:
Nicole Dresselhaus 2014-01-05 20:23:22 +01:00
parent a1968ca31a
commit 8622881a13
2 changed files with 120 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
src/Main.hs
View File

@ -3,25 +3,33 @@ module Main (main) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue) import Control.Concurrent.STM (TQueue, atomically,
import Control.Monad (unless, when, void) newTQueueIO,
import Control.Monad.RWS.Strict (RWST, ask, asks, evalRWST, get, liftIO, modify, put) tryReadTQueue,
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) writeTQueue)
import Data.List (intercalate) import Control.Monad (unless, void, when)
import Data.Maybe (catMaybes) import Control.Monad.RWS.Strict (RWST, ask, asks,
import Text.PrettyPrint evalRWST, get, liftIO,
import Data.Distributive (distribute) modify, put)
import Foreign (Ptr, castPtr, with) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Foreign.C (CFloat) import Data.Distributive (distribute)
import Linear as L import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Foreign (Ptr, castPtr, with)
import Foreign.C (CFloat)
import Linear as L
import Text.PrettyPrint
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.Rendering.OpenGL.Raw.Core31 import Graphics.Rendering.OpenGL.Raw.Core31
import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.UI.GLFW as GLFW
import Map.Map import Map.Map
import Render.Render (initShader, initRendering) import Render.Misc (checkError,
import Render.Misc (up, createFrustum, checkError, lookAt) createFrustum, getCam,
lookAt, up)
import Render.Render (initRendering,
initShader)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -37,9 +45,9 @@ data Env = Env
data State = State data State = State
{ stateWindowWidth :: !Int { stateWindowWidth :: !Int
, stateWindowHeight :: !Int , stateWindowHeight :: !Int
--- IO
, stateXAngle :: !Double , stateXAngle :: !Double
, stateYAngle :: !Double , stateYAngle :: !Double
, stateZAngle :: !Double
, stateZDist :: !Double , stateZDist :: !Double
, stateMouseDown :: !Bool , stateMouseDown :: !Bool
, stateDragging :: !Bool , stateDragging :: !Bool
@ -47,16 +55,18 @@ data State = State
, stateDragStartY :: !Double , stateDragStartY :: !Double
, stateDragStartXAngle :: !Double , stateDragStartXAngle :: !Double
, stateDragStartYAngle :: !Double , stateDragStartYAngle :: !Double
, statePositionX :: !Double
, statePositionY :: !Double
, stateFrustum :: !(M44 CFloat) , stateFrustum :: !(M44 CFloat)
-- pointer to bindings for locations inside the compiled shader --- pointer to bindings for locations inside the compiled shader
-- mutable because shaders may be changed in the future. --- mutable because shaders may be changed in the future.
, shdrVertexIndex :: !GL.AttribLocation , shdrVertexIndex :: !GL.AttribLocation
, shdrColorIndex :: !GL.AttribLocation , shdrColorIndex :: !GL.AttribLocation
, shdrNormalIndex :: !GL.AttribLocation , shdrNormalIndex :: !GL.AttribLocation
, shdrProjMatIndex :: !GL.UniformLocation , shdrProjMatIndex :: !GL.UniformLocation
, shdrViewMatIndex :: !GL.UniformLocation , shdrViewMatIndex :: !GL.UniformLocation
, shdrModelMatIndex :: !GL.UniformLocation , shdrModelMatIndex :: !GL.UniformLocation
-- the map --- the map
, stateMap :: !GL.BufferObject , stateMap :: !GL.BufferObject
, mapVert :: !GL.NumArrayIndices , mapVert :: !GL.NumArrayIndices
} }
@ -134,8 +144,9 @@ main = do
, stateWindowHeight = fbHeight , stateWindowHeight = fbHeight
, stateXAngle = pi/6 , stateXAngle = pi/6
, stateYAngle = pi/2 , stateYAngle = pi/2
, stateZAngle = 0
, stateZDist = 10 , stateZDist = 10
, statePositionX = 5
, statePositionY = 5
, stateMouseDown = False , stateMouseDown = False
, stateDragging = False , stateDragging = False
, stateDragStartX = 0 , stateDragStartX = 0
@ -235,6 +246,7 @@ run = do
-- update State -- update State
state <- get state <- get
-- change in camera-angle
if stateDragging state if stateDragging state
then do then do
let sodx = stateDragStartX state let sodx = stateDragStartX state
@ -244,15 +256,12 @@ run = do
(x, y) <- liftIO $ GLFW.getCursorPos win (x, y) <- liftIO $ GLFW.getCursorPos win
let myrot = (x - sodx) / 2 let myrot = (x - sodx) / 2
mxrot = (y - sody) / 2 mxrot = (y - sody) / 2
-- newXAngle = if newXAngle' > 2*pi then 2*pi else newXAngle = curb 0 (0.45*pi) newXAngle'
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 newXAngle' = sodxa + mxrot/100
newYAngle = if newYAngle' > pi then newYAngle'-2*pi else newYAngle
if newYAngle' < -pi then newYAngle'+2*pi else | newYAngle' > pi = newYAngle' - 2 * pi
newYAngle' | newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle'
newYAngle' = sodya + myrot/100 newYAngle' = sodya + myrot/100
put $ state put $ state
{ stateXAngle = newXAngle { stateXAngle = newXAngle
@ -260,13 +269,27 @@ run = do
} }
-- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle] -- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle]
else do else do
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
(jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
put $ state put $ state
{ stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot) { stateXAngle = stateXAngle state + (2 * jxrot)
, stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot) , stateYAngle = stateYAngle state + (2 * jyrot)
} }
-- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
modify $ \s ->
let
multc = cos $ stateYAngle s
mults = sin $ stateYAngle s
in
s {
statePositionX = statePositionX s - 0.2 * kxrot * multc
- 0.2 * kyrot * mults
, statePositionY = statePositionY s + 0.2 * kxrot * mults
- 0.2 * kyrot * multc
}
{- {-
--modify the state with all that happened in mt time. --modify the state with all that happened in mt time.
mt <- liftIO GLFW.getTime mt <- liftIO GLFW.getTime
@ -358,13 +381,12 @@ processEvent ev =
env <- ask env <- ask
modify $ \s -> s modify $ \s -> s
{ stateZDist = { stateZDist =
let zDist' = stateZDist s + realToFrac (negate $ y / 2) let zDist' = stateZDist s + realToFrac (negate $ y)
in curb (envZDistClosest env) (envZDistFarthest env) zDist' in curb (envZDistClosest env) (envZDistFarthest env) zDist'
} }
adjustWindow adjustWindow
(EventKey win k scancode ks mk) -> do (EventKey win k scancode ks mk) -> do
printEvent "key" [show k, show scancode, show ks, showModifierKeys mk]
when (ks == GLFW.KeyState'Pressed) $ do when (ks == GLFW.KeyState'Pressed) $ do
-- Q, Esc: exit -- Q, Esc: exit
when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $ when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $
@ -372,6 +394,12 @@ processEvent ev =
-- i: print GLFW information -- i: print GLFW information
when (k == GLFW.Key'I) $ when (k == GLFW.Key'I) $
liftIO $ printInformation win liftIO $ printInformation win
unless (elem k [GLFW.Key'Up
,GLFW.Key'Down
,GLFW.Key'Left
,GLFW.Key'Right
]) $ do
printEvent "key" [show k, show scancode, show ks, showModifierKeys mk]
(EventChar _ c) -> (EventChar _ c) ->
printEvent "char" [show c] printEvent "char" [show c]
@ -394,17 +422,19 @@ draw :: Pioneer ()
draw = do draw = do
env <- ask env <- ask
state <- get state <- get
let xa = fromRational $ toRational $ stateXAngle state let xa = stateXAngle state
ya = fromRational $ toRational $ stateYAngle state ya = stateYAngle state
za = stateZAngle state
(GL.UniformLocation proj) = shdrProjMatIndex state (GL.UniformLocation proj) = shdrProjMatIndex state
(GL.UniformLocation vmat) = shdrViewMatIndex state (GL.UniformLocation vmat) = shdrViewMatIndex state
vi = shdrVertexIndex state vi = shdrVertexIndex state
ni = shdrNormalIndex state ni = shdrNormalIndex state
ci = shdrColorIndex state ci = shdrColorIndex state
numVert = mapVert state numVert = mapVert state
map' = stateMap state map' = stateMap state
frust = stateFrustum state frust = stateFrustum state
camX = statePositionX state
camY = statePositionY state
zDist = stateZDist state
liftIO $ do liftIO $ do
--(vi,GL.UniformLocation proj) <- initShader --(vi,GL.UniformLocation proj) <- initShader
GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1 GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1
@ -414,22 +444,7 @@ draw = do
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
--set up camera --set up camera
let ! cam = getCam (camX,camY) zDist xa ya
let ! cam = lookAt (cpos ^+^ at') at' up
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))
with (distribute $ cam) $ \ptr -> with (distribute $ cam) $ \ptr ->
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
@ -446,10 +461,10 @@ draw = do
getCursorKeyDirections :: GLFW.Window -> IO (Double, Double) getCursorKeyDirections :: GLFW.Window -> IO (Double, Double)
getCursorKeyDirections win = do getCursorKeyDirections win = do
x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up
x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down
y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left
y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right
let x0n = if x0 then (-1) else 0 let x0n = if x0 then (-1) else 0
x1n = if x1 then 1 else 0 x1n = if x1 then 1 else 0
y0n = if y0 then (-1) else 0 y0n = if y0 then (-1) else 0

125
src/Render/Misc.hs
View File

@ -75,64 +75,6 @@ createFrustum fov n' f' rat =
(V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n))))
(V4 0 0 (-1) 0) (V4 0 0 (-1) 0)
lookAtUniformMatrix4fv :: (Double, Double, Double) --origin
-> (Double, Double, Double) --camera-pos
-> (Double, Double, Double) --up
-> [GLfloat] --frustum
-> GLint -> GLsizei -> IO () --rest of GL-call
lookAtUniformMatrix4fv o c u frust num size = allocaArray 16 $ \projMat ->
do
pokeArray projMat $
[0.1, 0, 0, 0,
0, 0, 0.1, 0,
0, 0.1, 0, 0,
0, 0, 0, 1
]
--(lookAt o c u) >< frust
glUniformMatrix4fv num size 1 projMat
infixl 5 ><
(><) :: [GLfloat] -> [GLfloat] -> [GLfloat]
[ aa, ab, ac, ad,
ba, bb, bc, bd,
ca, cb, cc, cd,
da, db, dc, dd
] ><
[
xx, xy, xz, xw,
yx, yy, yz, yw,
zx, zy, zz, zw,
wx, wy, wz, ww
] = [
--first row
aa*xx + ab*yx + ac*zx + ad * wx,
aa*xy + ab*yy + ac*zy + ad * wy,
aa*xz + ab*yz + ac*zz + ad * wz,
aa*xw + ab*yw + ac*zw + ad * ww,
--second row
ba*xx + bb*yx + bc*zx + bd * wx,
ba*xy + bb*yy + bc*zy + bd * wy,
ba*xz + bb*yz + bc*zz + bd * wz,
ba*xw + bb*yw + bc*zw + bd * ww,
--third row
ca*xx + cb*yx + cc*zx + cd * wx,
ca*xy + cb*yy + cc*zy + cd * wy,
ca*xz + cb*yz + cc*zz + cd * wz,
ca*xw + cb*yw + cc*zw + cd * ww,
--fourth row
da*xx + db*yx + dc*zx + dd * wx,
da*xy + db*yy + dc*zy + dd * wy,
da*xz + db*yz + dc*zz + dd * wz,
da*xw + db*yw + dc*zw + dd * ww
]
_ >< _ = error "non-conformat matrix-multiplication"
-- from vmath.h -- from vmath.h
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
lookAt eye@(V3 ex ey ez) center up = lookAt eye@(V3 ex ey ez) center up =
@ -146,43 +88,42 @@ lookAt eye@(V3 ex ey ez) center up =
x@(V3 xx xy xz) = normalize (cross up z) x@(V3 xx xy xz) = normalize (cross up z)
y@(V3 yx yy yz) = normalize (cross z x) y@(V3 yx yy yz) = normalize (cross z x)
-- generates 4x4-Projection-Matrix
lookAt_ :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat]
lookAt_ at eye up =
map (fromRational . toRational) [
xx, yx, zx, 0,
xy, yy, zy, 0,
xz, yz, zz, 0,
-(x *. eye), -(y *. eye), -(z *. eye), 1
]
where
z@(zx,zy,zz) = normal (at .- eye)
x@(xx,xy,xz) = normal (up *.* z)
y@(yx,yy,yz) = z *.* x
normal :: (Double, Double, Double) -> (Double, Double, Double) getCam :: (Double, Double) -- ^ Target in x/z-Plane
normal x = (1.0 / (sqrt (x *. x))) .* x -> Double -- ^ Distance from Target
-> Double -- ^ Angle around X-Axis (angle down/up)
-> Double -- ^ Angle around Y-Axis (angle left/right)
-> M44 CFloat
getCam (x',z') dist' xa' ya' = lookAt (cpos ^+^ at') at' up
where
at' = V3 x 0 z
cpos = crot !* (V3 0 0 (-dist))
crot = (
(fromQuaternion $ axisAngle upmap (xa::CFloat))
!*!
(fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat))
) ::M33 CFloat
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
!* (V3 1 0 0)
x = realToFrac x'
z = realToFrac z'
dist = realToFrac dist'
xa = realToFrac xa'
ya = realToFrac ya'
infixl 5 .*
--scaling
(.*) :: Double -> (Double, Double, Double) -> (Double, Double, Double)
a .* (x,y,z) = (a*x, a*y, a*z)
infixl 5 .-
--subtraction
(.-) :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double)
(a,b,c) .- (x,y,z) = (a-x, b-y, c-z)
infixl 5 *.*
--cross-product for left-hand-system
(*.*) :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double)
(a,b,c) *.* (x,y,z) = ( c*y - b*z
, a*z - c*x
, b*x - a*y
)
infixl 5 *.
--dot-product
(*.) :: (Double, Double, Double) -> (Double, Double, Double) -> Double
(a,b,c) *. (x,y,z) = a*x + b*y + c*z