aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Final.hs156
-rw-r--r--Graphics/Glyph/ArrayGenerator.hs33
-rw-r--r--Graphics/Glyph/BufferBuilder.hs6
-rw-r--r--Graphics/Glyph/GLMath.hs14
-rw-r--r--Graphics/Glyph/GlyphObject.hs16
-rw-r--r--Graphics/Glyph/Mat4.hs114
-rw-r--r--Graphics/Glyph/Util.hs51
-rw-r--r--Resources.hs153
-rw-r--r--shaders/.basic.frag.swpbin0 -> 12288 bytes
-rw-r--r--shaders/.water.frag.swpbin0 -> 12288 bytes
-rw-r--r--shaders/basic.frag83
-rw-r--r--shaders/basic.vert27
-rw-r--r--shaders/forest.frag53
-rw-r--r--shaders/forest.geom69
-rw-r--r--shaders/forest.vert44
-rw-r--r--shaders/sky.frag18
-rw-r--r--shaders/sky.vert18
-rw-r--r--shaders/water.frag9
-rw-r--r--shaders/water.vert16
19 files changed, 781 insertions, 99 deletions
diff --git a/Final.hs b/Final.hs
index a9c8ac4..96c826a 100644
--- a/Final.hs
+++ b/Final.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
module Main where
import Graphics.Rendering.OpenGL as GL
@@ -17,6 +19,9 @@ import Data.Word
import Data.Array
import Data.Array.IO
+import Data.Sequence as Seq
+import Prelude as P
+
import Debug.Trace
import Data.Bits
@@ -28,7 +33,7 @@ import Debug.Trace
data TileType = Forest | Beach | Water | Grass | Jungle | Mountains |
- Tundra | Unknown deriving Enum
+ Tundra | Unknown deriving (Enum,Eq)
$(makeShow ''TileType)
@@ -56,26 +61,102 @@ buildArray terrain height =
putStrLn $ show (head list)
return $ listArray ((0,0),(w-1,h-1)) list
+-- colors regions of water in the array
+colorArray :: Array (Int,Int) Tile -> IO (IOArray (Int,Int) Int)
+colorArray marr = do
+ let pollseq (Seq.viewl -> (head :< tail)) = (head,tail)
+ let bnd@(_,(w,h)) = bounds marr
+ ret <- newArray bnd 0
+ let myfunction place = do
+ val <- readArray ret place
+ case marr ! place of
+ (Tile Water _) -> return $ val==0
+ _ -> return False
+ let floodfill :: (Int,Int) -> ((Int,Int) -> IO Bool) -> Int -> IO ()
+ floodfill start func' val = do
+ let func t@(x,y) = if not (x <= w && x >= 0 && y <= h && y >= 0) then return False else func' t
+ _ <- untilM2 (return . Seq.null) (Seq.singleton start) $ \queue -> do
+ let (head',tail') = pollseq queue
+ bool <- func head'
+ if not bool then return tail' else do
+ (_,tail2) <- untilM2 (liftM not . func . fst) (head',tail') $ \((x,y),queue') -> do
+ (ret <!> (x,y)) $= val
+ return ((x+1,y),queue' |> (x,y-1) |> (x,y+1))
+ (_,tail3) <- untilM2 (liftM not . func . fst) (head',tail2) $ \((x,y),queue') -> do
+ (ret <!> (x,y)) $= val
+ return ((x-1,y), queue' |> (x,y-1) |> (x,y+1))
+ return tail3
+ return ()
+ foldM_ (\val place -> do
+ bool <- myfunction place
+ if bool then do
+ floodfill place myfunction val
+ return $ val+1
+ else return val
+ ) 1 [(x,y) | x <- [0..w], y <- [0..h]]
+ return ret
+
+-- elevation quad is corner verticices
+getWaterQuads :: Array (Int,Int) Tile -> IOArray (Int,Int) Int -> IO ( BuilderM GLfloat () )
+getWaterQuads marr arr = do
+ let (_,(w,h)) = bounds marr
+ let elevationCacheIO :: IO (Map.Map Int (Int,Int,Int,Int,Int))
+ elevationCacheIO = do
+ let tup = (max,max,max,min,min)
+ foldM (\themap (x,y) -> do
+ bodyID <- readArray arr (x,y)
+ if bodyID == 0 then return themap else do
+ let elev = elevation $ marr ! (x,y) :: Int
+ let newmap = Map.insertWith (\old->
+ zipWithT5 (P.$) (zipWithT5 (P.$) tup old)
+ ) bodyID (elev,x,y,x,y) themap
+ return newmap
+ ) (Map.empty::Map.Map Int (Int,Int,Int,Int,Int)) [(x,y) | x <- [0..w], y <- [0..h]]
+
+ dat <- (liftM Map.toList elevationCacheIO)
+ return . sequence_ $ for dat $ \(_, (elev,maxx,maxy,minx,miny)) -> do
+ let relev = (fromIntegral elev) / 10
+ mxx = fromIntegral maxx
+ mnx = fromIntegral minx
+ mxy = fromIntegral maxy
+ mny = fromIntegral miny
+ mapM_ bVertex3 $ trianglesFromQuads
+ [(mxx,relev,mxy),
+ (mxx,relev,mny),
+ (mnx,relev,mny),
+ (mnx,relev,mxy)]
+
+
printArray :: Array (Int,Int) Tile -> IO ()
printArray arr = do
let (_,(w,h)) = bounds arr
- putStrLn $ "w=" ++! w
- putStrLn $ "h=" ++! h
- forM_ [0..h-1] $ \y -> do
- forM_ [0..w-1] $ \x -> do
+ putStrLn $ "w=" ++! (w+1)
+ putStrLn $ "h=" ++! (h+1)
+ forM_ [0..h] $ \y -> do
+ forM_ [0..w] $ \x -> do
let next = arr ! (x,y)
putStr $ (show $ tileType next)
putStr " "
- forM_ [0..w-1] $ \x -> do
+ forM_ [0..w] $ \x -> do
let next = arr ! (x,y)
putStr $ (elevShow $ elevation next)
putStrLn ""
where elevShow x =
- let len = length elevMap
+ let len = P.length elevMap
nx = x `div` 5 in
- if nx > len then "=" else [elevMap !! nx]
+ if nx >= len then "=" else [elevMap !! nx]
elevMap = "`.,-~*<:!;%&#@0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+printShowArray arr = do
+ (_,(w,h)) <- getBounds arr
+ putStrLn $ "w=" ++! (w+1)
+ putStrLn $ "h=" ++! (h+1)
+ forM_ [0..h] $ \y -> do
+ forM_ [0..w] $ \x -> do
+ next <- readArray arr (x,y)
+ putStr $ (show $ next)
+ putStrLn ""
+
toColor :: TileType -> (GLfloat,GLfloat,GLfloat,GLfloat)
toColor Tundra = (0.5,0.5,0.5,1.0)
toColor Mountains = (0.5,0.4,0.03,1.0)
@@ -119,43 +200,47 @@ createBuilder arr = do
bTexture2 (f x / 10.0, f z / 10.0)
bVertex3 (f x, y,f z)
-createForestBuilder :: Array (Int,Int) Tile -> StdGen -> ObjectFile GLfloat -> BuilderM GLfloat ()
-createForestBuilder arr gen file = do
-
+createLocations :: Array (Int,Int) Tile -> StdGen -> Int -> TileType -> MonadPlusBuilder (Seq.Seq GLfloat) ()
+createLocations arr gen density typ = do
let (_,(w,h)) = bounds arr
let getElev x y = if x >= w || y >= h || x < 0 || y < 0 then 0 else fromIntegral (elevation $ arr ! (x,y)) /10.0
- let !treeF =
- trace "build tree" $
- basicBuildObject file
- let run :: [Int] -> (Int,Int) -> BuilderM GLfloat [Int]
+ let run :: [Int] -> (Int,Int) -> MonadPlusBuilder ( Seq.Seq GLfloat ) [Int]
run rs (x,y) = do
- let ((_:he), t) = splitAt (head rs `mod` 13 + 1) rs
+ let ((_:he), t) = P.splitAt (head rs `mod` density + 1) rs
let signum' = floor.signum
- when (isForest x y) $ do
+ when (isType x y typ) $ do
forM_ he $ \rand -> do
- let (a,b,_) = mapT3 f (toTup rand)
+ let (a',b',c) = toTup rand
+ let (a,b) = (f a', f b')
+ let [sx,sy,sz,rot,noise] = (P.take 5 $ randomRs (0.0,1.0) $ mkStdGen c)
+
let elev = getElev x y
let elev_dx = getElev (x + signum' a) y
let elev_dy = getElev x (y + signum' b)
let realelev =
((elev * (1-abs a) + elev_dx * (abs a)) +
(elev * (1-abs b) + elev_dy * (abs b))) / 2.0
- when (elev_dx > 0 && elev_dy > 0) $ do
- translating (fromIntegral x+a,realelev,fromIntegral y+b) $ do
- treeF
-
+ when (elev_dx > 0 && elev_dy > 0) $
+ plusM $ Seq.fromList [
+ -- translation
+ fromIntegral x+a,realelev,fromIntegral y+b,
+ -- scale
+ sx+0.5,sy+0.5,sz+0.5,
+ -- rotation
+ sin (rot*6.4), cos(rot*6.4),
+ -- noise
+ noise*6.4
+ ]
return t
- _ <- foldM run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]
+ foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]
return ()
- where isForest x y =
- case tileType $ arr ! (x,y) of
- Forest -> True
- _ -> False
+ where isType x y t =
+ (tileType $ arr ! (x,y)) == t
f x = (fromIntegral x - 128) / 128 * (sqrt 2 / 2)
toTup x = ( (x .&. 0xFF),
(x `shiftR` 8) .&. 0xFF,
@@ -171,11 +256,20 @@ main = do
arr <- buildArray terrain height
putStrLn "Array Built"
- -- printArray arr
+ printArray arr
+ coloredArr <- colorArray arr
+ printShowArray coloredArr
surface <- simpleStartup "Spectical" (640,480)
stgen <- newStdGen
- (log',file) <- loadObjFile "tree.obj"
- mapM_ putStrLn log'
+ stgen2 <- newStdGen
+-- (log',file) <- loadObjFile "tree.obj"
+-- mapM_ putStrLn log'
+
+ let !forestLocations = runMonadPlusBuilder $ createLocations arr stgen 7 Forest
+ let !jungleLocations = runMonadPlusBuilder $ createLocations arr stgen2 2 Jungle
- makeResources surface (createBuilder arr) (createForestBuilder arr stgen file) >>= startPipeline reshape eventHandle displayHandle updateHandle;
+ water <- getWaterQuads arr coloredArr
+-- putStrLn $ "ForestLocations :" ++! forestLocations
+ makeResources surface (createBuilder arr) forestLocations jungleLocations water
+ >>= startPipeline reshape eventHandle displayHandle updateHandle;
diff --git a/Graphics/Glyph/ArrayGenerator.hs b/Graphics/Glyph/ArrayGenerator.hs
new file mode 100644
index 0000000..1e9e5a3
--- /dev/null
+++ b/Graphics/Glyph/ArrayGenerator.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Graphics.Glyph.ArrayGenerator where
+
+import qualified Data.Map as M
+
+import Data.Array
+import Data.Maybe
+
+data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b
+instance (Ord ix) => Monad (ArrayTransaction ix a) where
+ return = ArrayBuilderM_ M.empty
+ (ArrayBuilderM_ map1 val) >>= f =
+ ArrayBuilderM_ (map1 `M.union` map2) val2
+ where (ArrayBuilderM_ map2 val2) = f val
+
+class HasDefault a where
+ theDefault :: a
+
+instance (Num a) => HasDefault a where
+ theDefault = 0
+instance (HasDefault a, HasDefault b) => HasDefault (a,b) where
+ theDefault = (theDefault,theDefault)
+instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a,b,c) where
+ theDefault = (theDefault,theDefault,theDefault)
+
+writeArray :: ix -> a -> ArrayTransaction ix a ()
+writeArray index' val = ArrayBuilderM_ (M.singleton index' val) ()
+
+buildArray :: (Ix ix) => (ix,ix) -> e -> ArrayTransaction ix e () -> Array ix e
+buildArray bounds' def (ArrayBuilderM_ map' _) =
+ listArray bounds' [maybeLookup map' bound | bound <- range bounds']
+ where maybeLookup map_ key = fromMaybe def (M.lookup key map_)
+
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index ec27a89..809312e 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -204,8 +204,8 @@ storableArrayToBuffer target arr = do
bufferData target $= (fromIntegral len, ptr, StaticDraw)
return buffer
-ptrToBuffer :: (Storable b) => BufferTarget -> Ptr b -> Int -> IO BufferObject
-ptrToBuffer target ptr len = do
+ptrToBuffer :: (Storable b) => BufferTarget -> Int -> Ptr b -> IO BufferObject
+ptrToBuffer target len ptr = do
-- len is length in bytes
[buffer] <- genObjectNames 1
bindBuffer target $= Just buffer
@@ -237,7 +237,7 @@ textureArrayDescriptor (CompiledBuild stride tup@(_,_,True) _ _ _) =
ifp b x = if b then x else 0
textureArrayDescriptor _ = Nothing
createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject
-createBufferObject target (CompiledBuild _ _ _ arr len) = ptrToBuffer target arr len
+createBufferObject target (CompiledBuild _ _ _ arr len) = ptrToBuffer target len arr
mapListInsert :: (Ord k) => k -> a -> Map.Map k [a] -> Map.Map k [a]
mapListInsert key val map =
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
index 14f12e3..7b454e2 100644
--- a/Graphics/Glyph/GLMath.hs
+++ b/Graphics/Glyph/GLMath.hs
@@ -5,6 +5,7 @@ module Graphics.Glyph.GLMath where
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
@@ -86,7 +87,7 @@ module Graphics.Glyph.GLMath where
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
- Matrix (sx, ux, -fx, 0,
+ Matrix4 (sx, ux, -fx, 0,
sy, uy, -fy, 0,
sz, uz, -fz, 0,
-(s<.>e) , -(u'<.>e), (f<.>e), 1 )
@@ -101,7 +102,7 @@ module Graphics.Glyph.GLMath where
res23 = - 1
res32 = - (2 * zf * zn) / (zf - zn) in
trace ("res22=" ++ (show res22)) $
- Matrix (res00, 0, 0, 0,
+ Matrix4 (res00, 0, 0, 0,
0, res11, 0, 0,
0, 0, res22, res23,
0, 0, res32, 0)
@@ -133,7 +134,7 @@ module Graphics.Glyph.GLMath where
mat -*| tmp = glslMatMul mat tmp
glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
- glslMatMul (Matrix (m00,m01,m02,m03,
+ glslMatMul (Matrix4 (m00,m01,m02,m03,
m10,m11,m12,m13,
m20,m21,m22,m23,
m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
@@ -142,16 +143,19 @@ module Graphics.Glyph.GLMath where
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@(Matrix (m00,m01,m02,m03,
+ 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
- (Matrix (m00,m01,m02,m03,
+ (Matrix4 (m00,m01,m02,m03,
m10,m11,m12,m13,
m20,m21,m22,m23,
m30+v0,m31+v1,m32+v2,m33+v3))
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
index e359838..a000aa7 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -26,7 +26,8 @@ module Graphics.Glyph.GlyphObject (
Drawable, draw, newGlyphObject,
newDefaultGlyphObject,
startClosure,
- newDefaultGlyphObjectWithClosure
+ newDefaultGlyphObjectWithClosure,
+ drawInstances, numInstances, setNumInstances
) where
import Graphics.Glyph.BufferBuilder
@@ -54,7 +55,8 @@ data GlyphObject a = GlyphObject {
setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
setupRoutine2 :: (Maybe (GlyphObject a -> IO ())), -- Setup
teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
- primitiveMode :: PrimitiveMode
+ primitiveMode :: PrimitiveMode,
+ numInstances :: Int
}
$(declareSetters ''GlyphObject)
@@ -102,7 +104,7 @@ newGlyphObject :: BuilderM GLfloat x ->
newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mode = do
compiled <- compilingBuilder builder
buffer <- createBufferObject ArrayBuffer compiled
- return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode
+ return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode 1
prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
prepare a b = setSetupRoutine2 (Just b) a
@@ -114,10 +116,10 @@ teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
teardown a b = setTeardownRoutine (Just b) a
instance Drawable (GlyphObject a) where
- draw = drawInstances 1
+ draw = drawInstances <..> numInstances
drawInstances :: Int -> GlyphObject a -> IO ()
-drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 tearDown p) = do
+drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 tearDown p _) = do
{- Setup whatever we need for the object to draw itself -}
maybe (return ()) (Prelude.$obj) setup1
maybe (return ()) (Prelude.$obj) setup2
@@ -148,9 +150,9 @@ drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 t
liftMaybe _ = Nothing
instance (Show a) => Show (GlyphObject a) where
- show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ _ p) =
+ show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ _ p n) =
"[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
- " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++"]"
+ " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++" instances="++!n++"]"
newDefaultGlyphObject :: BuilderM GLfloat x -> a -> IO (GlyphObject a)
newDefaultGlyphObject builder resources =
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
index 546baa2..294871c 100644
--- a/Graphics/Glyph/Mat4.hs
+++ b/Graphics/Glyph/Mat4.hs
@@ -8,13 +8,13 @@ import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
-import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL (GLfloat,Uniform(..),uniform,UniformLocation(..),makeStateVar)
import Graphics.Rendering.OpenGL.Raw.Core31
-data Mat4 a = Matrix (a,a,a,a,
- a,a,a,a,
- a,a,a,a,
- a,a,a,a) | IdentityMatrix
+data Mat4 a = Matrix4 (a,a,a,a,
+ a,a,a,a,
+ a,a,a,a,
+ a,a,a,a) | IdentityMatrix
data Mat3 a = Matrix3 ( a,a,a,
a,a,a,
@@ -25,11 +25,46 @@ class StorableMatrix t a where
toPtr :: a t -> (Ptr t -> IO b) -> IO b
fromPtr :: Ptr t -> (a t -> IO b) -> IO b
+class Mat a where
+ inverse :: a -> Maybe a
+ transpose :: a -> a
+ determinate :: a -> Double
+ scale :: (Real b) => b -> a -> a
+
+instance (RealFloat a,Eq a) => Mat (Mat4 a) where
+ inverse = inv4
+ transpose = transpose4
+ determinate = det4
+ scale b = scale4 (realToFrac b)
+
+instance (RealFloat a,Eq a) => Mat (Mat3 a) where
+ transpose
+ (Matrix3 (a00,a01,a02,
+ a10,a11,a12,
+ a20,a21,a22)) = Matrix3 (a00,a10,a20,a01,a11,a21,a02,a12,a22)
+ determinate
+ (Matrix3 (a11,a12,a13,a21,a22,a23,a31,a32,a33)) =
+ realToFrac $
+ a11*a22*a33+a21*a32*a13+a31*a12*a23-a11*a32*a23-a31*a22*a13-a21*a12*a33
+
+ scale n' (Matrix3 (m11,m12,m13,m21,m22,m23,m31,m32,m33)) =
+ let n = realToFrac n' in
+ Matrix3 (m11*n,m12*n,m13*n,m21*n,m22*n,m23*n,m31*n,m32*n,m33*n)
+
+ inverse
+ m@(Matrix3 (a11,a12,a13,a21,a22,a23,a31,a32,a33)) =
+ let det = determinate m in
+ if det == 0 then Nothing else Just $
+ (1 / determinate m) `scale` Matrix3 (
+ a22*a33 - a23*a32, a13*a32 - a12*a33, a12*a23 - a13*a22,
+ a23*a31 - a21*a33, a11*a33 - a13*a31, a13*a21 - a11*a23,
+ a21*a32 - a22*a31, a12*a31 - a11*a32, a11*a22 - a12*a21)
+
instance (Storable t) => StorableMatrix t Mat4 where
fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:m10:m11:m12:m13:m14:m15:m16:_) =
- Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)
+ Matrix4 (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)
- toPtr (Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)) fun =
+ toPtr (Matrix4 (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)) fun =
allocaArray 16 $ \ptr -> do
pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16]
fun ptr
@@ -78,7 +113,7 @@ instance (Show a) => Show (Mat4 a) where
" 0 1 0 0\n" ++
" 0 0 1 0\n" ++
" 0 0 0 1 ]\n"
- show (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) =
+ show (Matrix4 (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) =
"["++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n" ++
" "++! m10 ++ " " ++! m11 ++ " " ++! m12 ++ " " ++! m13 ++ "\n" ++
" "++! m20 ++ " " ++! m21 ++ " " ++! m22 ++ " " ++! m23 ++ "\n" ++
@@ -89,18 +124,18 @@ instance (Show a) => Show (Mat4 a) where
translateMat4 :: (Num a) => Mat4 a -> (a,a,a,a) -> Mat4 a
-translateMat4 IdentityMatrix x = translateMat4 (Matrix (1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1)) x
-translateMat4 (Matrix (m00,m01,m02,m03,
+translateMat4 IdentityMatrix x = translateMat4 (Matrix4 (1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1)) x
+translateMat4 (Matrix4 (m00,m01,m02,m03,
m10,m11,m12,m13,
m20,m21,m22,m23,
m30,m31,m32,m33)) (v0,v1,v2,v3) =
- Matrix (m00,m01,m02,m03+v0,
+ Matrix4 (m00,m01,m02,m03+v0,
m10,m11,m12,m13+v1,
m20,m21,m22,m23+v2,
m30,m31,m32,m33+v3)
applyMatrix :: (Num a) => Mat4 a -> (a,a,a,a) -> (a,a,a,a)
-applyMatrix (Matrix (m00,m01,m02,m03,
+applyMatrix (Matrix4 (m00,m01,m02,m03,
m10,m11,m12,m13,
m20,m21,m22,m23,
m30,m31,m32,m33)) (v0,v1,v2,v3) =
@@ -112,13 +147,13 @@ applyMatrix (Matrix (m00,m01,m02,m03,
applyMatrix IdentityMatrix v = v
scaleMatrix :: (Num a) => Mat4 a -> (a,a,a) -> Mat4 a
-scaleMatrix IdentityMatrix (a,b,c) = Matrix ( a,0,0,0,
+scaleMatrix IdentityMatrix (a,b,c) = Matrix4 ( a,0,0,0,
0,b,0,0,
0,0,c,0,
0,0,0,1)
-scaleMatrix (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) (a,b,c)
- = Matrix ( m00*a,m01,m02,m03,
+scaleMatrix (Matrix4 (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) (a,b,c)
+ = Matrix4 ( m00*a,m01,m02,m03,
m10,m11*b,m12,m13,
m20,m21,m22*c,m23,
m30,m31,m32,m33)
@@ -135,15 +170,15 @@ mulMatrix4 :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
mulMatrix4 IdentityMatrix a = a
mulMatrix4 a IdentityMatrix = a
mulMatrix4
- (Matrix (a00,a01,a02,a03,
+ (Matrix4 (a00,a01,a02,a03,
a10,a11,a12,a13,
a20,a21,a22,a23,
a30,a31,a32,a33 ))
- (Matrix (b00,b01,b02,b03,
+ (Matrix4 (b00,b01,b02,b03,
b10,b11,b12,b13,
b20,b21,b22,b23,
b30,b31,b32,b33 )) =
- Matrix (b00*a00+b10*a01+b20*a02+b30*a03,
+ Matrix4 (b00*a00+b10*a01+b20*a02+b30*a03,
b01*a00+b11*a01+b21*a02+b31*a03,
b02*a00+b12*a01+b22*a02+b32*a03,
b03*a00+b13*a01+b23*a02+b33*a03,
@@ -167,31 +202,32 @@ mulMatrix4
(|*|) = mulMatrix4
transpose4 :: Mat4 a -> Mat4 a
-transpose4 (Matrix
+transpose4 (Matrix4
(m00,m01,m02,m03,
m10,m11,m12,m13,
m20,m21,m22,m23,
- m30,m31,m32,m33 )) = (Matrix (m00, m10, m20, m30,
+ m30,m31,m32,m33 )) = (Matrix4 (m00, m10, m20, m30,
m01, m11, m21, m31,
m02, m12, m22, m32,
m03, m13, m23, m33))
scale4 :: (Num a) => a -> Mat4 a -> Mat4 a
-scale4 n (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- Matrix (m11*n,m12*n,m13*n,m14*n,m21*n,m22*n,m23*n,m24*n,m31*n,m32*n,m33*n,m34*n,m41*n,m42*n,m43*n,m44*n)
-
-det4 :: (Num a) => Mat4 a -> a
-det4 (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- m11*m22*m33*m44 + m11*m23*m34*m42 + m11*m24*m32*m43
- + m12*m21*m34*m43 + m12*m23*m31*m44 + m12*m24*m33*m41
- + m13*m21*m32*m44 + m13*m22*m34*m41 + m13*m24*m31*m42
- + m14*m21*m33*m42 + m14*m22*m31*m43 + m14*m23*m32*m41
- - m11*m22*m34*m43 - m11*m23*m32*m44 - m11*m24*m33*m42
- - m12*m21*m33*m44 - m12*m23*m34*m41 - m12*m24*m31*m43
- - m13*m21*m34*m42 - m13*m22*m31*m44 - m13*m24*m32*m41
- - m14*m21*m32*m43 - m14*m22*m33*m41 - m14*m23*m31*m42
-
-inv4 :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat4 a)
-inv4 mat@(Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
+scale4 n (Matrix4 (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
+ Matrix4 (m11*n,m12*n,m13*n,m14*n,m21*n,m22*n,m23*n,m24*n,m31*n,m32*n,m33*n,m34*n,m41*n,m42*n,m43*n,m44*n)
+
+det4 :: (Real a,Fractional b) => Mat4 a -> b
+det4 (Matrix4 (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
+ realToFrac $
+ m11*m22*m33*m44 + m11*m23*m34*m42 + m11*m24*m32*m43
+ + m12*m21*m34*m43 + m12*m23*m31*m44 + m12*m24*m33*m41
+ + m13*m21*m32*m44 + m13*m22*m34*m41 + m13*m24*m31*m42
+ + m14*m21*m33*m42 + m14*m22*m31*m43 + m14*m23*m32*m41
+ - m11*m22*m34*m43 - m11*m23*m32*m44 - m11*m24*m33*m42
+ - m12*m21*m33*m44 - m12*m23*m34*m41 - m12*m24*m31*m43
+ - m13*m21*m34*m42 - m13*m22*m31*m44 - m13*m24*m32*m41
+ - m14*m21*m32*m43 - m14*m22*m33*m41 - m14*m23*m31*m42
+
+inv4 :: (RealFloat a,Eq a) => Mat4 a -> Maybe (Mat4 a)
+inv4 mat@(Matrix4 (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
let b11 = m22*m33*m44 + m23*m34*m42 + m24*m32*m43 - m22*m34*m43 - m23*m32*m44 - m24*m33*m42
b12 = m12*m34*m43 + m13*m32*m44 + m14*m33*m42 - m12*m33*m44 - m13*m34*m42 - m14*m32*m43
b13 = m12*m23*m44 + m13*m24*m42 + m14*m22*m43 - m12*m24*m43 - m13*m22*m44 - m14*m23*m42
@@ -210,14 +246,14 @@ inv4 mat@(Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m4
b44 = m11*m22*m33 + m12*m23*m31 + m13*m21*m32 - m11*m23*m32 - m12*m21*m33 - m13*m22*m31 in
case det4 mat of
0 -> Nothing
- det -> Just $ (1 / det) `scale4` Matrix (b11,b12,b13,b14,b21,b22,b23,b24,b31,b32,b33,b34,b41,b42,b43,b44)
+ det -> Just $ (1 / det) `scale4` Matrix4 (b11,b12,b13,b14,b21,b22,b23,b24,b31,b32,b33,b34,b41,b42,b43,b44)
trunc4 :: Mat4 a -> Mat3 a
-trunc4 (Matrix
+trunc4 (Matrix4
(m11,m12,m13,_,
m21,m22,m23,_,
m31,m32,m33,_,
_ , _ , _ ,_)) = Matrix3 (m11,m12,m13,m21,m22,m23,m31,m32,m33)
-toNormalMatrix :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat3 a)
+toNormalMatrix :: (RealFloat a,Eq a) => Mat4 a -> Maybe (Mat3 a)
toNormalMatrix mat = inv4 mat >>= return . trunc4 . transpose4
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
index ba3b54a..61cd3f0 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+
module Graphics.Glyph.Util where
import Data.Angle
@@ -5,10 +8,17 @@ import Graphics.Rendering.OpenGL
import Data.Maybe
import Data.Char
import Data.Either
+
import Control.Exception
+import Control.Monad
import Data.Foldable as Fold
+import Foreign.Ptr
+import Foreign.Marshal.Alloc
+
+import Data.Array.MArray
+
if' :: Bool -> a -> a -> a
if' True a _ = a
if' False _ a = a
@@ -16,6 +26,9 @@ if' False _ a = a
(?) :: Bool -> a -> a -> a
(?) = if'
+flipIf :: a -> a -> Bool -> a
+flipIf a b c = if c then a else b
+
int :: (Integral a, Num b) => a -> b
int = fromIntegral
@@ -119,6 +132,9 @@ zipWithT3 fu (a, b, c) (d, e, f) = (fu a d, fu b e, fu c f)
zipWithT4 :: (a -> b -> c) -> (a,a,a,a) -> (b,b,b,b) -> (c,c,c,c)
zipWithT4 fu (a, b, c, d) (e, f, g, h) = (fu a e, fu b f, fu c g, fu d h)
+zipWithT5 :: (a -> b -> c) -> (a,a,a,a,a) -> (b,b,b,b,b) -> (c,c,c,c,c)
+zipWithT5 fu (a, b, c, d, i) (e, f, g, h, j) = (fu a e, fu b f, fu c g, fu d h, fu i j)
+
toFloating :: (Real a, Floating b) => a -> b
toFloating = fromRational . toRational
@@ -237,6 +253,12 @@ dFold _ next _ = next
(!>>=) :: Monad m => m a -> (a -> m b) -> m b
(!>>=) a f = a !>> (flip (>>=) f)
+{- Objective function composition. Useful to say
+ - (drawArrays <..> numInstances) obj
+ -}
+(<..>) :: (b -> a -> c) -> (a -> b) -> a -> c
+(<..>) f1 f2 a = f1 (f2 a) a
+
toHex :: (Integral a,Show a) => a -> String
toHex n | n == 0 = ""
| otherwise =
@@ -255,3 +277,32 @@ maybeDefault a b = fromJust $ b >||> Just a
maybeDefaultM :: (Monad m) => Maybe a -> (a -> m ()) -> m () -> m ()
maybeDefaultM Nothing _ a = a
maybeDefaultM (Just a) b _ = b a
+
+data MonadPlusBuilder a b = MonadPlusBuilder a b
+
+plusM :: a -> MonadPlusBuilder a ()
+plusM a = MonadPlusBuilder a ()
+
+runMonadPlusBuilder :: MonadPlusBuilder a b -> a
+runMonadPlusBuilder (MonadPlusBuilder !a _) = a
+
+instance (MonadPlus a) => Monad (MonadPlusBuilder (a b)) where
+ return x = MonadPlusBuilder mzero x
+ MonadPlusBuilder a1 _ >> MonadPlusBuilder a2 b = MonadPlusBuilder (a1 `mplus` a2) b
+ builder@(MonadPlusBuilder _ b) >>= f = builder >> f b
+ fail = undefined
+
+untilM2 :: (Monad m) => (a -> m Bool) -> a -> (a -> m a) -> m a
+untilM2 cond ini bod = do
+ bool <- cond ini
+ if bool then return ini
+ else bod ini >>= \newini -> untilM2 cond newini bod
+
+(<!>) :: (MArray a e IO, Ix i) => a i e -> i -> StateVar e
+(<!>) arr idx =
+ let setter = writeArray arr idx
+ getter = readArray arr idx in
+ makeStateVar getter setter
+
+for :: [a] -> (a -> b) -> [b]
+for = flip map
diff --git a/Resources.hs b/Resources.hs
index bcc194a..24154e0 100644
--- a/Resources.hs
+++ b/Resources.hs
@@ -1,9 +1,14 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
module Resources where
import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.Image as SDLImg
+import Foreign.Storable
+import Foreign.Ptr
+import Foreign.Marshal.Array
+
import Graphics.Glyph.GLMath as V
import Graphics.Glyph.GlyphObject
import Graphics.Glyph.ObjLoader
@@ -13,16 +18,24 @@ import Graphics.SDL.SDLHelp
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Mat4
import Graphics.Glyph.Util
+import Graphics.Glyph.ExtendedGL
import Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL.Raw.Core31
import Control.Applicative
import Control.Monad
import Data.Angle
+import Data.Function
import Data.Setters
+import qualified Data.Sequence as Seq
+import Data.Sequence ((><),(|>),(<|))
+import qualified Data.Foldable as Fold
import Data.Maybe
import Debug.Trace
+import Foreign.Marshal.Array
+
import System.Exit
import System.FilePath
@@ -48,8 +61,11 @@ data Resources = Resources {
object :: GlyphObject (),
forest :: GlyphObject (),
+ jungle :: GlyphObject (),
+ waterObj :: GlyphObject (),
speed :: Int,
+ timeSpeed :: Int,
time :: Int,
rSkyboxObject :: GlyphObject (UniformLocation,UniformLocation)
}
@@ -69,6 +85,11 @@ eventHandle event res = do
case event of
KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess
+ KeyDown (Keysym SDLK_EQUALS _ _) ->
+ return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
+ KeyDown (Keysym SDLK_MINUS _ _) ->
+ return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res
+
KeyDown (Keysym SDLK_UP _ _) ->
return $ setRDPosition (CameraPosition eye th (ph+1)) res
KeyDown (Keysym SDLK_DOWN _ _) ->
@@ -109,40 +130,74 @@ eventHandle event res = do
displayHandle :: Resources -> IO Resources
displayHandle resources = do
let cameraPos@(CameraPosition _ th ph) = rPosition resources
+ let lighty = ((/10) . fromIntegral . time) resources
+
+ let logist c = (1 / (1 + 2.71828**(-c*x))) * 0.9 + 0.1
+ where x = sine $ Degrees (lighty)
- clearColor $= Color4 1.0 0.0 0.0 1.0
+ let _'::(GLfloat,GLfloat,GLfloat,GLfloat)
+ _'@(r,g,b,a)= ( logist 2+0.1, logist 10, (logist 15) + 0.1,(sine.Degrees) lighty)
+
+ clearColor $= Color4 0 0 0 0
clear [ColorBuffer, DepthBuffer]
SDL.flip $ rSurface resources
printErrors "Display"
depthFunc $= Nothing
- let lightPos = Vec4( 100 * (cosine . Degrees . fromIntegral . time) resources + 50,
- 100,
- 100 * (sine . Degrees . fromIntegral . time) resources + 50, 1 )
+ let lightPos = Vec4( 50,
+ 1000000 * (sine.Degrees $ lighty),
+ -1000000 * (cosine.Degrees . (/10) . fromIntegral . time) resources,
+ 1 )
cullFace $= Nothing
draw $ prepare (rSkyboxObject resources) $ \this -> do
let (matLoc,pmatLoc) = getResources this
uniform pmatLoc $= pMatrix resources
uniform matLoc $= buildMVMatrix (CameraPosition (Vec3 (0,0,0)) th ph)
+ uniform (UniformLocation 1) $= Vec4 (r,g,b,a)
vertexProgramPointSize $= Enabled
depthFunc $= Just Less
+
let l_mvMatrix = buildMVMatrix $ cameraPos
+ let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix
+
cullFace $= Just Front
draw $ prepare (object resources) $ \_ -> do
uniform (UniformLocation 5) $= l_mvMatrix
uniform (UniformLocation 4) $= pMatrix resources
uniform (UniformLocation 6) $= l_mvMatrix `glslMatMul` lightPos
+ uniform (UniformLocation 7) $= normalMatrix
+ uniform (UniformLocation 8) $= Vec4 (r,g,b,a::GLfloat)
return ()
- cullFace $= Nothing
blend $= Enabled
+ cullFace $= Just Back
blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)
draw $ prepare (forest resources) $ \_ -> do
uniform (UniformLocation 5) $= l_mvMatrix
uniform (UniformLocation 4) $= pMatrix resources
uniform (UniformLocation 7) $= l_mvMatrix `glslMatMul` lightPos
+ uniform (UniformLocation 8) $= Index1 (fromIntegral $ time resources::GLfloat)
+ uniform (UniformLocation 9) $= normalMatrix
+
+ uniform (UniformLocation 10) $= Vec4 (r,g,b,a::GLfloat)
+ return ()
+
+ draw $ prepare (jungle resources) $ \_ -> do
+ uniform (UniformLocation 5) $= l_mvMatrix
+ uniform (UniformLocation 4) $= pMatrix resources
+ uniform (UniformLocation 7) $= l_mvMatrix `glslMatMul` lightPos
+ uniform (UniformLocation 8) $= Index1 (fromIntegral $ time resources::GLfloat)
+ uniform (UniformLocation 9) $= normalMatrix
+
+ uniform (UniformLocation 10) $= Vec4 (r,g,b,a::GLfloat)
+ return ()
+
+ draw $ prepare (waterObj resources) $ \_ -> do
+ uniform (UniformLocation 4) $= pMatrix resources
+ uniform (UniformLocation 5) $= l_mvMatrix
+ uniform (UniformLocation 7) $= normalMatrix
return ()
SDL.glSwapBuffers
@@ -151,7 +206,8 @@ displayHandle resources = do
updateHandle :: Resources -> IO Resources
updateHandle res = do
return $ setRPosition (rPosition res `cAdd` rDPosition res) $
- setTime (time res + 1) res
+ let new = ((+) `on` (Prelude.$ res)) timeSpeed time in
+ setTime new res
where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
let fri = fromIntegral
x' = (fri $ speed res) `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) in
@@ -197,26 +253,56 @@ buildTerrainObject builder = do
uniform dYlocation $= Index1 (dy::GLfloat)
printErrors "terrainObjectClosure"
-buildForestObject :: BuilderM GLfloat b -> IO (GlyphObject ())
-buildForestObject builder = do
+buildForestObject :: Seq.Seq GLfloat -> String -> String -> IO (GlyphObject ())
+buildForestObject seq obj tex = do
+ let bufferIO :: IO BufferObject
+ bufferIO = (newArray . Fold.toList) seq >>= ptrToBuffer ArrayBuffer (Seq.length seq * 4)
+
+ !buffer <- bufferIO
+ (log',file) <- loadObjFile obj :: IO ([String],ObjectFile GLfloat)
+ mapM_ putStrLn log'
+ let !treeF = trace "build tree" $ (basicBuildObject file :: BuilderM GLfloat ())
+
forestProg <- loadProgramSafe'
"shaders/forest.vert" "shaders/forest.frag" (Nothing::Maybe String)
- woodTexture <- load "textures/wood_low.png" >>= textureFromSurface
+ woodTexture <- load tex >>= textureFromSurface
let (dx,dy) = (mapT2 $ (1/).fromIntegral) (textureSize woodTexture)
dXlocation <- get $ uniformLocation forestProg "dX"
dYlocation <- get $ uniformLocation forestProg "dY"
- newDefaultGlyphObjectWithClosure builder () $ \_ -> do
+ obj <- newDefaultGlyphObjectWithClosure treeF () $ \_ -> do
currentProgram $= Just forestProg
setupTexturing woodTexture (UniformLocation 6) 0
uniform dXlocation $= (Index1 $ (dx::GLfloat))
uniform dYlocation $= (Index1 $ (dy::GLfloat))
+
+ bindBuffer ArrayBuffer $= Just buffer
+
+ let declareAttr location nelem offset = do
+ vertexAttribPointer location $=
+ (ToFloat, VertexArrayDescriptor
+ nelem Float (fromIntegral $ (3+3+2+1)*sizeOf (0::GLfloat))
+ (wordPtrToPtr offset))
+ vertexAttribArray location $= Enabled
+ vertexAttributeDivisor location $= 1
+
+ declareAttr (AttribLocation 10) 3 0
+ declareAttr (AttribLocation 11) 3 (3*4)
+ declareAttr (AttribLocation 12) 2 (6*4)
+ declareAttr (AttribLocation 13) 1 (8*4)
+
printErrors "forestClosure"
+ putStrLn $ "N trees = " ++! (Seq.length seq `div` 3)
+ return $ setNumInstances (Seq.length seq `div` 3) obj
-makeResources :: SDL.Surface -> BuilderM GLfloat b -> BuilderM GLfloat b -> IO Resources
-makeResources surf builder forestB = do
+makeResources :: SDL.Surface -> BuilderM GLfloat b ->
+ Seq.Seq GLfloat -> Seq.Seq GLfloat ->
+ BuilderM GLfloat a -> IO Resources
+makeResources surf builder forestB jungleB water = do
let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
+ waterProg <- loadProgramSafe'
+ "shaders/water.vert" "shaders/water.frag" (Nothing::Maybe String)
Resources
<$> pure surf
<*> do CameraPosition
@@ -230,8 +316,13 @@ makeResources surf builder forestB = do
<*> pure pMatrix'
<*> pure pMatrix'
<*> buildTerrainObject builder
- <*> buildForestObject forestB
+ <*> buildForestObject forestB "tree.obj" "textures/wood_low.png"
+ <*> buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png"
+ <*> (newDefaultGlyphObjectWithClosure water () $ \_ -> do
+ currentProgram $= Just waterProg
+ )
<*> pure 0
+ <*> pure 1
<*> pure 0
<*> skyboxObject
@@ -265,20 +356,54 @@ skyboxSides dist = do
(bTexture2(0.5,0), bVertex3 ( dist, dist, dist)),
(bTexture2(0.25,0) , bVertex3 ( dist, dist, -dist)),
(bTexture2(0.25,1) , bVertex3 ( dist, -dist, -dist))]
+
in
mapM_ (uncurry (>>)) q
+skyboxTop :: GLfloat -> BuilderM GLfloat ()
+skyboxTop dist = do
+ mapM_ (uncurry (>>)) $
+ trianglesFromQuads
+ [(bTexture2(1,0), bVertex3 ( -dist, dist, dist)),
+ (bTexture2(1,1), bVertex3 ( dist, dist, dist)),
+ (bTexture2(0,1), bVertex3 ( dist, dist, -dist)),
+ (bTexture2(0,0), bVertex3 ( -dist, dist, -dist))]
+
skyboxObject :: IO (GlyphObject (UniformLocation,UniformLocation))
skyboxObject = do
prog <- loadProgramSafe' "shaders/sky.vert" "shaders/sky.frag" (Nothing::Maybe String)
texLoc <- get $ uniformLocation prog "texture"
+ texLocNight <- get $ uniformLocation prog "night_tex"
matLoc <- get $ uniformLocation prog "mvMatrix"
pmatLoc <- get $ uniformLocation prog "pjMatrix"
+
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
texture <- load "textures/skybox_sides.png" >>= textureFromSurface
- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
+ texture2 <- load "textures/skybox_sides_night.png" >>= textureFromSurface
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
+ textureTop <- load "textures/skybox_top.png" >>= textureFromSurface
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
+ textureTopNight <- load "textures/skybox_top_night.png" >>= textureFromSurface
+
+ topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do
+ setupTexturing textureTop texLoc 2
+ setupTexturing textureTopNight texLocNight 3
+
+ obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do
currentProgram $= Just prog
setupTexturing texture texLoc 0
+ setupTexturing texture2 texLocNight 1
printErrors "Skybox"
+ (return . teardown obj) $ \_ -> do
+ draw topObj
+
+
+
prepareSkybox :: Mat4 GLfloat -> Mat4 GLfloat -> GlyphObject (Mat4 GLfloat -> Mat4 GLfloat -> IO ()) -> IO ()
prepareSkybox proj lookat obj = do
(getResources obj) proj lookat
diff --git a/shaders/.basic.frag.swp b/shaders/.basic.frag.swp
new file mode 100644
index 0000000..66aabb3
--- /dev/null
+++ b/shaders/.basic.frag.swp
Binary files differ
diff --git a/shaders/.water.frag.swp b/shaders/.water.frag.swp
new file mode 100644
index 0000000..73b3be2
--- /dev/null
+++ b/shaders/.water.frag.swp
Binary files differ
diff --git a/shaders/basic.frag b/shaders/basic.frag
new file mode 100644
index 0000000..4d7683c
--- /dev/null
+++ b/shaders/basic.frag
@@ -0,0 +1,83 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(location = 0) out vec4 frag_color ;
+layout(location = 6) uniform vec4 lightPos ;
+
+layout(location = 8) uniform vec4 globalAmbient ;
+uniform float dX ;
+uniform float dY ;
+
+uniform mat4 mvMatrix ;
+uniform mat4 pjMatrix ;
+
+in vec3 normal ;
+
+uniform sampler2D textures[8] ;
+
+in float texture_blend[8] ;
+in vec2 texcoord ;
+in vec4 position ;
+
+vec3 sample(float xc,float yc) {
+ vec3 color = vec3(0);
+ for ( int i = 0 ; i < 8 ; ++ i ) {
+ vec4 tmp = texture2D(textures[i], texcoord + vec2(xc,yc)) ;
+ color += vec3(tmp) * texture_blend[i] ;
+ }
+ return color ;
+}
+
+vec3 sample2(int tex, float xc,float yc) {
+ vec3 color = vec3(0);
+ vec4 tmp = texture2D(textures[tex], texcoord + vec2(xc,yc)) ;
+ color += vec3(tmp) ;
+ return color ;
+}
+
+int dominentTexture() {
+ float m = 0.0 ;
+ int ret = 0;
+ for( int i = 0 ; i < 8 ; ++ i ) {
+ if( texture_blend [i] > m ) {
+ m = texture_blend[i] ;
+ ret = i ;
+ }
+ }
+ return ret ;
+}
+
+vec3 calNormChange( vec3 norm, vec3 down, vec3 right ) {
+ int dom = dominentTexture() ;
+ float x00 = length(sample2(dom,-dX, dY));
+ float x01 = length(sample2(dom, 0, dY));
+ float x02 = length(sample2(dom, dX, dY));
+
+ float x10 = length(sample2(dom,-dX, 0));
+ float x11 = length(sample2(dom, 0, 0));
+ float x12 = length(sample2(dom, dX, 0));
+
+ float x20 = length(sample2(dom,-dX,-dY));
+ float x21 = length(sample2(dom, 0,-dY));
+ float x22 = length(sample2(dom, dX,-dY));
+
+ down = ((x11 - x00) + (x11 - x01) + (x11 - x02) - (x11 - x20) - (x11 - x21) - (x11 - x22)) * down ;
+ right = ((x11 - x00) + (x11 - x10) + (x11 - x20) - (x11 - x02) - (x11 - x12) - (x11 - x22)) * right ;
+
+ return (norm + down + right) / 3.0 ;
+}
+
+void main() {
+ vec3 down = vec3( 0.0, -1.0, 0.0 ) ;
+ vec3 right = normalize(cross( normal, down )) ;
+ down = normalize(cross( normal, right ) );
+ vec3 newNorm = calNormChange(normal,down,right) ;
+
+ vec3 color = sample(0,0) ;
+
+ float prod = dot( normalize(-newNorm), normalize(vec3(lightPos - position)));
+ vec3 intensity = vec3(prod,prod,max(prod,0.4)) ;
+
+ frag_color = vec4(color * intensity,1) * vec4(normalize(globalAmbient.xyz),1.0);
+}
diff --git a/shaders/basic.vert b/shaders/basic.vert
new file mode 100644
index 0000000..e1abeb5
--- /dev/null
+++ b/shaders/basic.vert
@@ -0,0 +1,27 @@
+#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 vec4 in_color ;
+layout(location = 1) in vec3 in_normal ;
+layout(location = 3) in vec2 in_texcoord ;
+
+layout(location = 4) uniform mat4 pjMatrix ;
+layout(location = 5) uniform mat4 mvMatrix ;
+layout(location = 7) uniform mat3 normalMatrix ;
+
+out vec2 texcoord ;
+out vec4 position ;
+out vec3 normal ;
+
+out float texture_blend[8] ;
+
+void main() {
+ gl_Position = pjMatrix * (position = mvMatrix * vec4(in_position,1.0)) ;
+ texcoord = in_texcoord ;
+ normal = normalMatrix * in_normal ;
+ for ( int i = 0 ; i < 8 ; ++ i )
+ texture_blend[i] = 0 ;
+ texture_blend[int(clamp(round(in_color.a),0,8))] = 1.0 ;
+}
diff --git a/shaders/forest.frag b/shaders/forest.frag
new file mode 100644
index 0000000..1cad806
--- /dev/null
+++ b/shaders/forest.frag
@@ -0,0 +1,53 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(location = 0) out vec4 frag_color ;
+
+uniform mat4 mvMatrix ;
+uniform mat4 pjMatrix ;
+layout(location = 6) uniform sampler2D texture ;
+layout(location = 7) uniform vec4 light ;
+layout(location = 10) uniform vec4 globalAmbient ;
+
+uniform float dX ;
+uniform float dY ;
+
+in vec2 texposition ;
+in vec3 normal ;
+in vec4 frag_position ;
+
+vec4 sample(float xc,float yc) {
+ return texture2D(texture,texposition + vec2(xc,yc));
+}
+
+vec3 calNormChange( vec3 norm, vec3 down, vec3 right ) {
+ float x00 = 1 - sample(-dX, dY).a ;
+ float x01 = 1 - sample( 0, dY).a ;
+ float x02 = 1 - sample( dX, dY).a ;
+
+ float x10 = 1 - sample(-dX, 0).a ;
+ float x11 = 1 - sample( 0, 0).a ;
+ float x12 = 1 - sample( dX, 0).a ;
+
+ float x20 = 1 - sample(-dX,-dY).a ;
+ float x21 = 1 - sample( 0,-dY).a ;
+ float x22 = 1 - sample( dX,-dY).a ;
+
+ down = ((x11 - x00) + (x11 - x01) + (x11 - x02) - (x11 - x20) - (x11 - x21) - (x11 - x22)) * down ;
+ right = ((x11 - x00) + (x11 - x10) + (x11 - x20) - (x11 - x02) - (x11 - x12) - (x11 - x22)) * right ;
+
+ return (right*2 + down*2 + norm) / 5.0 ;
+}
+
+void main() {
+ vec3 down = vec3( 0, -1, 0 ) ;
+ vec3 right = normalize(cross( normal, down )) ;
+ down = normalize(cross( normal, right ) );
+ vec3 newNorm = calNormChange( normal, down, right ) ;
+
+ vec4 col = texture2D(texture,texposition) ;
+ float coef = max(dot( normalize(newNorm),
+ normalize(vec3(frag_position - light)) ),0) + (globalAmbient.a/4.0) ;
+ frag_color = vec4( col.xyz * coef * globalAmbient.xyz, col.a);
+}
diff --git a/shaders/forest.geom b/shaders/forest.geom
new file mode 100644
index 0000000..0c0cafb
--- /dev/null
+++ b/shaders/forest.geom
@@ -0,0 +1,69 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(points) in ;
+layout(triangle_strip, max_vertices=82) out;
+
+layout(location = 4) uniform mat4 pjMatrix ;
+layout(location = 5) uniform mat4 mvMatrix ;
+
+out vec2 texposition;
+out vec3 normal ;
+out vec4 frag_position ;
+
+void vertex( vec4 pos ) {
+ normal = - inverse(transpose(mat3(mvMatrix))) * vec3( pos.x, 0, pos.z ) ;
+ gl_Position = pjMatrix * (frag_position = gl_in[0].gl_Position + (mvMatrix * pos)) ;
+ EmitVertex() ;
+}
+
+void main() {
+ float r = 0.045 ;
+ float th = 0.00 ;
+ float h = 0.4 ;
+ for( ; th < 6.4 ; th += 1.0 ) {
+ float c = r * cos( th ) ;
+ float s = r * sin( th ) ;
+ float c2 = r * cos( th + 1.0 ) ;
+ float s2 = r * sin( th + 1.0 ) ;
+
+ float tex_x = th / 6.4 / 2.0;
+ float tex_x2 = (th+1.0) / 6.4 / 2.0 ;
+ texposition = vec2(tex_x, 0);
+ vertex( vec4(c, 0.0, s, 0) ) ;
+ texposition = vec2(tex_x, 1);
+ vertex( vec4(c, h, s, 0) ) ;
+ texposition = vec2(tex_x2, 0);
+ vertex( vec4(c2, h, s2, 0) ) ;
+
+ texposition = vec2(tex_x, 0);
+ vertex( vec4(c, 0.0, s, 0) ) ;
+ texposition = vec2(tex_x2, 0);
+ vertex( vec4(c2, 0, s2, 0) ) ;
+ texposition = vec2(tex_x2, 1);
+ vertex( vec4(c2, h, s2, 0) ) ;
+ }
+
+ for( th = 0; th < 6.4 ; th += 1.0 ) {
+ float c = (r*4) * cos( th ) ;
+ float s = (r*4) * sin( th ) ;
+ float tex_x = th / 6.4 / 2.0 + 0.5;
+ texposition = vec2(tex_x, 1);
+ vertex( vec4(0,h*2,0,0) ) ;
+ texposition = vec2(tex_x, 0);
+ vertex( vec4(s,h/2,c,0) ) ;
+ }
+
+ for( th = 0; th < 6.4 ; th += 1.0 ) {
+ float c = (r*6) * cos( th ) ;
+ float s = (r*6) * sin( th ) ;
+ float tex_x = th / 6.4 / 2.0 + 0.5;
+ texposition = vec2(tex_x, 1);
+ vertex( vec4(0,h,0,0) ) ;
+ texposition = vec2(tex_x, 0);
+ vertex( vec4(s,h/4,c,0) ) ;
+ }
+
+ EndPrimitive();
+}
diff --git a/shaders/forest.vert b/shaders/forest.vert
new file mode 100644
index 0000000..8fb9528
--- /dev/null
+++ b/shaders/forest.vert
@@ -0,0 +1,44 @@
+#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 vec4 in_color ;
+layout(location = 1) in vec3 in_normal ;
+layout(location = 3) in vec2 in_texcoord ;
+
+layout(location = 4) uniform mat4 pjMatrix ;
+layout(location = 5) uniform mat4 mvMatrix ;
+layout(location = 8) uniform float time ;
+layout(location = 9) uniform mat3 normalMatrix ;
+
+layout(location = 10) in vec3 in_translation ;
+layout(location = 11) in vec3 in_scale ;
+layout(location = 12) in vec2 in_sincos_rot ;
+layout(location = 13) in float noise ;
+
+out vec2 texposition ;
+out vec3 normal ;
+out vec4 frag_position ;
+
+void main() {
+ float s = in_sincos_rot.x ;
+ float c = in_sincos_rot.y ;
+
+ mat3 rot = mat3( c,0,s,
+ 0,1,0,
+ -s,0,c ) ;
+ normal =-rot * normalMatrix * in_normal ;
+ texposition = in_texcoord ;
+
+ vec3 real_pos1 = (rot * in_position) * in_scale ;
+
+ float val = sin(( (time+noise) * noise) / 100.0) / 30.0 * pow(real_pos1.y,2) ;
+ s = sin( val ) ; c = cos( val ) ;
+ rot = mat3( c, -s, 0,
+ s, c, 0,
+ 0, 0, 1 );
+
+ vec3 real_pos = (rot * real_pos1) + in_translation ;
+ gl_Position = pjMatrix * (frag_position = mvMatrix * vec4(real_pos,1.0) );
+}
diff --git a/shaders/sky.frag b/shaders/sky.frag
new file mode 100644
index 0000000..743f538
--- /dev/null
+++ b/shaders/sky.frag
@@ -0,0 +1,18 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(location = 0) out vec4 frag_color ;
+layout(location = 1) uniform vec4 globalAmbient ;
+
+uniform sampler2D texture ;
+uniform sampler2D night_tex ;
+in vec2 texcoord;
+
+void main() {
+ vec3 color2 = texture2D(texture,texcoord).xyz ;
+ frag_color =
+ mix(texture2D(night_tex,texcoord) * (1-globalAmbient.a),
+ texture2D(texture,texcoord) * vec4(normalize(globalAmbient.xyz),1),
+ (globalAmbient.a + 1) / 2) ;
+}
diff --git a/shaders/sky.vert b/shaders/sky.vert
new file mode 100644
index 0000000..87d919b
--- /dev/null
+++ b/shaders/sky.vert
@@ -0,0 +1,18 @@
+#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 vec4 in_color ;
+layout(location = 1) in vec3 in_normal ;
+layout(location = 3) in vec2 in_texcoord ;
+
+uniform mat4 mvMatrix ;
+uniform mat4 pjMatrix ;
+
+out vec2 texcoord ;
+
+void main() {
+ gl_Position = pjMatrix * mvMatrix * vec4(in_position,1.0);
+ texcoord = in_texcoord ;
+}
diff --git a/shaders/water.frag b/shaders/water.frag
new file mode 100644
index 0000000..8a0dd0b
--- /dev/null
+++ b/shaders/water.frag
@@ -0,0 +1,9 @@
+#version 150
+#extension GL_ARB_explicit_attrib_location : enable
+#extension GL_ARB_explicit_uniform_location : enable
+
+layout(location = 0) out vec4 frag_color ;
+
+void main() {
+ frag_color = vec4(0.0,0.3,0.7,0.5) ;
+}
diff --git a/shaders/water.vert b/shaders/water.vert
new file mode 100644
index 0000000..1db6dc5
--- /dev/null
+++ b/shaders/water.vert
@@ -0,0 +1,16 @@
+#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 vec4 in_color ;
+layout(location = 1) in vec3 in_normal ;
+layout(location = 3) in vec2 in_texcoord ;
+
+layout(location = 4) uniform mat4 pjMatrix ;
+layout(location = 5) uniform mat4 mvMatrix ;
+layout(location = 7) uniform mat3 normalMatrix ;
+
+void main() {
+ gl_Position = pjMatrix * mvMatrix * vec4( in_position, 1.0 );
+}
generated by cgit (git 2.34.1) at 2025-04-28 19:49:04 +0000