Misc movement
- Scrollwheel now zooms in/out - Arrow-Keys now move map correctly - removed most Debug-Output
This commit is contained in:
parent
a1968ca31a
commit
8622881a13
151
src/Main.hs
151
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
|
||||
]
|
||||
]
|
||||
|
||||
@ -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'
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user