aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Graphics/Glyph/GLMath.hs367
-rw-r--r--Graphics/Glyph/Util.hs2
-rw-r--r--Graphics/SDL/SDLHelp.hs2
-rw-r--r--Resources.hs110
-rw-r--r--Terralloc.cabal2
-rw-r--r--maps/svalbard_height.pngbin2908 -> 10361 bytes
6 files changed, 283 insertions, 200 deletions
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
index b1df4c5..361ca16 100644
--- a/Graphics/Glyph/GLMath.hs
+++ b/Graphics/Glyph/GLMath.hs
@@ -1,170 +1,203 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Graphics.Glyph.GLMath where
- import Graphics.Glyph.Mat4
- import qualified Graphics.Rendering.OpenGL as GL
- import Graphics.Rendering.OpenGL (GLfloat,Uniform,Vertex3(..),uniform,UniformComponent)
- import Data.Angle
- import Data.Maybe
- import Debug.Trace
-
- data Vec2 a = Vec2 (a,a) deriving Show
- data Vec3 a = Vec3 (a,a,a) deriving Show
- data Vec4 a = Vec4 (a,a,a,a) deriving Show
-
- instance UniformComponent a => Uniform (Vec3 a) where
- uniform loc = GL.makeStateVar
- (do
- (Vertex3 x y z) <-
- GL.get (uniform loc)
- return (Vec3 (x,y,z)) )
- (\(Vec3 (x,y,z)) -> uniform loc GL.$= Vertex3 x y z)
- uniformv _ = undefined
-
- instance UniformComponent a => Uniform (Vec4 a) where
- uniform loc = GL.makeStateVar
- (do
- (GL.Vertex4 x y z w) <-
- GL.get (uniform loc)
- return (Vec4 (x,y,z,w)) )
- (\(Vec4 (x,y,z,w)) -> uniform loc GL.$= GL.Vertex4 x y z w)
- uniformv _ = undefined
-
- class (Floating flT) => Vector flT b where
- (<+>) :: b flT -> b flT -> b flT
- (<->) :: b flT -> b flT -> b flT
- norm :: b flT -> flT
- normalize :: b flT -> b flT
- vDot :: b flT -> b flT -> flT
- vScale :: flT -> b flT -> b flT
- vNegate :: b flT -> b flT
-
-
- (<.>) :: (Vector a b) => b a -> b a -> a
- (<.>) = vDot
-
- (|||) :: (Vector a b) => b a -> a
- (|||) = norm
-
- instance (Floating flT) => Vector flT Vec2 where
- (<+>) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a+c,b+d)
- (<->) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a-c,b-d)
- vDot (Vec2 (a,b)) (Vec2 (c,d)) = a * c + b * d
- vScale c (Vec2 (a,b)) = Vec2 (a*c,b*c)
- norm (Vec2 (a,b)) = sqrt (a*a + b*b)
- normalize vec@(Vec2 (a,b)) =
- let n = norm vec in Vec2 (a/n,b/n)
- vNegate (Vec2 (a,b)) = Vec2 (-a,-b)
-
- instance (Floating flT) => Vector flT Vec3 where
- (<+>) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a+d,b+e,c+f)
- (<->) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a-d,b-e,c-f)
- vDot (Vec3 (a,b,c)) (Vec3 (d,e,f)) = a * d + b * e + c * f
- vScale x (Vec3 (a,b,c)) = Vec3 (a*x,b*x,c*x)
- norm (Vec3 (a,b,c)) = sqrt (a*a + b*b + c*c)
- normalize vec@(Vec3 (a,b,c)) =
- let n = norm vec in Vec3 (a/n,b/n,c/n)
- vNegate (Vec3 (a,b,c)) = Vec3 (-a,-b,-c)
-
- instance (Floating flT) => Vector flT Vec4 where
- (<+>) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a+d,b+e,c+f,g+h)
- (<->) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a-d,b-e,c-f,g-h)
- vDot (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = a * d + b * e + c * f + g * h
- vScale x (Vec4 (a,b,c,d)) = Vec4 (a*x,b*x,c*x,d*x)
- norm (Vec4 (a,b,c,d)) = sqrt (a*a + b*b + c*c + d*d)
- normalize vec@(Vec4 (a,b,c,d)) =
- let n = norm vec in Vec4 (a/n,b/n,c/n,d/n)
- vNegate (Vec4 (a,b,c,d)) = Vec4 (-a,-b,-c,-d)
-
- cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
- cross (Vec3 (u1,u2,u3)) (Vec3 (v1,v2,v3)) =
- Vec3 ( u2*v3 - u3*v2,
- u3*v1 - u1*v3,
- u1*v2 - u2*v1 )
- (×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
- (×) = cross
-
- lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
- lookAtMatrix e c u =
- let f@(Vec3 (fx,fy,fz)) = normalize (c <-> e)
- s@(Vec3 (sx,sy,sz)) = normalize (f × u)
- u'@(Vec3 (ux,uy,uz)) = s × f in
- Matrix4 (sx, ux, -fx, 0,
- sy, uy, -fy, 0,
- sz, uz, -fz, 0,
- -(s<.>e) , -(u'<.>e), f<.>e, 1 )
-
- orthoMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
- orthoMatrix top bot right left near far =
- Matrix4 (2 / (right-left), 0, 0, - (right + left) / (right - left),
- 0, 2 / (top-bot), 0, - (top+bot) / (top-bot),
- 0, 0, -2 / (far-near), - (far+near) / (far - near),
- 0, 0, 0, 1)
- perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
- {- as close to copied from glm as possible -}
- perspectiveMatrix fov asp zn zf =
- let tanHalfFovy = tangent (Degrees fov/2)
- res00 = 1 / (asp * tanHalfFovy)
- res11 = 1 / tanHalfFovy
- res22 = - (zf + zn) / (zf - zn)
- res23 = - 1
- res32 = - (2 * zf * zn) / (zf - zn) in
- trace ("res22=" ++ show res22) $
- Matrix4 (res00, 0, 0, 0,
- 0, res11, 0, 0,
- 0, 0, res22, res23,
- 0, 0, res32, 0)
-
- class VectorMatrix vecT matT where
- vTranslate :: matT -> vecT -> matT
- (-*|) :: matT -> vecT -> vecT
-
- instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
- vTranslate (Matrix3 (a00,a01,a02,
- a10,a11,a12,
- a20,a21,a22)) (Vec3 (a,b,c)) =
- Matrix3 (a00,a01,a02+a,
- a10,a11,a12+b,
- a20,a21,a22+c)
-
- (Matrix3 (a00,a01,a02,
- a10,a11,a12,
- a20,a21,a22)) -*| (Vec3 (a,b,c)) =
- Vec3 (a00 * a + a01 * b + a02 * c,
- a10 * a + a11 * b + a12 * c,
- a20 * a + a21 * b + a22 * c )
-
-
-
-
- instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
- vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
- mat -*| tmp = glslMatMul mat tmp
-
- glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
- glslMatMul (Matrix4 (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
- Vec4 ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
- v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
- v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
- v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33 )
-
- glslModelViewToNormalMatrix :: Mat4 GLfloat -> Mat3 GLfloat
- glslModelViewToNormalMatrix = fromJust.inverse.transpose.trunc4
-
- (==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
- (==>) = glslMatTranslate
- glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
- glslMatTranslate
- mat@(Matrix4 (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) vec =
- let (Vec4 (v0,v1,v2,v3)) = mat -*| vec in
- Matrix4 (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30+v0,m31+v1,m32+v2,m33+v3)
-
+import Graphics.Glyph.Mat4
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (GLfloat,Uniform,Vertex3(..),uniform,UniformComponent)
+import Data.Angle
+import Data.Maybe
+import Debug.Trace
+
+data Vec2 a = Vec2 (a,a) deriving (Show,Eq)
+data Vec3 a = Vec3 (a,a,a) deriving (Show,Eq)
+data Vec4 a = Vec4 (a,a,a,a) deriving (Show,Eq)
+
+instance UniformComponent a => Uniform (Vec3 a) where
+ uniform loc = GL.makeStateVar
+ (do
+ (Vertex3 x y z) <-
+ GL.get (uniform loc)
+ return (Vec3 (x,y,z)) )
+ (\(Vec3 (x,y,z)) -> uniform loc GL.$= Vertex3 x y z)
+ uniformv _ = undefined
+
+instance UniformComponent a => Uniform (Vec4 a) where
+ uniform loc = GL.makeStateVar
+ (do
+ (GL.Vertex4 x y z w) <-
+ GL.get (uniform loc)
+ return (Vec4 (x,y,z,w)) )
+ (\(Vec4 (x,y,z,w)) -> uniform loc GL.$= GL.Vertex4 x y z w)
+ uniformv _ = undefined
+
+class (Floating flT) => Vector flT b where
+ (<+>) :: b flT -> b flT -> b flT
+ (<->) :: b flT -> b flT -> b flT
+ norm :: b flT -> flT
+ normalize :: b flT -> b flT
+ vDot :: b flT -> b flT -> flT
+ vScale :: flT -> b flT -> b flT
+ vNegate :: b flT -> b flT
+
+
+(<.>) :: (Vector a b) => b a -> b a -> a
+(<.>) = vDot
+
+(|||) :: (Vector a b) => b a -> a
+(|||) = norm
+
+instance (Floating flT) => Vector flT Vec2 where
+ (<+>) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a+c,b+d)
+ (<->) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a-c,b-d)
+ vDot (Vec2 (a,b)) (Vec2 (c,d)) = a * c + b * d
+ vScale c (Vec2 (a,b)) = Vec2 (a*c,b*c)
+ norm (Vec2 (a,b)) = sqrt (a*a + b*b)
+ normalize vec@(Vec2 (a,b)) =
+ let n = norm vec in Vec2 (a/n,b/n)
+ vNegate (Vec2 (a,b)) = Vec2 (-a,-b)
+
+instance (Floating flT) => Vector flT Vec3 where
+ (<+>) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a+d,b+e,c+f)
+ (<->) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a-d,b-e,c-f)
+ vDot (Vec3 (a,b,c)) (Vec3 (d,e,f)) = a * d + b * e + c * f
+ vScale x (Vec3 (a,b,c)) = Vec3 (a*x,b*x,c*x)
+ norm (Vec3 (a,b,c)) = sqrt (a*a + b*b + c*c)
+ normalize vec@(Vec3 (a,b,c)) =
+ let n = norm vec in Vec3 (a/n,b/n,c/n)
+ vNegate (Vec3 (a,b,c)) = Vec3 (-a,-b,-c)
+
+instance (Floating flT) => Vector flT Vec4 where
+ (<+>) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a+d,b+e,c+f,g+h)
+ (<->) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a-d,b-e,c-f,g-h)
+ vDot (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = a * d + b * e + c * f + g * h
+ vScale x (Vec4 (a,b,c,d)) = Vec4 (a*x,b*x,c*x,d*x)
+ norm (Vec4 (a,b,c,d)) = sqrt (a*a + b*b + c*c + d*d)
+ normalize vec@(Vec4 (a,b,c,d)) =
+ let n = norm vec in Vec4 (a/n,b/n,c/n,d/n)
+ vNegate (Vec4 (a,b,c,d)) = Vec4 (-a,-b,-c,-d)
+
+cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+cross (Vec3 (u1,u2,u3)) (Vec3 (v1,v2,v3)) =
+ Vec3 ( u2*v3 - u3*v2,
+ u3*v1 - u1*v3,
+ u1*v2 - u2*v1 )
+(×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+(×) = cross
+
+lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
+lookAtMatrix e c u =
+ let f@(Vec3 (fx,fy,fz)) = normalize (c <-> e)
+ s@(Vec3 (sx,sy,sz)) = normalize (f × u)
+ u'@(Vec3 (ux,uy,uz)) = s × f in
+ Matrix4 (sx, ux, -fx, 0,
+ sy, uy, -fy, 0,
+ sz, uz, -fz, 0,
+ -(s<.>e) , -(u'<.>e), f<.>e, 1 )
+
+orthoMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
+orthoMatrix top bot right left near far =
+ Matrix4 (2 / (right-left), 0, 0, - (right + left) / (right - left),
+ 0, 2 / (top-bot), 0, - (top+bot) / (top-bot),
+ 0, 0, -2 / (far-near), - (far+near) / (far - near),
+ 0, 0, 0, 1)
+perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
+{- as close to copied from glm as possible -}
+perspectiveMatrix fov asp zn zf =
+ let tanHalfFovy = tangent (Degrees fov/2)
+ res00 = 1 / (asp * tanHalfFovy)
+ res11 = 1 / tanHalfFovy
+ res22 = - (zf + zn) / (zf - zn)
+ res23 = - 1
+ res32 = - (2 * zf * zn) / (zf - zn) in
+ trace ("res22=" ++ show res22) $
+ Matrix4 (res00, 0, 0, 0,
+ 0, res11, 0, 0,
+ 0, 0, res22, res23,
+ 0, 0, res32, 0)
+
+class VectorMatrix vecT matT where
+ vTranslate :: matT -> vecT -> matT
+ (-*|) :: matT -> vecT -> vecT
+
+instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
+ vTranslate (Matrix3 (a00,a01,a02,
+ a10,a11,a12,
+ a20,a21,a22)) (Vec3 (a,b,c)) =
+ Matrix3 (a00,a01,a02+a,
+ a10,a11,a12+b,
+ a20,a21,a22+c)
+
+ (Matrix3 (a00,a01,a02,
+ a10,a11,a12,
+ a20,a21,a22)) -*| (Vec3 (a,b,c)) =
+ Vec3 (a00 * a + a01 * b + a02 * c,
+ a10 * a + a11 * b + a12 * c,
+ a20 * a + a21 * b + a22 * c )
+
+
+
+
+instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
+ vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
+ mat -*| tmp = glslMatMul mat tmp
+
+glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
+glslMatMul (Matrix4 (m00,m01,m02,m03,
+ m10,m11,m12,m13,
+ m20,m21,m22,m23,
+ m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
+ Vec4 ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
+ v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
+ v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
+ v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33 )
+
+glslModelViewToNormalMatrix :: Mat4 GLfloat -> Mat3 GLfloat
+glslModelViewToNormalMatrix = fromJust.inverse.transpose.trunc4
+
+(==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+(==>) = glslMatTranslate
+glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+glslMatTranslate
+ mat@(Matrix4 (m00,m01,m02,m03,
+ m10,m11,m12,m13,
+ m20,m21,m22,m23,
+ m30,m31,m32,m33)) vec =
+ let (Vec4 (v0,v1,v2,v3)) = mat -*| vec in
+ Matrix4 (m00,m01,m02,m03,
+ m10,m11,m12,m13,
+ m20,m21,m22,m23,
+ m30+v0,m31+v1,m32+v2,m33+v3)
+
+rotationMatrix :: GLfloat -> Vec3 GLfloat -> Mat3 GLfloat
+rotationMatrix ang (Vec3 (u,v,w)) =
+ let l = (u*u + v*v + w*w)
+ u2 = u*u
+ v2 = v*v
+ w2 = w*w in
+ Matrix3 (
+ (u2 + (v2 + w2) * cos(ang)) / l,
+ (u * v * (1 - cos(ang)) - w * sqrt(l) * sin(ang)) / l,
+ (u * w * (1 - cos(ang)) + v * sqrt(l) * sin(ang)) / l,
+
+ (u * v * (1 - cos(ang)) + w * sqrt(l) * sin(ang)) / l,
+ (v2 + (u2 + w2) * cos(ang)) / l,
+ (v * w * (1 - cos(ang)) - u * sqrt(l) * sin(ang)) / l,
+
+ (u * w * (1 - cos(ang)) - v * sqrt(l) * sin(ang)) / l,
+ (v * w * (1 - cos(ang)) + u * sqrt(l) * sin(ang)) / l,
+ (w2 + (u2 + v2) * cos(ang)) / l
+ )
+
+zRotationMatrix :: GLfloat -> Mat3 GLfloat
+zRotationMatrix ang = rotationMatrix ang (Vec3 (0,0,1))
+
+rotateFrom :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat
+rotateFrom vector relative newRelative =
+ if vector == Vec3 (0,0,0) then vector else
+ case (normalize relative, normalize newRelative) of
+ (r', n') ->
+ if r' == n' then vector else
+ let axis = r' × n'
+ ang = acos $ r' `vDot` n' in
+ rotationMatrix ang axis -*| vector
+
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
index e8a5974..21e219a 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -320,3 +320,5 @@ mix a b c = a * c + b * (1 - c)
fpart :: (RealFrac a) => a -> a
fpart x = x - (fromIntegral (floor x::Int))
+ifNaN :: (RealFloat a) => a -> a -> a
+ifNaN reg def = if' (isNaN reg) def reg
diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs
index 75806b2..06761fd 100644
--- a/Graphics/SDL/SDLHelp.hs
+++ b/Graphics/SDL/SDLHelp.hs
@@ -132,7 +132,7 @@ startPipeline reshapeH eventH displayH updateH ini = do
_ -> eventH ev res >>= pumpEvents'
let runPipeline val = do
res <- pumpEvents' val >>= displayH
- SDL.glSwapBuffers `seq` (updateH res) >>= runPipeline
+ updateH res >>= runPipeline
-- TODO unhardcode this
reshapeH 640 480 ini >>= runPipeline
diff --git a/Resources.hs b/Resources.hs
index 30d129b..ddffb9c 100644
--- a/Resources.hs
+++ b/Resources.hs
@@ -39,6 +39,8 @@ import TileShow
import Data.Array
import qualified Data.StateVar as SV
+import Data.Time.Clock.POSIX
+import Control.Concurrent
{- Types of terrain which are possible -}
data TileType = Forest | Beach | Water | Grass | Jungle | Mountains |
@@ -74,17 +76,49 @@ data Resources = Resources {
routines :: [ResourcesClosure -> IO ()],
- speed :: GLfloat,
timeSpeed :: Int,
time :: Int,
heightMap :: Array (Int,Int) Tile,
positionUpdate :: (Resources -> IO Resources),
+
+ {- Smaller if in first person -}
speedFactor :: GLfloat,
+ {- Higher if shift is held -}
+ speedMultiplier :: GLfloat,
+ {- Direction -}
+ speedDirection :: Vec3 GLfloat,
+
dDown :: GLfloat,
- waterArray :: ArrIO.IOArray (Int,Int) GLfloat
+ waterArray :: ArrIO.IOArray (Int,Int) GLfloat,
+ headBob :: GLfloat,
+ mode :: CameraMode
}
+getSpeed :: Resources -> GLfloat
+getSpeed res =speedFactor res * speedMultiplier res
+
+cameraForward :: CameraPosition -> Vec3 GLfloat
+cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1,th,ph)
+
+cameraUp :: CameraPosition -> Vec3 GLfloat
+cameraUp (CameraPosition _ _ ph) =
+ if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0)
+ where ph' = (floor ph::Int) `mod` 360
+
+cameraRight :: CameraPosition -> Vec3 GLfloat
+cameraRight cam = cameraUp cam × cameraForward cam
+
+
+getVelocity :: Resources -> Vec3 GLfloat
+getVelocity res =
+ let dir = speedDirection res
+ camdir = cameraForward $ rPosition res
+ truedir = dir <-> (Vec3 (0,0,1) <-> camdir) in
+ getSpeed res `vScale` (norm dir `vScale` V.normalize truedir)
+
+data CameraMode = Oracle | FirstPerson deriving Eq
+
{- Central data type for rendering each frame -}
data ResourcesClosure = ResourcesClosure {
rcMVMatrix :: Mat4 GLfloat
@@ -104,7 +138,7 @@ $(declareSetters ''Resources)
- person -}
firstPerson :: Resources -> IO Resources
firstPerson res =
- let (CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition res
+ let camera@(CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition res
(_,(w,h)) = bounds $ heightMap res
(!!!) arr (x',y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x',y'))
h1 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor y) )
@@ -115,19 +149,19 @@ firstPerson res =
v = y - (int $ (floor y::Int))
mixu1 = mix h3 h1 u
mixu2 = mix h4 h2 u
- newh = mix mixu2 mixu1 v + 0.2
+ newh = mix mixu2 mixu1 v
droph = curh - dDown res
+ jitter = (max 0 $ getSpeed res - 0.029) ** 0.1 / 2
+ dy = sin (headBob res*2) * jitter
+ dx = realToFrac $ cos (headBob res) * jitter
in do
- return $
- if (newh+0.2 > droph) then
- setRPosition (CameraPosition (Vec3 (x,newh,y)) th ph) $
- setDDown 0 $
- if speed res > speedFactor res then
- (setSpeed <..> speedFactor) res
- else res
+ return $ ((setHeadBob.(+ jitter)) <..> headBob) $
+ if (newh+0.3 > droph) then
+ setRPosition (CameraPosition (Vec3 (x,newh+0.2,y)) (th + asin dx) (ph - asin dy)) $
+ setDDown 0 res
else
setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $
- setDDown (dDown res + 0.05) res
+ setDDown (dDown res + 0.03) res
{- A function which will explode if a uniform
- does not exist for the shader given, otherwis,
@@ -145,11 +179,9 @@ getUniformsSafe prog uniforms =
{- Builds an model view matrix given the
- camera position of the scene -}
buildMVMatrix :: CameraPosition -> Mat4 GLfloat
-buildMVMatrix (CameraPosition eye th ph) =
- let up = if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0)
- where ph' = (floor ph::Int) `mod` 360 in
- let lookat = eye <+> (Vec3 $ toEuclidian (1,th,ph)) in
- lookAtMatrix eye lookat up
+buildMVMatrix camera@(CameraPosition eye _ _) =
+ let lookat = eye <+> cameraForward camera in
+ lookAtMatrix eye lookat (cameraUp camera)
{- Called after each frame to crunch throught the
- events -}
@@ -184,28 +216,30 @@ eventHandle event res = do
return $ setRDPosition (CameraPosition eye (th+1) ph) res
MouseMotion _ _ x y -> do
- return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res
+ return $
+ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res
KeyDown (Keysym SDLK_w _ _) ->
- return $ setSpeed (speed res + speedFactor res) res
+ return $ setSpeedDirection (Vec3 (0,0,1)) res
KeyDown (Keysym SDLK_s _ _) ->
- return $ setSpeed (speed res - speedFactor res) res
+ return $ setSpeedDirection (Vec3 (0,0,-1)) res
KeyUp (Keysym SDLK_w _ _) ->
- return $ setSpeed 0 res
+ return $ setSpeedDirection (Vec3 (0,0,0)) res
KeyUp (Keysym SDLK_s _ _) ->
- return $ setSpeed 0 res
+ return $ setSpeedDirection (Vec3 (0,0,0)) res
KeyUp (Keysym SDLK_q _ _) ->
let getY (Vec3 (_,y,_)) = y in
return $
setPositionUpdate firstPerson $
- setSpeedFactor 0.1 $
+ setSpeedFactor 0.03 $
+ setMode FirstPerson $
(setDDown <..> (negate . getY . resourcesVelocity)) res
KeyUp (Keysym SDLK_e _ _) ->
return $
setPositionUpdate return $
setSpeedFactor 1 $
- if speed res > 0 then setSpeed 1 res else res
+ setMode Oracle res
KeyUp (Keysym SDLK_f _ _) -> do
ret <- reshape 1920 1080 res
@@ -219,18 +253,21 @@ eventHandle event res = do
return res
KeyDown (Keysym SDLK_SPACE _ _) -> do
- return $ setDDown (-0.3) res
+ return $ setDDown (-0.2) res
KeyDown (Keysym SDLK_LSHIFT _ _) -> do
- return $ (setSpeed <..> ((*3) . speed)) res
+ return $ setSpeedMultiplier 4 res
+
KeyUp (Keysym SDLK_LSHIFT _ _) -> do
- return $ (setSpeed <..> ((/3) . speed)) res
+ return $ setSpeedMultiplier 1 res
_ -> return res
+ where oracle = if (mode res == FirstPerson) then 1 else 3
{- Callback for the display -}
displayHandle :: Resources -> IO Resources
displayHandle resources = do
+ time1 <- getPOSIXTime
let cameraPos@(CameraPosition loc _ _) = rPosition resources
let lighty = ((/10) . fromIntegral . time) resources
let logist c = (1 / (1 + 2.71828**(-c*x))) * 0.9 + 0.1
@@ -263,13 +300,21 @@ displayHandle resources = do
in mapM_ (Prelude.$rc) $ routines resources
SDL.glSwapBuffers
+ time2 <- getPOSIXTime
+
+ let diff = 0.033 - (time2 - time1)
+ when (diff > 0) (threadDelay $ round $ diff * 1000000)
+ time3 <- getPOSIXTime
+
+ putStrLn $ "FPS: " ++! (1/ (time3 - time1))
+
return resources
cameraToEuclidian :: CameraPosition -> Vec3 GLfloat
cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1,ph,th)
resourcesVelocity :: Resources -> Vec3 GLfloat
-resourcesVelocity res = speed res `vScale` cameraToEuclidian (rPosition res)
+resourcesVelocity res = getSpeed res `vScale` cameraToEuclidian (rPosition res)
resourcesUnderWater :: Resources -> IO Bool
resourcesUnderWater res = do
@@ -285,8 +330,8 @@ updateHandle res = do
let new = ((+) `on` (Prelude.$ res)) timeSpeed time in
setTime new res
where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
- let x' = speed res `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) in
- (CameraPosition (x <+> x') (y + y') (z + z'))
+ let x' = getVelocity res in
+ CameraPosition (x <+> x') (y + y') (z + z')
reshape :: Int -> Int -> Resources -> IO Resources
reshape w h res =
@@ -506,14 +551,17 @@ makeResources surf builder forestB jungleB water arr waterarr = do
<*> pure pMatrix'
<*> pure pMatrix'
<*> l_routines
- <*> pure 0
<*> pure 1
<*> pure 0
<*> pure arr
<*> pure return
<*> pure 1
+ <*> pure 1
+ <*> pure (Vec3 (0,0,0))
<*> pure 0
<*> pure waterarr
+ <*> pure 0
+ <*> pure Oracle
printErrors :: String -> IO ()
printErrors ctx =
diff --git a/Terralloc.cabal b/Terralloc.cabal
index 7281d81..6ee1d80 100644
--- a/Terralloc.cabal
+++ b/Terralloc.cabal
@@ -22,4 +22,4 @@ executable terralloc.bin
ghc-options: -rtsopts -O3
-- ghc-options: -prof -osuf h_o
-- other-modules:
- build-depends: setters, base, OpenGL, bytestring, array, SDL, random, OpenGLRaw, AC-Angle, deepseq, containers, SDL-image, cpu, template-haskell, filepath, MissingH, StateVar
+ build-depends: setters, base, OpenGL, bytestring, array, SDL, random, OpenGLRaw, AC-Angle, deepseq, containers, SDL-image, cpu, template-haskell, filepath, MissingH, StateVar, time
diff --git a/maps/svalbard_height.png b/maps/svalbard_height.png
index 7670da1..6892b3a 100644
--- a/maps/svalbard_height.png
+++ b/maps/svalbard_height.png
Binary files differ
generated by cgit (git 2.34.1) at 2025-04-29 01:03:56 +0000