diff options
Diffstat (limited to 'Graphics')
| -rw-r--r-- | Graphics/Glyph/BufferBuilder.hs | 32 | ||||
| -rw-r--r-- | Graphics/Glyph/GlyphObject.hs | 158 | ||||
| -rw-r--r-- | Graphics/Glyph/Util.hs | 3 |
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 |