Misc movement

- Scrollwheel now zooms in/out
- Arrow-Keys now move map correctly
- removed most Debug-Output

src/Main.hs

@@ -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,
+                                                       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 Text.PrettyPrint
-import Data.Distributive (distribute)
 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           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
     { 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
+    --- 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
     , 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
@@ -235,6 +246,7 @@ run = do
     -- 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  = 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
-              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
           put $ state
             { stateXAngle = newXAngle
@@ -260,11 +269,25 @@ 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)
+            { 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
                      }
         
     {-
@@ -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,9 +422,8 @@ draw :: Pioneer ()
 draw = do
     env   <- ask
     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 vmat)  = shdrViewMatIndex state
         vi       = shdrVertexIndex      state
@@ -405,6 +432,9 @@ draw = do
         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 = 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 ->
               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
+    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
         x1n = if x1 then   1  else 0
         y0n = if y0 then (-1) else 0

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]
+getCam :: (Double, Double) -- ^ Target in x/z-Plane
-lookAt_ at eye up =
+          -> Double        -- ^ Distance from Target
-        map (fromRational . toRational) [
+          -> Double        -- ^ Angle around X-Axis (angle down/up)
-         xx, yx, zx, 0,
+          -> Double        -- ^ Angle around Y-Axis (angle left/right)
-         xy, yy, zy, 0,
+          -> M44 CFloat
-         xz, yz, zz, 0,
+
-         -(x *. eye), -(y *. eye), -(z *. eye), 1
+getCam (x',z') dist' xa' ya' = lookAt (cpos ^+^ at') at' up
-        ]
                      where
-                z@(zx,zy,zz) = normal (at .- eye)
+                        at'   = V3 x 0 z
-                x@(xx,xy,xz) = normal (up *.* z)
+                        cpos  = crot !* (V3 0 0 (-dist))
-                y@(yx,yy,yz) = z *.* x
+                        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'
+                        
+                        
+                        
+                        
+                        
+                        
+                        
+                        
+                        
+                        
                         
-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