added real water

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.