diff options
| -rw-r--r-- | Final.hs | 156 | ||||
| -rw-r--r-- | Graphics/Glyph/ArrayGenerator.hs | 33 | ||||
| -rw-r--r-- | Graphics/Glyph/BufferBuilder.hs | 6 | ||||
| -rw-r--r-- | Graphics/Glyph/GLMath.hs | 14 | ||||
| -rw-r--r-- | Graphics/Glyph/GlyphObject.hs | 16 | ||||
| -rw-r--r-- | Graphics/Glyph/Mat4.hs | 114 | ||||
| -rw-r--r-- | Graphics/Glyph/Util.hs | 51 | ||||
| -rw-r--r-- | Resources.hs | 153 | ||||
| -rw-r--r-- | shaders/.basic.frag.swp | bin | 0 -> 12288 bytes | |||
| -rw-r--r-- | shaders/.water.frag.swp | bin | 0 -> 12288 bytes | |||
| -rw-r--r-- | shaders/basic.frag | 83 | ||||
| -rw-r--r-- | shaders/basic.vert | 27 | ||||
| -rw-r--r-- | shaders/forest.frag | 53 | ||||
| -rw-r--r-- | shaders/forest.geom | 69 | ||||
| -rw-r--r-- | shaders/forest.vert | 44 | ||||
| -rw-r--r-- | shaders/sky.frag | 18 | ||||
| -rw-r--r-- | shaders/sky.vert | 18 | ||||
| -rw-r--r-- | shaders/water.frag | 9 | ||||
| -rw-r--r-- | shaders/water.vert | 16 |
19 files changed, 781 insertions, 99 deletions
@@ -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 $= Ju |