6 files changed, 752 insertions, 0 deletions
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
new file mode 100644
index 0000000..e43e48a
--- /dev/null
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Graphics.Glyph.BufferBuilder where
+
+import Control.Monad
+import Graphics.Rendering.OpenGL
+import Foreign.Storable
+import Foreign.Ptr
+import Data.Array.Storable
+import Data.Setters
+import Debug.Trace
+import qualified Data.Foldable as Fold
+import Data.Sequence as Seq
+
+import Graphics.Glyph.Mat4
+import Graphics.Glyph.Util
+
+import System.IO.Unsafe
+
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+bufferSize :: BufferBuilder3D -> Int
+bufferSize End = 0
+bufferSize (Plot _ _ l _) = l
+
+nelem :: BufferBuilder3D -> Int
+nelem End = 0
+nelem (Plot _ _ _ l) = l
+
+sizeofGLfloat :: Int
+sizeofGLfloat = 4
+
+{- A state monad that keeps track of operations
+ - and will compile them into a buffer -}
+data Builder b a = Builder {
+    bList :: Seq (BuildDatum b),
+    bReturn :: a
+} | BuildError String
+
+data BuildDatum b =
+    VertexLink (b,b,b)  |
+    NormalLink (b,b,b)  |
+    ColorLink (b,b,b,b) |
+    TextureLink (b,b) deriving Show
+
+data CompiledBuild b = CompiledBuild {
+    bStride :: Int,
+    bEnabled :: (Bool,Bool,Bool),
+    nElems  :: Int,
+    array :: StorableArray Int b
+}
+
+bufferLength :: (Integral a) => CompiledBuild b -> a
+bufferLength = fromIntegral . nElems
+
+instance Show (CompiledBuild x) where
+    show (CompiledBuild stride enabled n _) =
+        "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++"]"
+
+instance (Num t) => Monad (Builder t) where
+    (Builder lst1 _) >> (Builder lst2 ret) = Builder (lst2 >< lst1) ret
+    BuildError str >> _ = BuildError str
+    _ >> BuildError str = BuildError str
+
+    b1@(Builder _ ret1) >>= func = b1 >> func ret1
+    BuildError str >>= _ = BuildError str
+
+    return = Builder empty
+    fail = BuildError
+
+{- Add a vertex to the current builder -}
+bVertex3 :: (a,a,a) -> Builder a ()
+bVertex3 vert = Builder (Seq.singleton $ VertexLink vert) ()
+
+bTexture2 :: (a,a) -> Builder a ()
+bTexture2 tex = Builder (Seq.singleton $ TextureLink tex) ()
+
+bNormal3 :: (a,a,a) -> Builder a ()
+bNormal3 norm = Builder (Seq.singleton $ NormalLink norm) ()
+
+bColor4 :: (a,a,a,a) -> Builder a ()
+bColor4 col = Builder (Seq.singleton $ ColorLink col) ()
+
+compilingBuilder :: (Storable b, Num b, Show b) => Builder b x -> IO (CompiledBuild b)
+compilingBuilder (Builder lst _) = do
+    -- Size of the elements
+    let sizeof = sizeOf $ tmp (Seq.index lst 0)
+                  where tmp (VertexLink (a,_,_)) = a
+                        tmp _ = 0
+    {- Simply figure out what types of elementse
+     - exist in this buffer -}
+    let en@(bn,bc,bt) = Fold.foldl (\(bn,bc,bt) ele ->
+                                case ele of
+                                    NormalLink _ -> (True,bc,bt)
+                                    ColorLink _ -> (bn,True,bt)
+                                    TextureLink _ -> (bn,bc,True)
+                                    VertexLink _ -> (bn,bc,bt)) (False,False,False) lst
+    {- Calculate the stride; number of floats per element -}
+    let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof
+                    where (?) True = 1
+                          (?) False = 0
+    --             Cur color normal texture buffer
+    let (_,_,_,buffer) =
+         Fold.foldl (\(cn,cc,ct,ll) ele ->
+                    -- trace ("foldl " ++! ele) $
+                    case ele of
+                        NormalLink nn -> (nn,cc,ct,ll)
+                        ColorLink nc -> (cn,nc,ct,ll)
+                        TextureLink nt -> (cn,cc,nt,ll)
+                        VertexLink vert ->
+                         (cn,cc,ct,
+                            ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct)
+                            )) ( (0,0,0), (0,0,0,0), (0,0), Seq.empty ) (Seq.reverse lst)
+
+    arr <- newListArray (0,Seq.length buffer) (Fold.toList buffer)
+    ((putStrLn.("Compiled: "++!))>&>return) $ CompiledBuild stride en (Seq.length buffer `div` stride * sizeof) arr
+
+                
+    where
+        tp2 True (a,b)  = Seq.fromList [a,b]
+        tp2 False _  = empty
+
+        tp3 True (a,b,c) = Seq.fromList [a,b,c]
+        tp3 False _ = empty
+
+        tp4 True (a,b,c,d) = Seq.fromList [a,b,c,d]
+        tp4 False _ = empty
+
+storableArrayToBuffer :: (Storable el) => BufferTarget -> StorableArray Int el -> IO BufferObject
+storableArrayToBuffer target arr = do
+    let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
+    [buffer] <- genObjectNames 1
+    bindBuffer target $= Just buffer
+    len <- getBounds arr >>= (\(a,b) -> return $ (b - a) * sizeof )
+    withStorableArray arr $ \ptr ->
+        bufferData target $= (fromIntegral len, ptr, StaticDraw)
+    return buffer
+
+vertexArrayDescriptor :: CompiledBuild GLfloat -> VertexArrayDescriptor GLfloat
+vertexArrayDescriptor (CompiledBuild stride _ _ _) = VertexArrayDescriptor 3 Float (fromIntegral stride) (wordPtrToPtr 0)
+
+normalArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
+normalArrayDescriptor (CompiledBuild stride (True,_,_) _ _) =
+                Just $ VertexArrayDescriptor 3 Float
+                        (fromIntegral stride) (wordPtrToPtr (3*4))
+normalArrayDescriptor  _ = Nothing
+
+colorArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
+colorArrayDescriptor (CompiledBuild stride tup@(_,True,_) _ _) =
+                Just $ VertexArrayDescriptor 4 Float
+                        (fromIntegral stride) (wordPtrToPtr (offset tup))
+                where offset (b1,_,_) = if b1 then (6*4) else (3*4)
+                        
+colorArrayDescriptor  _ = Nothing
+
+textureArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
+textureArrayDescriptor (CompiledBuild stride tup@(_,_,True) _ _) =
+                Just $ VertexArrayDescriptor 2 Float
+                        (fromIntegral stride) (wordPtrToPtr (offset tup))
+                where offset (b1,b2,_) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
+                      ifp b x = if b then x else 0  
+textureArrayDescriptor  _ = Nothing
+createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject
+createBufferObject target (CompiledBuild _ _ _ arr) = storableArrayToBuffer target arr
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
new file mode 100644
index 0000000..bec796c
--- /dev/null
+++ b/Graphics/Glyph/GLMath.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.GLMath where
+    import Graphics.Glyph.Mat4
+    import qualified Graphics.Rendering.OpenGL as GL
+    import Graphics.Rendering.OpenGL (GLfloat,Uniform,Vertex3(..),uniform,UniformComponent)
+    import Data.Angle
+    import Debug.Trace
+
+    data Vec2 a = Vec2 (a,a) deriving Show
+    data Vec3 a = Vec3 (a,a,a) deriving Show
+    data Vec4 a = Vec4 (a,a,a,a) deriving Show
+
+    instance UniformComponent a => Uniform (Vec3 a) where
+        uniform loc = GL.makeStateVar
+                        (do
+                            (Vertex3 x y z) <-
+                                GL.get (uniform loc)
+                            return (Vec3 (x,y,z)) )
+                        (\(Vec3 (x,y,z)) -> uniform loc GL.$= Vertex3 x y z)
+
+    class (Floating flT) => Vector flT b where
+        (<+>) :: b flT -> b flT -> b flT
+        (<->) :: b flT -> b flT -> b flT
+        norm :: b flT -> flT
+        normalize :: b flT -> b flT
+        vDot :: b flT -> b flT -> flT
+        vScale :: flT -> b flT -> b flT
+
+
+    (<.>) :: (Vector a b) => b a -> b a -> a
+    (<.>) = vDot
+
+    (|||) :: (Vector a b) => b a -> a
+    (|||) = norm
+
+    instance (Floating flT) => Vector flT Vec2 where
+        (<+>) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a+c,b+d)
+        (<->) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a-c,b-d)
+        vDot (Vec2 (a,b)) (Vec2 (c,d)) = a * c + b * d
+        vScale c (Vec2 (a,b)) = Vec2 (a*c,b*c)
+        norm (Vec2 (a,b)) = sqrt (a*a + b*b)
+        normalize vec@(Vec2 (a,b)) = 
+            let n = norm vec in Vec2 (a/n,b/n)
+
+    instance (Floating flT) => Vector flT Vec3 where
+        (<+>) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a+d,b+e,c+f)
+        (<->) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a-d,b-e,c-f)
+        vDot (Vec3 (a,b,c)) (Vec3 (d,e,f)) = a * d + b * e + c * f
+        vScale x (Vec3 (a,b,c)) = Vec3 (a*x,b*x,c*x)
+        norm (Vec3 (a,b,c)) = sqrt (a*a + b*b + c*c)
+        normalize vec@(Vec3 (a,b,c)) = 
+            let n = norm vec in Vec3 (a/n,b/n,c/n)
+
+    instance (Floating flT) => Vector flT Vec4 where
+        (<+>) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a+d,b+e,c+f,g+h)
+        (<->) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a-d,b-e,c-f,g-h)
+        vDot  (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = a * d + b * e + c * f + g * h
+        vScale x (Vec4 (a,b,c,d)) = Vec4 (a*x,b*x,c*x,d*x)
+        norm (Vec4 (a,b,c,d)) = sqrt (a*a + b*b + c*c + d*d)
+        normalize vec@(Vec4 (a,b,c,d)) = 
+            let n = norm vec in Vec4 (a/n,b/n,c/n,d/n)
+
+    cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+    cross (Vec3 (u1,u2,u3)) (Vec3 (v1,v2,v3)) =
+            Vec3 ( u2*v3 - u3*v2,
+                      u3*v1 - u1*v3,
+                      u1*v2 - u2*v1 )
+    (×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+    (×) = cross
+
+    lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
+    lookAtMatrix e@(Vec3 (ex,ey,ez)) c u =
+        let f@(Vec3 (fx,fy,fz)) = normalize (c <-> e)
+            s@(Vec3 (sx,sy,sz)) = normalize (f × u)
+            u'@(Vec3 (ux,uy,uz))   = s × f in 
+               Matrix (sx, ux, -fx, 0,
+                       sy, uy, -fy, 0,
+                       sz, uz, -fz, 0,
+                       -(s<.>e) , -(u'<.>e),  (f<.>e),  1 )
+
+    perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
+    {- as close to copied from glm as possible -}
+    perspectiveMatrix fov asp zn zf =
+        let tanHalfFovy = tangent (Degrees fov/2)
+            res00 = 1 / (asp * tanHalfFovy)
+            res11 = 1 / tanHalfFovy
+            res22 = - (zf + zn) / (zf - zn)
+            res23 = - 1
+            res32 = - (2 * zf * zn) / (zf - zn) in
+        trace ("res22=" ++ (show res22)) $
+        Matrix (res00, 0, 0, 0,
+                0, res11, 0, 0,
+                0, 0, res22, res23,
+                0, 0, res32, 0)
+
+    class VectorMatrix vecT matT where
+        vTranslate :: matT -> vecT -> matT
+        (-*|)  :: matT -> vecT -> vecT
+
+    instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
+        vTranslate (Matrix3 (a00,a01,a02,
+                             a10,a11,a12,
+                             a20,a21,a22)) (Vec3 (a,b,c)) =
+                        Matrix3 (a00,a01,a02+a,
+                                 a10,a11,a12+b,
+                                 a20,a21,a22+c)
+
+        (Matrix3 (a00,a01,a02,
+                 a10,a11,a12,
+                 a20,a21,a22)) -*| (Vec3 (a,b,c)) = 
+                                    Vec3 (a00 * a + a01 * b + a02 * c,
+                                          a10 * a + a11 * b + a12 * c,
+                                          a20 * a + a21 * b + a22 * c )
+
+
+
+
+    instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
+        vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
+        mat -*| tmp = glslMatMul mat tmp
+
+    glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
+    glslMatMul (Matrix (m00,m01,m02,m03,
+                m10,m11,m12,m13,
+                m20,m21,m22,m23,
+                m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
+                    Vec4 ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
+                           v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
+                           v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
+                           v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33 )
+
+    (==>) :: (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,
+                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,
+                             m10,m11,m12,m13,
+                             m20,m21,m22,m23,
+                             m30+v0,m31+v1,m32+v2,m33+v3))
+                    
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
new file mode 100644
index 0000000..546baa2
--- /dev/null
+++ b/Graphics/Glyph/Mat4.hs
@@ -0,0 +1,223 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.Mat4 where
+
+import Control.Monad
+
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
+
+import Graphics.Rendering.OpenGL
+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 Mat3 a = Matrix3 ( a,a,a,
+                        a,a,a,
+                        a,a,a ) | IdentityMatrix3
+
+class StorableMatrix t a where
+    fromList :: [t] -> a t
+    toPtr :: a t -> (Ptr t -> IO b) -> IO b
+    fromPtr :: Ptr t -> (a t -> IO b) -> IO b
+
+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)
+
+    toPtr (Matrix (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
+
+    fromPtr ptr f = peekArray 16 ptr >>= f . fromList
+
+instance (Storable t) => StorableMatrix t Mat3 where
+    fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:_) =
+        Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)
+
+    toPtr (Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)) fun =
+        allocaArray 9 $ \ptr -> do
+            pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9]
+            fun ptr
+
+    fromPtr ptr f = peekArray 9 ptr >>= f . fromList
+
+instance Uniform (Mat4 GLfloat) where
+    uniform (UniformLocation loc)  = makeStateVar getter setter
+                    where setter mat = toPtr mat $ \ptr ->
+                                    glUniformMatrix4fv loc 1 (fromIntegral gl_FALSE) ptr
+                          getter :: IO (Mat4 GLfloat)
+                          getter = do
+                                pid <- liftM fromIntegral getCurrentProgram
+                                ( allocaArray 16 $ \buf -> do
+                                    glGetUniformfv pid loc buf
+                                    fromPtr buf return )
+
+instance Uniform (Mat3 GLfloat) where
+    uniform (UniformLocation loc)  = makeStateVar getter setter
+                    where setter mat = toPtr mat $ \ptr ->
+                                    glUniformMatrix3fv loc 1 (fromIntegral gl_FALSE) ptr
+                          getter :: IO (Mat3 GLfloat)
+                          getter = do
+                                pid <- liftM fromIntegral getCurrentProgram
+                                ( allocaArray 9 $ \buf -> do
+                                    glGetUniformfv pid loc buf
+                                    fromPtr buf return )
+
+getCurrentProgram :: IO GLint
+getCurrentProgram = alloca $ glGetIntegerv gl_CURRENT_PROGRAM >> peek
+
+instance (Show a) => Show (Mat4 a) where
+    show IdentityMatrix =
+        "[ 1 0 0 0\n" ++
+        "  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)) =
+        "["++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n" ++
+        " "++! m10 ++ " " ++! m11 ++ " " ++! m12 ++ " " ++! m13 ++ "\n" ++
+        " "++! m20 ++ " " ++! m21 ++ " " ++! m22 ++ " " ++! m23 ++ "\n" ++
+        " "++! m30 ++ " " ++! m31 ++ " " ++! m32 ++ " " ++! m33 ++ "]"
+     where (++!) a = (a++) . show
+        
+
+    
+
+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,
+                        m10,m11,m12,m13,
+                        m20,m21,m22,m23,
+                        m30,m31,m32,m33)) (v0,v1,v2,v3) =
+                Matrix (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,
+              m10,m11,m12,m13,
+              m20,m21,m22,m23,
+              m30,m31,m32,m33)) (v0,v1,v2,v3) =
+                ( v0 * m00 + v1 * m01 + v2 * m02 + v3 * m03,
+                  v0 * m10 + v1 * m11 + v2 * m12 + v3 * m13,
+                  v0 * m20 + v1 * m21 + v2 * m22 + v3 * m23,
+                  v0 * m30 + v1 * m31 + v2 * m32 + v3 * m33 )
+
+applyMatrix IdentityMatrix v = v
+
+scaleMatrix :: (Num a) => Mat4 a -> (a,a,a) -> Mat4 a
+scaleMatrix IdentityMatrix (a,b,c) = Matrix ( 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,
+                               m10,m11*b,m12,m13,
+                               m20,m21,m22*c,m23,
+                               m30,m31,m32,m33)
+
+applyMatrixToList :: (Num a) => Mat4 a -> [a] -> [a]
+applyMatrixToList IdentityMatrix t = t
+applyMatrixToList mat (a:b:c:xs) =
+    let (a',b',c',_) = applyMatrix mat (a,b,c,1) in
+    (a':b':c':applyMatrixToList mat xs)
+
+applyMatrixToList _ _ = []
+
+mulMatrix4 :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
+mulMatrix4 IdentityMatrix a = a
+mulMatrix4 a IdentityMatrix = a
+mulMatrix4
+    (Matrix (a00,a01,a02,a03,
+              a10,a11,a12,a13,
+              a20,a21,a22,a23,
+              a30,a31,a32,a33 ))
+    (Matrix (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,
+                         b01*a00+b11*a01+b21*a02+b31*a03,
+                         b02*a00+b12*a01+b22*a02+b32*a03,
+                         b03*a00+b13*a01+b23*a02+b33*a03,
+
+                         b00*a10+b10*a11+b20*a12+b30*a13,
+                         b01*a10+b11*a11+b21*a12+b31*a13,
+                         b02*a10+b12*a11+b22*a12+b32*a13,
+                         b03*a10+b13*a11+b23*a12+b33*a13,
+
+                         b00*a20+b10*a21+b20*a22+b30*a23,
+                         b01*a20+b11*a21+b21*a22+b31*a23,
+                         b02*a20+b12*a21+b22*a22+b32*a23,
+                         b03*a20+b13*a21+b23*a22+b33*a23,
+
+                         b00*a30+b10*a31+b20*a32+b30*a33,
+                         b01*a30+b11*a31+b21*a32+b31*a33,
+                         b02*a30+b12*a31+b22*a32+b32*a33,
+                         b03*a30+b13*a31+b23*a32+b33*a33 )
+
+(|*|) :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
+(|*|) = mulMatrix4
+
+transpose4 :: Mat4 a -> Mat4 a
+transpose4 (Matrix
+                (m00,m01,m02,m03,
+                 m10,m11,m12,m13,
+                 m20,m21,m22,m23,
+                 m30,m31,m32,m33 ))  = (Matrix (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)) =
+        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
+            b14 = m12*m24*m33 + m13*m22*m34 + m14*m23*m32 - m12*m23*m34 - m13*m24*m32 - m14*m22*m33
+            b21 = m21*m34*m43 + m23*m31*m44 + m24*m33*m41 - m21*m33*m44 - m23*m34*m41 - m24*m31*m43
+            b22 = m11*m33*m44 + m13*m34*m41 + m14*m31*m43 - m11*m34*m43 - m13*m31*m44 - m14*m33*m41
+            b23 = m11*m24*m43 + m13*m21*m44 + m14*m23*m41 - m11*m23*m44 - m13*m24*m41 - m14*m21*m43
+            b24 = m11*m23*m34 + m13*m24*m31 + m14*m21*m33 - m11*m24*m33 - m13*m21*m34 - m14*m23*m31
+            b31 = m21*m32*m44 + m22*m34*m41 + m24*m31*m42 - m21*m34*m42 - m22*m31*m44 - m24*m32*m41
+            b32 = m11*m34*m42 + m12*m31*m44 + m14*m32*m41 - m11*m32*m44 - m12*m34*m41 - m14*m31*m42
+            b33 = m11*m22*m44 + m12*m24*m41 + m14*m21*m42 - m11*m24*m42 - m12*m21*m44 - m14*m22*m41
+            b34 = m11*m24*m32 + m12*m21*m34 + m14*m22*m31 - m11*m22*m34 - m12*m24*m31 - m14*m21*m32
+            b41 = m21*m33*m42 + m22*m31*m43 + m23*m32*m41 - m21*m32*m43 - m22*m33*m41 - m23*m31*m42
+            b42 = m11*m32*m43 + m12*m33*m41 + m13*m31*m42 - m11*m33*m42 - m12*m31*m43 - m13*m32*m41
+            b43 = m11*m23*m42 + m12*m21*m43 + m13*m22*m41 - m11*m22*m43 - m12*m23*m41 - m13*m21*m42
+            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)
+
+trunc4 :: Mat4 a -> Mat3 a
+trunc4 (Matrix
+        (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 mat = inv4 mat >>= return . trunc4 . transpose4
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
new file mode 100644
index 0000000..9a85e1a
--- /dev/null
+++ b/Graphics/Glyph/Shaders.hs
@@ -0,0 +1,57 @@
+module Graphics.Glyph.Shaders where
+
+import Graphics.Rendering.OpenGL
+import qualified Data.ByteString as BS
+import Control.Monad
+import Data.Maybe
+
+loadShader :: ShaderType -> FilePath -> IO (String, Maybe Shader)
+loadShader typ path = do
+    shader <- createShader typ
+    ( shaderSourceBS shader $= ) =<< BS.readFile path
+    compileShader shader
+
+    ok <- get (compileStatus shader)
+    infoLog <- get (shaderInfoLog shader)
+
+    unless ok $
+        deleteObjectNames [shader]
+
+    return ( infoLog, if not ok then Nothing else Just shader );
+
+
+loadShaders :: [(ShaderType,FilePath)] -> IO [(String, Maybe Shader)]
+loadShaders = mapM ( uncurry loadShader )
+
+workingShaders :: [(a, Maybe Shader)] -> [Shader]
+workingShaders lst = map (fromJust . snd) (filter (isJust . snd) lst)
+
+createShaderProgram :: [Shader] -> IO (String, Maybe Program)
+createShaderProgram shaders = do
+    p <- createProgram
+    mapM_ (attachShader p) shaders
+    linkProgram p
+
+    ok <- get $ linkStatus p
+    info <- get $ programInfoLog p
+
+    unless ok $
+        deleteObjectNames [p]
+
+    return ( info, if not ok then Nothing else Just p )
+
+getUniform :: Uniform a => String -> IO (Maybe (StateVar a))
+getUniform name =
+    get currentProgram >>= (\pr -> case pr of
+            Just p -> liftM (Just . uniform) (get $ uniformLocation p name)
+            Nothing -> return Nothing )
+
+getUniformForProgram :: Uniform a => String -> Program -> IO (StateVar a)
+getUniformForProgram name prog =
+    liftM uniform (get $ uniformLocation prog name)
+    
+
+getUniformLocation :: String -> IO (Maybe UniformLocation)
+getUniformLocation name =
+    get currentProgram >>= maybe (return Nothing) (\prog ->
+        liftM Just (get $ uniformLocation prog name) )
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
new file mode 100644
index 0000000..7e86d2a
--- /dev/null
+++ b/Graphics/Glyph/Textures.hs
@@ -0,0 +1,39 @@
+module Graphics.Glyph.Textures where
+
+import Data.Array.Storable
+import Data.Word
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL
+import Control.Monad
+
+data Pixels =
+    PixelsRGB  (Int,Int) (StorableArray Int Word8) |
+    PixelsRGBA (Int,Int) (StorableArray Int Word8)
+
+pixelsArray :: Pixels -> StorableArray Int Word8
+pixelsArray (PixelsRGB  _ a) = a
+pixelsArray (PixelsRGBA _ a) = a
+-- construct a new 2d array of pixels
+makePixelsRGB :: (Int, Int) -> IO Pixels
+makePixelsRGB a@(w,h) = liftM (PixelsRGB a) (newArray_ (0,w*h-1))
+
+-- convert a list of rgb values to an array
+newPixelsFromListRGB :: (Int, Int) -> [(Word8,Word8,Word8)] -> IO Pixels
+newPixelsFromListRGB a@(w,h) lst = liftM (PixelsRGB a) $ (newListArray (0,w*h*3) .
+                                                    concatMap (\(x,y,z)->[x,y,z])) lst
+
+newPixelsFromListRGBA :: (Int, Int) -> [(Word8,Word8,Word8,Word8)] -> IO Pixels
+newPixelsFromListRGBA a@(w,h) lst = liftM (PixelsRGBA a) $ newListArray (0,w*h*4)
+                                                    (concatMap (\(x,y,z,q)->[x,y,z,q]) lst)
+
+attachPixelsToTexture :: Pixels -> TextureObject -> IO ()
+attachPixelsToTexture pixels tex =
+    withStorableArray (pixelsArray pixels) $ \ptr -> do
+        textureBinding Texture2D $= Just tex
+        case pixels of
+            PixelsRGB  (w,h) _ -> glTexImage2D gl_TEXTURE_2D 0 3 (f w) (f h) 0 gl_RGB gl_UNSIGNED_BYTE ptr
+            PixelsRGBA (w,h) _ -> glTexImage2D gl_TEXTURE_2D 0 4 (f w) (f h) 0 gl_RGBA gl_UNSIGNED_BYTE ptr
+        where f = fromIntegral
+
+
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
new file mode 100644
index 0000000..550dd30
--- /dev/null
+++ b/Graphics/Glyph/Util.hs
@@ -0,0 +1,125 @@
+module Graphics.Glyph.Util where
+
+import Data.Angle
+import Graphics.Rendering.OpenGL
+
+uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a,b,c,d,e,f,g) -> h
+uncurry7 func (a,b,c,d,e,f,g) = func a b c d e f g
+
+uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a,b,c,d,e,f) -> g
+uncurry6 func (a,b,c,d,e,f) = func a b c d e f
+
+uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
+uncurry5 func (a,b,c,d,e) = func a b c d e
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
+uncurry4 func (a,b,c,d) = func a b c d
+
+uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e
+uncurry3 func (a,b,c) = func a b c
+
+gsin :: (Floating a) => a -> a
+gsin = sine . Degrees
+
+gcos :: (Floating a) => a -> a
+gcos = cosine . Degrees
+
+toEuclidian :: (Floating a) => (a, a, a) -> (a, a, a)
+toEuclidian (r, th, ph) = (
+        -r * gsin th * gcos ph,
+         r * gsin ph,
+         r * gcos th * gcos ph
+    )
+
+mapT2 :: (a -> b) -> (a,a) -> (b,b) 
+mapT2 f (a, b) = (f a, f b)
+
+mapT3 :: (a -> b) -> (a,a,a) -> (b,b,b) 
+mapT3 f (a, b, c) = (f a, f b, f c)
+
+mapT4 :: (a -> b) -> (a,a,a,a) -> (b,b,b,b) 
+mapT4 f (a, b, c, d) = (f a, f b, f c, f d)
+
+mapT5 :: (a -> b) -> (a,a,a,a,a) -> (b,b,b,b,b) 
+mapT5 f (a, b, c, d, e) = (f a, f b, f c, f d, f e)
+
+mapT6 :: (a -> b) -> (a,a,a,a,a,a) -> (b,b,b,b,b,b) 
+mapT6 f (a, b, c, d, e, _f) = (f a, f b, f c, f d, f e, f _f)
+
+mapT7 :: (a -> b) -> (a,a,a,a,a,a,a) -> (b,b,b,b,b,b,b) 
+mapT7 f (a, b, c, d, e, _f, g) = (f a, f b, f c, f d, f e, f _f, f g)
+
+foldT2 :: (a -> b -> a) -> a -> (b,b) -> a
+foldT2 f ini (x,y) = ini `f` x `f` y
+
+foldT3 :: (a -> b -> a) -> a -> (b,b,b) -> a
+foldT3 f ini (x,y,z) = ini `f` x `f` y `f` z
+
+foldT4 :: (a -> b -> a) -> a -> (b,b,b,b) -> a
+foldT4 f ini (x,y,z,w) = ini `f` x `f` y `f` z `f` w
+
+foldT5 :: (a -> b -> a) -> a -> (b,b,b,b,b) -> a
+foldT5 f ini (x,y,z,w,v) = ini `f` x `f` y `f` z `f` w `f` v
+
+tup2Len :: (Real a,Floating b) => (a,a) -> b
+tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((**2).toFloating)
+
+tup3Len :: (Real a,Floating b) => (a,a,a) -> b
+tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((**2).toFloating)
+
+tup4Len :: (Real a,Floating b) => (a,a,a,a) -> b
+tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((**2).toFloating)
+
+tup5Len :: (Real a,Floating b) => (a,a,a,a,a) -> b
+tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((**2).toFloating)
+
+expand3 :: a -> (a,a,a)
+expand3 t = (t,t,t)
+
+expand4 :: a -> (a,a,a,a)
+expand4 t = (t,t,t,t)
+
+expand5 :: a -> (a,a,a,a,a)
+expand5 t = (t,t,t,t,t)
+
+expand6 :: a -> (a,a,a,a,a)
+expand6 t = (t,t,t,t,t)
+
+zipWithT2 :: (a -> b -> c) -> (a,a) -> (b,b) -> (c,c)
+zipWithT2 fu (a, b) (d, e) = (fu a d, fu b e)
+
+zipWithT3 :: (a -> b -> c) -> (a,a,a) -> (b,b,b) -> (c,c,c)
+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)
+
+toFloating :: (Real a, Floating b) => a -> b
+toFloating = fromRational . toRational
+
+(!!%) :: [a] -> Int -> a
+(!!%) lst idx = lst !! (idx `mod` length lst)
+
+(++!) :: (Show a) => String -> a -> String
+(++!) str = (str++) . show
+
+clamp :: (Ord a) => a -> (a, a) -> a 
+clamp var (low, high) = min (max var low) high
+
+floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble
+floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)
+
+floatVector :: (GLfloat,GLfloat,GLfloat) -> Vector3 GLdouble
+floatVector tup = uncurry3 Vector3 (mapT3 toFloating tup)
+
+-- Maps a function across a list, except this function
+-- can also be given a state variable like how foldl
+-- works
+mapWith :: (s -> a -> (b,s)) -> s -> [a] -> ([b], s)
+mapWith func state (x:xs) = 
+    let (x',s') = func state x in
+    let (l,s) = mapWith func s' xs in (x':l, s)
+
+mapWith _ s [] = ([],s)
+(>&>) :: (Monad m) => (a -> m b) -> (a -> m c) -> a -> m c
+(>&>) f1 f2 a = f1 a >> f2 a