added real water

6 files changed, 180 insertions, 54 deletions

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