intiial commit

12 files changed, 1716 insertions, 0 deletions

diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
new file mode 100644
index 0000000..ec27a89
--- /dev/null
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -0,0 +1,283 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.BufferBuilder where
+
+import Control.Monad
+import Graphics.Rendering.OpenGL
+import Foreign.Storable
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Data.Array.Storable
+import Data.Setters
+import Debug.Trace
+import qualified Data.Foldable as Fold
+import Data.Sequence as Seq
+import Data.Map as Map
+
+import Graphics.Glyph.Mat4
+import Graphics.Glyph.Util
+import Graphics.Glyph.GLMath
+
+import System.IO.Unsafe
+import Unsafe.Coerce
+
+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
+
+class Monad a => IsModelBuilder b a where
+    plotVertex3 :: b -> b -> b -> a ()
+    plotNormal  :: b -> b -> b -> a ()
+    plotTexture :: b -> b ->a ()
+
+{- A state monad that keeps track of operations
+ - and will compile them into a buffer -}
+
+data BuilderM b a = BuilderM (Builder (BuildDatum b)) a
+data Builder b = Builder
+                    !(Builder b) -- before
+                    !(Builder b) -- after
+                  | LeafBuilder !(Seq b) deriving Show
+
+instance IsModelBuilder GLfloat (BuilderM GLfloat) where
+    plotVertex3 x y z = bVertex3 (x,y,z)
+    plotNormal x y z  = bNormal3 (x,y,z)
+    plotTexture x y   = bTexture2 (x,y)
+
+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 :: Ptr b,
+    arrayBytes :: Int
+}
+
+bufferLength :: (Integral a) => CompiledBuild b -> a
+bufferLength = fromIntegral . nElems
+
+instance Show (CompiledBuild x) where
+    show (CompiledBuild stride enabled n ptr nbytes) =
+        "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++" ptr="++!ptr++" nbytes="++!nbytes++"]"
+
+instance (Num t) => Monad (BuilderM t) where
+    (BuilderM !builder1 _) >> (BuilderM !builder2 ret) =
+        BuilderM (builder1 ><> builder2) ret
+        where
+            b1@(LeafBuilder !seq1) ><> b2@(LeafBuilder !seq2) 
+                | Seq.length seq1 + Seq.length seq2 < 128 = LeafBuilder (seq1 >< seq2)
+                | otherwise = Builder b1 b2
+            (Builder !b1 !b2)  ><> leaf@(LeafBuilder !_)  =
+                (Builder b1 (b2 ><> leaf))
+            builder1 ><> builder2 = (Builder builder1 builder2)
+
+    b1@(BuilderM _ ret) >>= func = b1 >> func ret
+
+    return = BuilderM (LeafBuilder Seq.empty)
+    fail = undefined
+
+instance Functor Builder where
+    fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
+    fmap f (LeafBuilder seq) = (LeafBuilder (fmap f seq))
+
+instance Fold.Foldable Builder where
+    foldl f ini (Builder b1 b2) = 
+        Fold.foldl f (Fold.foldl f ini b1) b2
+    foldl f ini (LeafBuilder seq) =
+        Fold.foldl f ini seq
+
+    foldr f ini (Builder b1 b2) = 
+        Fold.foldr f (Fold.foldr f ini b2) b1
+    foldr f ini (LeafBuilder seq) =
+        Fold.foldr f ini seq
+
+expandBuilder :: Builder a -> b -> (b -> a -> (b,[a])) -> Builder a
+expandBuilder builder ini f = snd $ expandBuilder' builder ini f
+    where expandBuilder' :: Builder a -> b -> (b -> a -> (b,[a])) -> (b,Builder a)
+
+          expandBuilder' (Builder builder1 builder2) ini f = 
+            let (snowball1,newBuilder1) = expandBuilder' builder1 ini f
+                (snowball2,newBuilder2) = expandBuilder' builder2 snowball1 f in
+                (snowball2,Builder newBuilder1 newBuilder2)
+
+          expandBuilder' (LeafBuilder seq1) ini f = 
+            let (seq,snow) = Fold.foldl' (\(seq', snow) datum -> 
+                            let (snow',lst) = f snow datum in
+                            (seq' >< Seq.fromList lst,snow')) (Seq.empty,ini) seq1 in
+                (snow,LeafBuilder seq)
+
+{- Add a vertex to the current builder -}
+bVertex3 :: (a,a,a) -> BuilderM a ()
+bVertex3 vert = BuilderM (LeafBuilder (Seq.singleton $ VertexLink vert)) ()
+
+bTexture2 :: (a,a) -> BuilderM a ()
+bTexture2 tex = BuilderM (LeafBuilder (Seq.singleton $ TextureLink tex)) ()
+
+bNormal3 :: (a,a,a) -> BuilderM a ()
+bNormal3 norm = BuilderM (LeafBuilder (Seq.singleton $ NormalLink norm)) ()
+
+bColor4 :: (a,a,a,a) -> BuilderM a ()
+bColor4 col = BuilderM (LeafBuilder (Seq.singleton $ ColorLink col)) ()
+
+writeAndAvance :: (Storable a) => [a] -> Ptr a -> IO (Ptr a)
+writeAndAvance (a:as) ptr = poke ptr a >> writeAndAvance as (advancePtr ptr 1)
+writeAndAvance [] ptr = return ptr
+
+compilingBuilder :: (Storable b, Num b, Show b) => BuilderM b x -> IO (CompiledBuild b)
+compilingBuilder (BuilderM builder _) = do
+
+    putStrLn "COMPILING"
+    -- Size of the elements TODO unhardcode this
+    let sizeof = sizeOf $ builderElem builder
+                  where builderElem :: Builder (BuildDatum a) -> a
+                        builderElem _ = unsafeCoerce (0::Int)
+
+    {- Simply figure out what types of elementse
+     - exist in this buffer -}
+    let (bn,bc,bt,nVerts) = Fold.foldl' (\(bn,bc,bt,len) ele ->
+                                case ele of
+                                    NormalLink _ -> (True,bc,bt,len)
+                                    ColorLink _ -> (bn,True,bt,len)
+                                    TextureLink _ -> (bn,bc,True,len)
+                                    VertexLink _ -> (bn,bc,bt,len+1)) (False,False,False,0) builder
+    {- Calculate the stride; number of floats per element -}
+    let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof
+                    where (?) True = 1
+                          (?) False = 0
+
+    let nbytes = stride * nVerts
+    putStrLn $ "Mallocing array of size: " ++! nbytes
+    array <- mallocArray nbytes
+
+    -- Tuple
+    -- Pointer to current element, current normal/color/texture
+    putStrLn "Writing array buffer"
+    !_ <- Fold.foldlM (\(ptr, cn, cc, ct) ele ->
+           -- trace ("foldl " ++! ele) $
+            case ele of
+                NormalLink nn -> return (ptr,nn,cc,ct)
+                ColorLink nc -> return (ptr,cn,nc,ct)
+                TextureLink nt -> return (ptr,cn,cc,nt)
+                VertexLink vert -> do
+                  ptr' <- writeAndAvance (tp3 True vert) ptr >>=
+                            writeAndAvance (tp3 bn cn) >>=
+                            writeAndAvance (tp4 bc cc) >>=
+                            writeAndAvance (tp2 bt ct)
+                  return (ptr',cn,cc,ct) ) ( array, (0,0,0), (0,0,0,0), (0,0) ) builder
+    putStrLn "Buffer written"
+    let !compiledRet = CompiledBuild stride (bn,bc,bt) nVerts array nbytes
+    putStrLn $ "COMPILE COMPLETE" ++! compiledRet
+    return compiledRet
+
+  where
+      tp2 True (a,b)  = [a,b]
+      tp2 False _  = []
+ 
+      tp3 True (a,b,c) = [a,b,c]
+      tp3 False _ = []
+ 
+      tp4 True (a,b,c,d) = [a,b,c,d]
+      tp4 False _ = []
+
+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
+
+ptrToBuffer :: (Storable b) => BufferTarget -> Ptr b -> Int -> IO BufferObject
+ptrToBuffer target ptr len = do
+    -- len is length in bytes
+    [buffer] <- genObjectNames 1
+    bindBuffer target $= Just buffer
+    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 len) = ptrToBuffer target arr len
+
+mapListInsert :: (Ord k) => k -> a -> Map.Map k [a] -> Map.Map k [a]
+mapListInsert key val map =
+    flip (Map.insert key) map $
+        case Map.lookup key map of
+            Nothing -> [val]
+            Just x -> (val:x)
+
+inferingNormals :: (RealFloat a,Ord a,Show a) => BuilderM a b -> BuilderM a b
+inferingNormals (BuilderM builder ret) =
+    let (normalMap,_,_) = Fold.foldl' (\(newMap, v1, v2) datum ->
+                            case datum of
+                                VertexLink w ->
+                                    case (v1,v2) of
+                                        (Just u, Just v) -> 
+                                            let (Vec3 normal) = (Vec3 u <-> Vec3 v) × (Vec3 u <-> Vec3 w) in
+                                            (insertWith (zipWithT3 (+)) w normal newMap, Nothing, Nothing)
+                                        (Just u, Nothing) -> (newMap, v1, Just w)
+                                        (Nothing,Nothing) -> (newMap, Just w, Nothing)
+                                _ -> (newMap,v1,v2)
+                                ) (Map.empty,Nothing,Nothing) builder in
+
+    let newBuilder = expandBuilder builder () $ \() datum ->
+         case datum of
+            VertexLink tup ->
+                let normalLink = NormalLink $ maybe (0,0,0) id $ Map.lookup tup normalMap in
+                ((),[normalLink, datum])
+            _ -> ((),[datum]) in
+
+    (BuilderM newBuilder ret)
+
+
+trianglesFromQuads :: [a] -> [a]
+trianglesFromQuads (a:b:c:d:xs) = [a,b,c,a,c,d] ++ trianglesFromQuads xs
+trianglesFromQuads l = l
+
+translating :: (Num a) => (a,a,a) -> BuilderM a b -> BuilderM a b
+translating trans (BuilderM builder ret) = do
+    BuilderM (flip fmap builder $ \datum ->
+                case datum of
+                    VertexLink tup -> VertexLink $ zipWithT3 (+) tup trans
+                    _ -> datum) ret
+translating _ x = x
diff --git a/Graphics/Glyph/ExtendedGL.hs b/Graphics/Glyph/ExtendedGL.hs
new file mode 100644
index 0000000..d42e973
--- /dev/null
+++ b/Graphics/Glyph/ExtendedGL.hs
@@ -0,0 +1,26 @@
+module Graphics.Glyph.ExtendedGL where
+
+import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL.Raw.ARB
+
+marshalPrimitiveMode :: PrimitiveMode -> GLenum
+marshalPrimitiveMode x = case x of
+   Points -> 0x0
+   Lines -> 0x1
+   LineLoop -> 0x2
+   LineStrip -> 0x3
+   Triangles -> 0x4
+   TriangleStrip -> 0x5
+   TriangleFan -> 0x6
+   Quads -> 0x7
+   QuadStrip -> 0x8
+   Polygon -> 0x9
+
+drawArraysInstanced :: PrimitiveMode -> ArrayIndex -> NumArrayIndices -> GLsizei -> IO ()
+drawArraysInstanced = glDrawArraysInstanced . marshalPrimitiveMode
+
+vertexAttributeDivisor :: AttribLocation -> SettableStateVar GLuint
+vertexAttributeDivisor (AttribLocation loc) =
+    makeSettableStateVar $ \val ->
+        glVertexAttribDivisor loc val
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
new file mode 100644
index 0000000..14f12e3
--- /dev/null
+++ b/Graphics/Glyph/GLMath.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -XFlexibleInstances #-}
+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)
+
+    instance UniformComponent a => Uniform (Vec4 a) where
+        uniform loc = GL.makeStateVar
+                        (do
+                            (GL.Vertex4 x y z w) <-
+                                GL.get (uniform loc)
+                            return (Vec4 (x,y,z,w)) )
+                        (\(Vec4 (x,y,z,w)) -> uniform loc GL.$= GL.Vertex4 x y z w)
+
+    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
+        vNegate :: 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)
+        vNegate (Vec2 (a,b)) = Vec2 (-a,-b)
+
+    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)
+        vNegate (Vec3 (a,b,c)) = Vec3 (-a,-b,-c)
+
+    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)
+        vNegate (Vec4 (a,b,c,d)) = Vec4 (-a,-b,-c,-d)
+
+    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/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs
new file mode 100644
index 0000000..31be715
--- /dev/null
+++ b/Graphics/Glyph/GeometryBuilder.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Graphics.Glyph.GeometryBuilder where
+
+import Data.Sequence as Seq
+import Data.Setters
+import Data.Maybe
+
+import Graphics.Glyph.Util
+import Graphics.Glyph.BufferBuilder
+
+import Data.ByteStringBuilder
+import Data.ByteString.Lazy
+import Data.ByteString.Lazy.Char8 as BSLC
+import Data.Foldable as Fold
+
+import Text.Printf
+
+data OutType = TriangleStrip | Triangles
+instance Show OutType where
+    show TriangleStrip = "triangle_strip"
+    show Triangles = "triangle_strip"
+
+buildSourceAsString :: GeometryBuilder a -> String
+buildSourceAsString = BSLC.unpack . buildSource
+
+buildSource :: GeometryBuilder a -> ByteString
+buildSource builder =
+    runBuilder $ do
+        putSLn "#version 150"
+        putSLn "#extension GL_ARB_explicit_attrib_location : enable"
+        putSLn "#extension GL_ARB_explicit_uniform_location : enable"
+        putSLn "layout(points) in ;"
+    
+        let isVertex (Vertex _ _ _ _) = True
+            isVertex _ = False
+        putSLn $ printf "layout(%s,max_vertices=%d) out ;"
+                    (show $ maybeDefault TriangleStrip $ gOutType builder)
+                    (Seq.length $ Seq.filter isVertex $ gList builder)
+
+        forM_ (textureOut builder) $ putSLn.("out vec2 "++) . (++";")
+        forM_ (normalOut builder) $ putSLn.("out vec3 "++) . (++";")
+        forM_ (positionOut builder) $ putSLn.("out vec4 "++) . (++";")
+        
+        let pjMatStr = fromJust (pjMatrixUniform builder >||> Just "pjMatrix")
+        let mvMatStr = fromJust (mvMatrixUniform builder >||> Just "mvMatrix")
+
+        Fold.mapM_ (putSLn.("uniform mat4 "++).(++";")) [pjMatStr, mvMatStr]
+
+        putSLn "void main() {"
+
+        let vertexOutF =
+             case positionOut builder of
+                Nothing ->
+                    printf "\tgl_Position = %s * (gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));"
+                        pjMatStr mvMatStr
+                Just str -> 
+                    printf "\tgl_Position = %s * (%s = gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));"
+                        pjMatStr str mvMatStr
+        let normalOutF = case normalOut builder of
+             Nothing -> const3 ""
+             Just str -> printf "\t%s = -inverse(transpose(mat3(%s))) * vec3(%f,%f,%f);" str mvMatStr
+
+        let textureOutF = case textureOut builder of
+             Nothing -> const2 ""
+             Just str -> printf "\t%s = vec2(%f,%f);" str
+
+        forM_ (gList builder) $ \datum ->
+            case datum of
+                Vertex x y z w -> putSLn $ vertexOutF x y z w
+                Normal x y z -> putSLn $ normalOutF x y z
+                Texture x y -> putSLn $ textureOutF x y
+                EmitVertex -> putSLn "\tEmitVertex();"
+                EndPrimitive -> putSLn "\tEndPrimitive();"
+        putSLn "}"
+
+data GeometryDatum =
+    Vertex  Float Float Float Float |
+    Texture Float Float |
+    Normal  Float Float Float |
+    EmitVertex |
+    EndPrimitive
+
+data GeometryBuilder a = GeometryBuilder {
+    gList :: (Seq GeometryDatum),
+
+    gOutType :: Maybe OutType,
+    pjMatrixUniform :: Maybe String,
+    mvMatrixUniform :: Maybe String,
+    maxVerts :: Maybe Int,
+
+    textureOut :: Maybe String,
+    normalOut :: Maybe String,
+    positionOut :: Maybe String,
+    gRet :: a
+}
+
+$(declareSetters ''GeometryBuilder)
+
+generating :: OutType -> GeometryBuilder () -> GeometryBuilder ()
+generating TriangleStrip builder = setGOutType (Just TriangleStrip) $ builder
+generating Triangles builder = do
+    let (nSeq,_) =
+         Fold.foldl' (\(tSeq,cnt) datum ->
+            case datum of
+                EmitVertex ->
+                    if cnt == (2::Int) then (tSeq |> datum |> EndPrimitive, 0)
+                    else (tSeq |> datum, cnt + 1)
+                _ -> (tSeq |> datum,cnt)
+            ) (Seq.empty, 0) (gList builder)
+
+    setGOutType (Just Triangles) $
+        setGList nSeq builder
+
+projectionMatrixUniform :: String -> GeometryBuilder ()
+projectionMatrixUniform str = setPjMatrixUniform (Just str) $ return ()
+
+modelViewMatrixUniform :: String -> GeometryBuilder ()
+modelViewMatrixUniform str = setMvMatrixUniform (Just str) $ return ()
+
+maxVerticies :: Int -> GeometryBuilder ()
+maxVerticies i = setMaxVerts (Just i) $ return ()
+
+textureOutput :: String -> GeometryBuilder ()
+textureOutput str = setTextureOut (Just str) $ return ()
+
+normalOutput :: String -> GeometryBuilder ()
+normalOutput str = setNormalOut (Just str) $ return ()
+
+positionOutput :: String -> GeometryBuilder ()
+positionOutput str = setPositionOut (Just str) $ return ()
+
+gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder ()
+gVertex4 x y z w = setGList (Seq.singleton $ Vertex x y z w) $ return ()
+
+gNormal3 :: Float -> Float -> Float -> GeometryBuilder ()
+gNormal3 x y z = setGList (Seq.singleton $ Normal x y z) $ return ()
+
+gTexture2 :: Float -> Float -> GeometryBuilder ()
+gTexture2 x y = setGList (Seq.singleton $ Texture x y) $ return ()
+
+gEmitVertex :: GeometryBuilder ()
+gEmitVertex = setGList (Seq.singleton $ EmitVertex) $ return ()
+
+gEndPrimitive :: GeometryBuilder ()
+gEndPrimitive = setGList (Seq.singleton $ EndPrimitive) $ return ()
+
+gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder ()
+gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex
+
+
+instance Monad GeometryBuilder where
+    aB >> bB = GeometryBuilder
+                (gList aB >< gList bB)
+                (select gOutType gOutType)
+                (select pjMatrixUniform pjMatrixUniform)
+                (select mvMatrixUniform mvMatrixUniform)
+                (select maxVerts maxVerts)
+                (select textureOut textureOut)
+                (select normalOut normalOut)
+                (select positionOut positionOut)
+                (gRet bB)
+                where select f1 f2 = (f1 bB) >||> (f2 aB)
+    aB >>= func = aB >> func (gRet aB)
+    return = GeometryBuilder
+                Seq.empty
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+    fail = error
+    
+
+instance IsModelBuilder Float GeometryBuilder where
+    plotVertex3 x y z = gVertex4E x y z 0
+    plotNormal = gNormal3
+    plotTexture = gTexture2
+
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
new file mode 100644
index 0000000..e359838
--- /dev/null
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Graphics.Glyph.GlyphObject (
+    GlyphObject,
+    getBufferObject,
+    getCompiledData,
+    getVertexAttribute,
+    getNormalAttribute,
+    getColorAttribute ,
+    getTextureAttribute,
+    getResources,
+    getSetupRoutine,
+    getTeardownRoutine,
+    getPrimitiveMode,
+    setBufferObject,
+    setCompiledData,
+    setVertexAttribute,
+    setNormalAttribute,
+    setColorAttribute ,
+    setTextureAttribute,
+    setResources,
+    setSetupRoutine,
+    setTeardownRoutine,
+    setPrimitiveMode,
+    prepare, teardown,
+    Drawable, draw, newGlyphObject,
+    newDefaultGlyphObject,
+    startClosure,
+    newDefaultGlyphObjectWithClosure
+) where
+
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL
+import Graphics.Glyph.ExtendedGL
+import Data.Setters
+
+import Control.Monad
+import Control.Applicative
+import Data.Maybe
+
+class Drawable a where
+    -- mvMat -> pMat -> obj -> IO ()
+    draw :: a -> IO ()
+
+data GlyphObject a = GlyphObject {
+    bufferObject :: BufferObject, -- buffer
+    compiledData :: (CompiledBuild GLfloat), -- compiled data
+    vertexAttribute :: AttribLocation, -- vertex attribute
+    normalAttribute :: (Maybe AttribLocation), -- normal attrib
+    colorAttribute  :: (Maybe AttribLocation), -- color attrib
+    textureAttribute :: (Maybe AttribLocation), -- texture attrib
+    resources :: a, -- Resources
+    setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
+    setupRoutine2 :: (Maybe (GlyphObject a -> IO ())), -- Setup
+    teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
+    primitiveMode :: PrimitiveMode
+}
+
+$(declareSetters ''GlyphObject)
+getBufferObject :: GlyphObject a -> BufferObject
+getBufferObject = bufferObject
+
+getCompiledData :: GlyphObject a -> (CompiledBuild GLfloat)
+getCompiledData = compiledData
+
+getVertexAttribute :: GlyphObject a -> AttribLocation
+getVertexAttribute = vertexAttribute
+
+getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getNormalAttribute = normalAttribute
+
+getColorAttribute  :: GlyphObject a -> (Maybe AttribLocation)
+getColorAttribute  = colorAttribute
+
+getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getTextureAttribute = textureAttribute
+
+getResources :: GlyphObject a -> a
+getResources = resources
+
+getSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ()))
+getSetupRoutine = setupRoutine
+
+getTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ()))
+getTeardownRoutine = teardownRoutine
+
+getPrimitiveMode :: GlyphObject a -> PrimitiveMode
+getPrimitiveMode = primitiveMode
+
+newGlyphObject :: BuilderM GLfloat x ->
+    AttribLocation ->
+    Maybe AttribLocation ->
+    Maybe AttribLocation ->
+    Maybe AttribLocation ->
+    a ->
+    Maybe (GlyphObject a -> IO ()) ->
+    Maybe (GlyphObject a -> IO ()) ->
+    PrimitiveMode ->
+    IO (GlyphObject a)
+
+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
+
+prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+prepare a b = setSetupRoutine2 (Just b) a
+
+startClosure :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+startClosure a b = setSetupRoutine (Just b) a
+
+teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+teardown a b = setTeardownRoutine (Just b) a
+
+instance Drawable (GlyphObject a) where
+    draw = drawInstances 1
+
+drawInstances :: Int -> GlyphObject a -> IO ()
+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
+
+    {- Get the array descriptors for the possible
+     - parts -}
+    let vad = vertexArrayDescriptor co
+    let nad = normalArrayDescriptor co
+    let cad = colorArrayDescriptor co
+    let tad = textureArrayDescriptor co
+
+    bindBuffer ArrayBuffer $= Just bo
+    let enabled = catMaybes $
+         map liftMaybe [(Just vAttr,Just vad), (nAttr, nad), (cAttr,cad), (tAttr,tad)]
+
+    forM_ enabled $ \(attr, ad) -> do
+        vertexAttribPointer attr $= (ToFloat, ad)
+        vertexAttribArray attr $= Enabled
+
+    drawArraysInstanced p 0 (bufferLength co) $ fromIntegral n
+        
+    forM_ enabled $ \(attr, _) -> do
+        vertexAttribArray attr $= Disabled
+        
+    {- Tear down whatever the object needs -}
+    maybe (return ()) (Prelude.$ obj) tearDown
+    where liftMaybe (Just a, Just b) = Just (a,b)
+          liftMaybe _ = Nothing
+
+instance (Show a) => Show (GlyphObject a) where
+    show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ _ p) =
+        "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
+            " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++"]"
+
+newDefaultGlyphObject :: BuilderM GLfloat x -> a -> IO (GlyphObject a)
+newDefaultGlyphObject builder resources =
+                        newGlyphObject builder
+                                       (AttribLocation 0) -- vertex
+                                       (Just $ AttribLocation 1) -- normal
+                                       (Just $ AttribLocation 2) -- color
+                                       (Just $ AttribLocation 3) -- texture
+                                       resources
+                                       Nothing -- setup
+                                       Nothing -- teardown
+                                       Triangles -- primitive
+
+newDefaultGlyphObjectWithClosure :: BuilderM GLfloat x -> a -> (GlyphObject a -> IO ()) -> IO (GlyphObject a)
+newDefaultGlyphObjectWithClosure builder res func =
+    liftM (flip startClosure func) $ newDefaultGlyphObject builder res 
+        
+    
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 $