diff options
Diffstat (limited to 'Graphics/Glyph/GlyphObject.hs')
| -rw-r--r-- | Graphics/Glyph/GlyphObject.hs | 189 |
1 files changed, 100 insertions, 89 deletions
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs index db7b47c..a9f5c60 100644 --- a/Graphics/Glyph/GlyphObject.hs +++ b/Graphics/Glyph/GlyphObject.hs @@ -1,10 +1,10 @@ -module Graphics.Glyph.GlyphObject ( - GlyphObject, +module Graphics.Glyph.GlyphObject + ( GlyphObject, getBufferObject, getCompiledData, getVertexAttribute, getNormalAttribute, - getColorAttribute , + getColorAttribute, getTextureAttribute, getResources, getSetupRoutine, @@ -14,39 +14,44 @@ module Graphics.Glyph.GlyphObject ( setCompiledData, setVertexAttribute, setNormalAttribute, - setColorAttribute , + setColorAttribute, setTextureAttribute, setResources, setSetupRoutine, setTeardownRoutine, setPrimitiveMode, - prepare, teardown, - Drawable, draw, newGlyphObject, + prepare, + teardown, + Drawable, + draw, + newGlyphObject, newDefaultGlyphObject, startClosure, newDefaultGlyphObjectWithClosure, - drawInstances, numInstances, setNumInstances -) where + drawInstances, + numInstances, + setNumInstances, + ) +where +import Control.Applicative +import Control.Monad +import Data.Maybe import Graphics.Glyph.BufferBuilder +import Graphics.Glyph.ExtendedGL as Ex import Graphics.Glyph.Util import Graphics.Rendering.OpenGL as GL -import Graphics.Glyph.ExtendedGL as Ex - -import Control.Monad -import Control.Applicative -import Data.Maybe class Drawable a where - -- mvMat -> pMat -> obj -> IO () - draw :: a -> IO () + -- mvMat -> pMat -> obj -> IO () + draw :: a -> IO () -data GlyphObject a = GlyphObject { - bufferObject :: BufferObject, -- buffer +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 + colorAttribute :: (Maybe AttribLocation), -- color attrib textureAttribute :: (Maybe AttribLocation), -- texture attrib resources :: a, -- Resources setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup @@ -54,7 +59,7 @@ data GlyphObject a = GlyphObject { teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down primitiveMode :: ExPrimitiveMode, numInstances :: Int -} + } getBufferObject :: GlyphObject a -> BufferObject getBufferObject = bufferObject @@ -68,8 +73,8 @@ getVertexAttribute = vertexAttribute getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) getNormalAttribute = normalAttribute -getColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -getColorAttribute = colorAttribute +getColorAttribute :: GlyphObject a -> (Maybe AttribLocation) +getColorAttribute = colorAttribute getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation) getTextureAttribute = textureAttribute @@ -122,91 +127,97 @@ setPrimitiveMode o a = o {primitiveMode = a} setNumInstances :: GlyphObject a -> Int -> GlyphObject a setNumInstances o a = o {numInstances = a} - -newGlyphObject :: BuilderM GLfloat x -> - AttribLocation -> - Maybe AttribLocation -> - Maybe AttribLocation -> - Maybe AttribLocation -> - a -> - Maybe (GlyphObject a -> IO ()) -> - Maybe (GlyphObject a -> IO ()) -> - ExPrimitiveMode -> - IO (GlyphObject a) - +newGlyphObject :: + BuilderM GLfloat x -> + AttribLocation -> + Maybe AttribLocation -> + Maybe AttribLocation -> + Maybe AttribLocation -> + a -> + Maybe (GlyphObject a -> IO ()) -> + Maybe (GlyphObject a -> IO ()) -> + ExPrimitiveMode -> + 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 1 + compiled <- compilingBuilder builder + buffer <- createBufferObject ArrayBuffer compiled + return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode 1 -prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a +prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a prepare a b = setSetupRoutine2 a (Just b) -startClosure :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a +startClosure :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a startClosure a b = setSetupRoutine a (Just b) -teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a +teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a teardown a b = setTeardownRoutine a (Just b) instance Drawable (GlyphObject a) where - draw = drawInstances <..> numInstances + draw = drawInstances <..> numInstances 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 - - let p' = case p of - Ex.Points -> GL.Points - Ex.Lines -> GL.Lines - Ex.Triangles -> GL.Triangles - Ex.Patches -> GL.Patches - - 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 + {- 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 + + let p' = case p of + Ex.Points -> GL.Points + Ex.Lines -> GL.Lines + Ex.Triangles -> GL.Triangles + Ex.Patches -> GL.Patches + + 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 n) = - "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++ - " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++" instances="++!n++"]" + 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 + ++ " instances=" ++! n + ++ "]" 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 - Ex.Triangles -- primitive + newGlyphObject + builder + (AttribLocation 0) -- vertex + (Just $ AttribLocation 1) -- normal + (Just $ AttribLocation 2) -- color + (Just $ AttribLocation 3) -- texture + resources + Nothing -- setup + Nothing -- teardown + Ex.Triangles -- primitive newDefaultGlyphObjectWithClosure :: BuilderM GLfloat x -> a -> (GlyphObject a -> IO ()) -> IO (GlyphObject a) newDefaultGlyphObjectWithClosure builder res func = - liftM (flip startClosure func) $ newDefaultGlyphObject builder res - - + liftM (flip startClosure func) $ newDefaultGlyphObject builder res |