From 8622881a134d272e11abe6036956bc570911e39c Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sun, 5 Jan 2014 20:23:22 +0100 Subject: [PATCH] Misc movement - Scrollwheel now zooms in/out - Arrow-Keys now move map correctly - removed most Debug-Output --- src/Main.hs | 151 +++++++++++++++++++++++++-------------------- src/Render/Misc.hs | 133 +++++++++++---------------------------- 2 files changed, 120 insertions(+), 164 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 6921cf3..0094e2a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,25 +3,33 @@ module Main (main) where -------------------------------------------------------------------------------- -import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue) -import Control.Monad (unless, when, void) -import Control.Monad.RWS.Strict (RWST, ask, asks, evalRWST, get, liftIO, modify, put) -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 Control.Concurrent.STM (TQueue, atomically, + newTQueueIO, + tryReadTQueue, + writeTQueue) +import Control.Monad (unless, void, when) +import Control.Monad.RWS.Strict (RWST, ask, asks, + evalRWST, get, liftIO, + modify, put) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Distributive (distribute) +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 Graphics.Rendering.OpenGL.Raw.Core31 -import qualified Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.Rendering.OpenGL.Raw.Core31 +import qualified Graphics.UI.GLFW as GLFW -import Map.Map -import Render.Render (initShader, initRendering) -import Render.Misc (up, createFrustum, checkError, lookAt) +import Map.Map +import Render.Misc (checkError, + createFrustum, getCam, + lookAt, up) +import Render.Render (initRendering, + initShader) -------------------------------------------------------------------------------- @@ -37,9 +45,9 @@ data Env = Env data State = State { stateWindowWidth :: !Int , stateWindowHeight :: !Int + --- IO , stateXAngle :: !Double , stateYAngle :: !Double - , stateZAngle :: !Double , stateZDist :: !Double , stateMouseDown :: !Bool , stateDragging :: !Bool @@ -47,16 +55,18 @@ data State = State , stateDragStartY :: !Double , stateDragStartXAngle :: !Double , stateDragStartYAngle :: !Double + , statePositionX :: !Double + , statePositionY :: !Double , stateFrustum :: !(M44 CFloat) - -- pointer to bindings for locations inside the compiled shader - -- mutable because shaders may be changed in the future. + --- 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 , shdrProjMatIndex :: !GL.UniformLocation , shdrViewMatIndex :: !GL.UniformLocation , shdrModelMatIndex :: !GL.UniformLocation - -- the map + --- the map , stateMap :: !GL.BufferObject , mapVert :: !GL.NumArrayIndices } @@ -134,8 +144,9 @@ main = do , stateWindowHeight = fbHeight , stateXAngle = pi/6 , stateYAngle = pi/2 - , stateZAngle = 0 , stateZDist = 10 + , statePositionX = 5 + , statePositionY = 5 , stateMouseDown = False , stateDragging = False , stateDragStartX = 0 @@ -233,8 +244,9 @@ run = do processEvents -- update State - + state <- get + -- change in camera-angle if stateDragging state then do let sodx = stateDragStartX state @@ -244,15 +256,12 @@ 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 = curb 0 (0.45*pi) newXAngle' newXAngle' = sodxa + mxrot/100 - newYAngle = if newYAngle' > pi then newYAngle'-2*pi else - if newYAngle' < -pi then newYAngle'+2*pi else - newYAngle' + newYAngle + | newYAngle' > pi = newYAngle' - 2 * pi + | newYAngle' < (-pi) = newYAngle' + 2 * pi + | otherwise = newYAngle' newYAngle' = sodya + myrot/100 put $ state { stateXAngle = newXAngle @@ -260,18 +269,32 @@ run = do } -- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle] else do - (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 put $ state - { stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot) - , stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot) + { stateXAngle = stateXAngle state + (2 * jxrot) + , 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 modify $ \s -> s - { + { } -} @@ -358,13 +381,12 @@ processEvent ev = env <- ask modify $ \s -> s { stateZDist = - let zDist' = stateZDist s + realToFrac (negate $ y / 2) + let zDist' = stateZDist s + realToFrac (negate $ y) in curb (envZDistClosest env) (envZDistFarthest env) zDist' } adjustWindow (EventKey win k scancode ks mk) -> do - printEvent "key" [show k, show scancode, show ks, showModifierKeys mk] when (ks == GLFW.KeyState'Pressed) $ do -- Q, Esc: exit when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $ @@ -372,6 +394,12 @@ processEvent ev = -- i: print GLFW information when (k == GLFW.Key'I) $ 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) -> printEvent "char" [show c] @@ -394,17 +422,19 @@ draw :: Pioneer () draw = do env <- ask state <- get - let xa = fromRational $ toRational $ stateXAngle state - ya = fromRational $ toRational $ stateYAngle state - za = stateZAngle state + let xa = stateXAngle state + ya = stateYAngle 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 + vi = shdrVertexIndex state + ni = shdrNormalIndex state + ci = shdrColorIndex state + numVert = mapVert state + map' = stateMap state + frust = stateFrustum state + camX = statePositionX state + camY = statePositionY state + zDist = stateZDist state liftIO $ do --(vi,GL.UniformLocation proj) <- initShader 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))) --set up camera - - 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)) - + let ! cam = getCam (camX,camY) zDist xa ya with (distribute $ cam) $ \ptr -> glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) @@ -446,10 +461,10 @@ draw = do getCursorKeyDirections :: GLFW.Window -> IO (Double, Double) getCursorKeyDirections win = do - x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up - x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down - y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left - y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right + y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up + y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down + x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left + x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right let x0n = if x0 then (-1) else 0 x1n = if x1 then 1 else 0 y0n = if y0 then (-1) else 0 @@ -627,4 +642,4 @@ joysticks = , GLFW.Joystick'14 , GLFW.Joystick'15 , GLFW.Joystick'16 - ] \ No newline at end of file + ] diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index c740b3e..93cd96d 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -75,64 +75,6 @@ createFrustum fov n' f' rat = (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) (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 lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat 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) 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) -normal x = (1.0 / (sqrt (x *. x))) .* x - -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 +getCam :: (Double, Double) -- ^ Target in x/z-Plane + -> 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' + + + + + + + + + + + + + + + +