updated to add particles

3 files changed, 177 insertions, 16 deletions

diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index 4c56c6f..e9606de 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -88,7 +88,7 @@ compilingBuilder (Builder lst _) = do
                         tmp _ = 0
     {- Simply figure out what types of elementse
      - exist in this buffer -}
-    let en@(bn,bc,bt) = Fold.foldl (\(bn,bc,bt) ele ->
+    let en@(bn,bc,bt) = Fold.foldl' (\(bn,bc,bt) ele ->
                                 case ele of
                                     NormalLink _ -> (True,bc,bt)
                                     ColorLink _ -> (bn,True,bt)
@@ -100,8 +100,8 @@ compilingBuilder (Builder lst _) = do
                           (?) False = 0
     --             Cur color normal texture buffer
     let (nverts,_,_,_,buffer) =
-         Fold.foldl (\(num,cn,cc,ct,ll) ele ->
-                    -- trace ("foldl " ++! ele) $
+         Fold.foldl' (\(num,cn,cc,ct,ll) ele ->
+                   -- trace ("foldl " ++! ele) $
                     case ele of
                         NormalLink nn -> (num,nn,cc,ct,ll)
                         ColorLink nc -> (num,cn,nc,ct,ll)
@@ -111,19 +111,19 @@ compilingBuilder (Builder lst _) = do
                             ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct)
                             )) ( 0, (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 nverts 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
+    let blst = (Fold.toList buffer)
+    arr <- blst `seq` newListArray (0,Seq.length buffer) blst
+    let compiledRet = CompiledBuild stride en nverts arr
+    compiledRet `seq` putStrLn ("Compiled: " ++! compiledRet ) `seq` return compiledRet
+  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
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
new file mode 100644
index 0000000..8a3fe4a
--- /dev/null
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -0,0 +1,158 @@
+{-# 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
+) where
+
+import Graphics.Glyph.BufferBuilder
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL
+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
+    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 :: Builder 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 tear mode
+
+prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+prepare 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 obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown p) = do
+        {- Setup whatever we need for the object to draw itself -}
+        maybe (return ()) (apply obj) setup
+
+        {- 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
+
+        drawArrays p 0 (bufferLength co)
+            
+        forM_ enabled $ \(attr, _) -> do
+            vertexAttribArray attr $= Disabled
+            
+        {- Tear down whatever the object needs -}
+        maybe (return ()) (apply obj) tearDown
+        where liftMaybe (Just a, Just b) = Just (a,b)
+              liftMaybe _ = Nothing
+              apply obj' f = f obj'
+
+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 :: Builder 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
+        
+    
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
index 550dd30..d657aa3 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -3,6 +3,9 @@ module Graphics.Glyph.Util where
 import Data.Angle
 import Graphics.Rendering.OpenGL
 
+int :: (Integral a, Num b) => a -> b
+int = fromIntegral 
+
 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