aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Final.hs2
-rw-r--r--Graphics/Glyph/GLMath.hs378
-rw-r--r--Graphics/Glyph/Util.hs15
-rw-r--r--Graphics/SDL/SDLHelp.hs1
-rw-r--r--Resources.hs266
-rw-r--r--maps/goliath_height.pngbin0 -> 27219 bytes
-rw-r--r--maps/goliath_terrain.pngbin0 -> 3414 bytes
-rw-r--r--maps/svalbard_height.pngbin2908 -> 19903 bytes
-rw-r--r--maps/svalbard_terrain.pngbin1862 -> 1946 bytes
-rw-r--r--package.yaml1
-rw-r--r--shaders/snow.frag13
-rw-r--r--shaders/snow.geom26
-rw-r--r--shaders/snow.vert20
13 files changed, 519 insertions, 203 deletions
diff --git a/Final.hs b/Final.hs
index 3a7596f..f17703c 100644
--- a/Final.hs
+++ b/Final.hs
@@ -127,6 +127,7 @@ colorArray marr = do
- 2 things:
- A map of water bodies ids to elevations (to detect if you are under water
- A builder that will generate all of the quads for the water. -}
+
getWaterQuads :: Array (Int,Int) Tile -> IOArray (Int,Int) Int -> IO ( Map.Map Int GLfloat, BuilderM GLfloat () )
getWaterQuads marr arr = do
let (_,(w,h)) = bounds marr
@@ -351,6 +352,7 @@ main = do
(mapping,water) <- getWaterQuads arr coloredArr
coloredArr2 <- mapArray (\idx -> if idx == 0 then -1 else Map.findWithDefault (-1) idx mapping) coloredArr
+
printShowArray coloredArr2
printArray arr
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
index b1df4c5..ac3e93a 100644
--- a/Graphics/Glyph/GLMath.hs
+++ b/Graphics/Glyph/GLMath.hs
@@ -1,170 +1,214 @@
{-# 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))
+
+maybeNormalize :: (Vector f a, Eq f) => a f -> a f
+maybeNormalize x = if norm x == 0 then x else normalize x
+
+coordinateConvert :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat
+coordinateConvert forward up' vector =
+ if vector == Vec3 (0,0,0) then vector else
+ let right = forward × up'
+ up = right × forward in
+ case (normalize forward, normalize up, normalize right, vector) of
+ (za,ya,xa,Vec3 (x,y,z)) -> (x `vScale` xa) <+> (y `vScale` ya) <+> (z `vScale` za)
+
+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 1c1269d..90640a4 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -329,3 +329,18 @@ 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
+
+everyN :: Int -> [a] -> [a]
+everyN _ [] = []
+everyN n (x : xs) = x : (everyN n $ drop n xs)
+
+chunkList :: [a] -> [(a,a)]
+chunkList l = zip [x | x <- everyN 1 l] [x | x <- everyN 1 (tail l)]
+
+chunkList3 :: [a] -> [(a,a,a)]
+chunkList3 l = zip3
+ [x | x <- everyN 2 l]
+ [x | x <- everyN 2 (tail l)]
+ [x | x <- everyN 2 (tail $ tail l)]
diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs
index 9c65c83..72159d1 100644
--- a/Graphics/SDL/SDLHelp.hs
+++ b/Graphics/SDL/SDLHelp.hs
@@ -138,7 +138,6 @@ defaultReshape w h ret = do
startPipeline :: forall a. (Int -> Int -> a -> IO a) -> (SDL.EventPayload -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
startPipeline reshapeH eventH displayH updateH ini = do
-
let pumpEvents' res = do
evs <- SDL.pollEvents
foldM (\res (SDL.eventPayload -> ev) -> case ev of
diff --git a/Resources.hs b/Resources.hs
index 009bdac..d446796 100644
--- a/Resources.hs
+++ b/Resources.hs
@@ -36,6 +36,12 @@ import qualified Data.Array.IO as ArrIO
import Data.Array
import qualified Data.StateVar as SV
+import Data.Time.Clock.POSIX
+import Control.Concurrent
+import Text.Printf
+import System.IO
+import System.Random hiding (uniform)
+import qualified SDL
{- Types of terrain which are possible -}
data TileType = Forest | Beach | Water | Grass | Jungle | Mountains |
@@ -80,17 +86,32 @@ 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,
+ threadDiff :: Double
}
+setHeadBob :: GLfloat -> Resources -> Resources
+setHeadBob f r = r { headBob = f }
+
+setThreadDiff :: Double -> Resources -> Resources
+setThreadDiff f r = r { threadDiff = f }
+
setRSurface :: SDL.Window -> Resources -> Resources
setRSurface x r = r { rWindow = x }
@@ -109,8 +130,8 @@ setMvMatrix x r = r { mvMatrix = x }
setRoutines :: [ResourcesClosure -> IO ()] -> Resources -> Resources
setRoutines x r = r { routines = x }
-setSpeed :: GLfloat -> Resources -> Resources
-setSpeed x r = r { speed = x }
+setSpeedDirection :: Vec3 GLfloat -> Resources -> Resources
+setSpeedDirection x r = r { speedDirection = x }
setTimeSpeed :: Int -> Resources -> Resources
setTimeSpeed x r = r { timeSpeed = x }
@@ -133,6 +154,29 @@ setDDown x r = r { dDown = x }
setWaterArray :: ArrIO.IOArray (Int,Int) GLfloat -> Resources -> Resources
setWaterArray x r = r { waterArray = x }
+getSpeed :: Resources -> GLfloat
+getSpeed res =speedFactor res * speedMultiplier res * norm (speedDirection 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 = coordinateConvert camdir (Vec3 (0,1,0)) dir in
+ getSpeed res `vScale` maybeNormalize truedir
+
+data CameraMode = Oracle | FirstPerson deriving Eq
{- Central data type for rendering each frame -}
data ResourcesClosure = ResourcesClosure {
@@ -151,7 +195,7 @@ data ResourcesClosure = ResourcesClosure {
- 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) )
@@ -162,19 +206,21 @@ 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
+ speed = getSpeed res
+ jitter = (max 0 $ speed - 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
+ setSpeedFactor 0.03 $
+ setRPosition (CameraPosition (Vec3 (x,newh+0.2,y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $
+ 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,
@@ -192,11 +238,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 -}
@@ -204,28 +248,66 @@ eventHandle :: SDL.EventPayload -> Resources -> IO Resources
eventHandle event = case event of
SDL.KeyboardEvent e ->
case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
- (SDL.Pressed, SDL.ScancodeW) -> setPh 1
+ (SDL.Pressed, SDL.ScancodeW) -> setPh 2
(SDL.Released, SDL.ScancodeW) -> setPh 0
- (SDL.Pressed, SDL.ScancodeA) -> setTh (-1)
+ (SDL.Pressed, SDL.ScancodeA) -> setTh (-2)
(SDL.Released, SDL.ScancodeA) -> setTh 0
- (SDL.Pressed, SDL.ScancodeS) -> setPh (-1)
+ (SDL.Pressed, SDL.ScancodeS) -> setPh (-2)
(SDL.Released, SDL.ScancodeS) -> setPh 0
- (SDL.Pressed, SDL.ScancodeD) -> setTh 1
+ (SDL.Pressed, SDL.ScancodeD) -> setTh 2
(SDL.Released, SDL.ScancodeD) -> setTh 0
- (SDL.Pressed, SDL.ScancodeI) -> \res -> return $ setSpeed (speedFactor res) res
- (SDL.Released, SDL.ScancodeI) -> return . setSpeed 0
- (SDL.Pressed, SDL.ScancodeK) -> \res -> return $ setSpeed (0 - speedFactor res) res
- (SDL.Released, SDL.ScancodeK) -> return . setSpeed 0
+ (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1))
+ (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0))
+ (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1))
+ (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0))
+
+ -- Pressing the 'q' enters first-person-mode
+ (SDL.Pressed, SDL.ScancodeQ) -> return . appAll
+ [setPositionUpdate firstPerson,
+ setSpeedFactor 0.1,
+ \res -> res { dDown = negate $ (\(Vec3 (_,y,_)) -> y) $ resourcesVelocity res}]
+
+ (SDL.Pressed, SDL.ScancodeE) -> return . appAll
+ [setPositionUpdate return,
+ setSpeedFactor 1,
+ \res -> res { dDown = 0 }]
+
+ (SDL.Pressed, SDL.ScancodeSpace) -> return . appAll
+ [setSpeedFactor 0.05,
+ \res -> res { dDown = -0.2 }]
+
+ (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 4 }
+
+ (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 1 }
+
+ -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ setSpeedMultiplier 4 res
+
+ -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ setSpeedMultiplier 1 res
+ -- KeyUp (Keysym SDLK_e _ _) ->
+ -- return $
+ -- setPositionUpdate return $
+ -- setSpeedFactor 1 $
+ -- if speed res > 0 then setSpeed 1 res else res
+
_ -> return
_ -> return
where
+ appAll :: [a -> a] -> a -> a
+ appAll (f:fs) a = appAll fs (f a)
+ appAll [] a = a
+
setPh i res =
let (CameraPosition eye th ph) = rDPosition res in
return $ setRDPosition (CameraPosition eye th i) res
setTh i res =
let (CameraPosition eye th ph) = rDPosition res in
return $ setRDPosition (CameraPosition eye i ph) res
+
+-- eventHandle :: SDL.Event -> Resources -> IO Resources
+-- eventHandle event res = do
-- let (CameraPosition eye th ph) = rDPosition res
-- let (CameraPosition peye pth pph) = rPosition res
-- case event of
@@ -291,6 +373,65 @@ eventHandle event = case event of
-- KeyDown (Keysym SDLK_SPACE _ _) -> do
-- return $ setDDown (-0.3) res
+ -- MouseMotion _ _ x y -> do
+ -- return $
+ -- setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res
+
+ -- KeyDown (Keysym SDLK_w _ _) ->
+ -- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
+ -- KeyDown (Keysym SDLK_s _ _) ->
+ -- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
+ -- KeyDown (Keysym SDLK_d _ _) ->
+ -- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
+ -- KeyDown (Keysym SDLK_a _ _) ->
+ -- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
+
+ -- KeyUp (Keysym SDLK_w _ _) ->
+ -- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
+ -- KeyUp (Keysym SDLK_s _ _) ->
+ -- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
+ -- KeyUp (Keysym SDLK_d _ _) ->
+ -- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
+ -- KeyUp (Keysym SDLK_a _ _) ->
+ -- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
+
+ -- KeyUp (Keysym SDLK_q _ _) ->
+ -- let getY (Vec3 (_,y,_)) = y in
+ -- return $
+ -- setPositionUpdate firstPerson $
+ -- setMode FirstPerson $
+ -- (setDDown <..> (negate . getY . resourcesVelocity)) res
+ -- KeyUp (Keysym SDLK_e _ _) ->
+ -- return $
+ -- setPositionUpdate return $
+ -- setSpeedFactor 1 $
+ -- setMode Oracle res
+
+ -- KeyUp (Keysym SDLK_f _ _) -> do
+ -- ret <- reshape 1920 1080 res
+ -- SDL.toggleFullscreen $ rSurface ret
+ -- SDL.showCursor False
+ -- SDL.grabInput True
+ -- return ret
+ -- KeyUp (Keysym SDLK_c _ _) -> do
+ -- SDL.showCursor True
+ -- SDL.grabInput False
+ -- return res
+ -- KeyUp (Keysym SDLK_g _ _) -> do
+ -- SDL.showCursor False
+ -- SDL.grabInput True
+ -- return res
+
+ -- KeyDown (Keysym SDLK_SPACE _ _) -> do
+ -- return $
+ -- setDDown (-0.2) $
+ -- setSpeedFactor 0.05 res
+
+ -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ setSpeedMultiplier 4 res
+
+ -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ setSpeedMultiplier 1 res
-- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
-- return $ (setSpeed <..> ((*3) . speed)) res
@@ -302,6 +443,7 @@ eventHandle event = case event of
{- 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
@@ -333,13 +475,25 @@ displayHandle resources = do
in mapM_ (Prelude.$rc) $ routines resources
SDL.glSwapWindow (rWindow resources)
- return resources
+ time2 <- getPOSIXTime
+
+ let diff = threadDiff resources - (realToFrac $ time2 - time1)
+ when (diff > 0) (threadDelay $ round $ diff * 1000000)
+ time3 <- getPOSIXTime
+ let fps = realToFrac $ 1 / (time3 - time1) :: Double
+
+ putStr $ printf "FPS: %.2f\r" fps
+
+ return $
+ if' (fps < 30)
+ ((setThreadDiff.(subtract 0.0001)) <..> threadDiff)
+ ((setThreadDiff.(+0.0001)) <..> threadDiff) 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
@@ -355,8 +509,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 =
@@ -449,6 +603,41 @@ buildTerrainObject builder = do
-- uniform lightposU $= rcLightPos rc
-- setupTexturing3D density densityU 0
+buildSnowVal :: Array (Int,Int) Tile -> StdGen -> BuilderM GLfloat ()
+buildSnowVal arr gen =
+ let (_,(w,h)) = bounds arr
+ run :: [Int] -> (Int,Int) -> BuilderM GLfloat [Int]
+ run rs (x,y) = do
+ let (seed:npart:t) = rs
+ nStdGen = mkStdGen seed
+ height = elevation (arr ! (x,y))
+ when (tileType (arr ! (x,y)) == Tundra) $
+ forM_ (take (npart`mod`50) $ chunkList3 $ randomRs (0::GLfloat,1) nStdGen ) $ \(a,b,c) -> do
+ let (x',y') = (int x + a, int y + b)
+ bVertex3 (x',c*100,y')
+ bColor4 (int $ height `div` 10,1, 0, 0)
+
+ return t
+ in
+
+ foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]
+
+buildSnowObject :: Array (Int,Int) Tile -> StdGen -> IO (ResourcesClosure -> IO ())
+buildSnowObject arr gen = do
+ snowProgram <- loadProgramSafe' "shaders/snow.vert" "shaders/snow.frag" (Just "shaders/snow.geom")
+ obj <-
+ liftM (flip setPrimitiveMode Ex.Points) $
+ newDefaultGlyphObjectWithClosure (buildSnowVal arr gen) () $ \_ -> do
+ currentProgram $= Just snowProgram
+
+ [globalAmbientU,pjMatrixU,mvMatrixU,timeU] <-
+ getUniformsSafe snowProgram ["globalAmbient","pjMatrix","mvMatrix","time"]
+ return $ \rc -> do
+ draw $ (prepare obj) $ \_ -> do
+ uniform mvMatrixU $= rcMVMatrix rc
+ uniform pjMatrixU $= rcPMatrix rc
+ uniform timeU $= (Index1 $ (rcTime rc/75))
+ uniform globalAmbientU $= rcGlobalAmbient rc
buildForestObject :: Seq.Seq GLfloat -> String -> String -> IO (ResourcesClosure -> IO ())
buildForestObject a_seq obj tex =
@@ -533,7 +722,7 @@ buildWaterObject builder = do
uniform (UniformLocation 5) $= rcMVMatrix rc
uniform (UniformLocation 7) $= rcNormalMatrix rc
uniform (UniformLocation 8) $= rcLightPos rc
- uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0)
+ uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0);
uniform (UniformLocation 10) $= rcGlobalAmbient rc
bool <- (resourcesUnderWater $ rcResources rc)
if bool then
@@ -546,8 +735,10 @@ makeResources :: SDL.Window -> BuilderM GLfloat b ->
BuilderM GLfloat a -> Array (Int,Int) Tile ->
ArrIO.IOArray (Int,Int) GLfloat -> IO Resources
makeResources window builder forestB jungleB water arr waterarr = do
+ hSetBuffering stdout NoBuffering
let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
+ stdgen <- newStdGen
let l_routines = sequence [
skyboxObject,
(return $ \_ -> do
@@ -558,15 +749,16 @@ makeResources window builder forestB jungleB water arr waterarr = do
blend $= Enabled
cullFace $= Just Back
blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)),
+ buildWaterObject water,
buildForestObject forestB "tree.obj" "textures/wood_low.png",
buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png",
- buildWaterObject water
+ buildSnowObject arr stdgen
-- cloudProgram
]
Resources
<$> pure window
<*> do CameraPosition
- <$> pure (Vec3 (10,10,2))
+ <$> pure (Vec3 (10,10,-10))
<*> pure 0
<*> pure 0
<*> do CameraPosition
@@ -576,14 +768,18 @@ makeResources window 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
+ <*> pure 0.033
printErrors :: String -> IO ()
printErrors ctx =
diff --git a/maps/goliath_height.png b/maps/goliath_height.png
new file mode 100644
index 0000000..5e982e8
--- /dev/null
+++ b/maps/goliath_height.png
Binary files differ
diff --git a/maps/goliath_terrain.png b/maps/goliath_terrain.png
new file mode 100644
index 0000000..5c288bd
--- /dev/null
+++ b/maps/goliath_terrain.png
Binary files differ
diff --git a/maps/svalbard_height.png b/maps/svalbard_height.png
index 7670da1..656226a 100644
--- a/maps/svalbard_height.png
+++ b/maps/svalbard_height.png
Binary files differ
diff --git a/maps/svalbard_terrain.png b/maps/svalbard_terrain.png
index 5afd0b4..edc7f65 100644
--- a/maps/svalbard_terrain.png
+++ b/maps/svalbard_terrain.png
Binary files differ
diff --git a/package.yaml b/package.yaml
index 7aab7c5..e82ad36 100644
--- a/package.yaml
+++ b/package.yaml
@@ -26,4 +26,5 @@ dependencies:
- filepath
- StateVar
- split
+ - time
diff --git a/shaders/snow.frag b/shaders/snow.frag
new file mode 100644
index 0000000..d494633
--- /dev/null
+++ b/shaders/snow.frag
@@ -0,0 +1,13 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(location = 0) out vec4 frag_color ;
+
+in float rad ;
+
+uniform vec4 globalAmbient ;
+
+void main() {
+ frag_color = vec4( 1.0,1.0,1.0,(9 - rad*rad)/9) * vec4(normalize(globalAmbient.xyz),globalAmbient.a) ;
+}
diff --git a/shaders/snow.geom b/shaders/snow.geom
new file mode 100644
index 0000000..116a59d
--- /dev/null
+++ b/shaders/snow.geom
@@ -0,0 +1,26 @@
+#version 150
+layout(points) in;
+layout(triangle_strip, max_vertices=28) out;
+
+out float rad ;
+
+void vertex( vec3 pos ) {
+ gl_Position = gl_in[0].gl_Position + vec4(pos,0.0) ;
+ EmitVertex() ;
+}
+
+void main( ) {
+ float r = 0.008 ;
+ float th = 0.00 ;
+ for( ; th < 6.3 ; th += 0.5 ) {
+ rad = 3 ;
+ vertex( vec3(r*sin(th),r*cos(th),0.0) ) ;
+ rad = 0.0 ;
+ vertex( vec3(0.0,0.0,0.0) ) ;
+ }
+ th = 0 ;
+ rad = 3 ;
+ vertex( vec3(r*sin(th),r*cos(th),0.0) ) ;
+ // vertex( vector[0] ) ;
+ EndPrimitive();
+}
diff --git a/shaders/snow.vert b/shaders/snow.vert
new file mode 100644
index 0000000..535c26a
--- /dev/null
+++ b/shaders/snow.vert
@@ -0,0 +1,20 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(location = 0) in vec3 in_position ;
+layout(location = 2) in vec3 in_range ;
+
+uniform mat4 pjMatrix ;
+uniform mat4 mvMatrix ;
+
+uniform float time ;
+
+void main() {
+ float tmp = in_position.y + time ;
+ float ipart ;
+ float fpart = modf( tmp, ipart ) ;
+ float newy = in_range.y - (int(ipart) % int(in_range.y) + fpart) + in_range.x ;
+ vec3 newp = vec3( in_position.x, newy, in_position.z ) ;
+ gl_Position = pjMatrix * (mvMatrix * vec4(newp,1.0)) ;
+}
generated by cgit (git 2.34.1) at 2025-04-28 11:03:42 +0000