aboutsummaryrefslogtreecommitdiff
path: root/Graphics/Glyph/GlyphObject.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Graphics/Glyph/GlyphObject.hs')
-rw-r--r--Graphics/Glyph/GlyphObject.hs196
1 files changed, 102 insertions, 94 deletions
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
index 239007d..ef83cd8 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -1,12 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
-module Graphics.Glyph.GlyphObject (
- GlyphObject(..),
+module Graphics.Glyph.GlyphObject
+ ( GlyphObject (..),
getBufferObject,
getCompiledData,
getVertexAttribute,
getNormalAttribute,
- getColorAttribute ,
+ getColorAttribute,
getTextureAttribute,
getResources,
getSetupRoutine,
@@ -16,41 +16,44 @@ module Graphics.Glyph.GlyphObject (
setCompiledData,
setVertexAttribute,
setNormalAttribute,
- setColorAttribute ,
+ setColorAttribute,
setTextureAttribute,
setResources,
setSetupRoutine,
setTeardownRoutine,
setPrimitiveMode,
- prepare, teardown,
- Drawable, draw, newGlyphObject,
- newDefaultGlyphObject
-) where
+ prepare,
+ teardown,
+ Drawable,
+ draw,
+ newGlyphObject,
+ newDefaultGlyphObject,
+ )
+where
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL
-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
teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
primitiveMode :: PrimitiveMode
-}
+ }
getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject
@@ -64,8 +67,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
@@ -83,104 +86,109 @@ getPrimitiveMode :: GlyphObject a -> PrimitiveMode
getPrimitiveMode = primitiveMode
setBufferObject :: GlyphObject a -> BufferObject -> GlyphObject a
-setBufferObject o a = o { bufferObject = a }
+setBufferObject o a = o {bufferObject = a}
setCompiledData :: GlyphObject a -> (CompiledBuild GLfloat) -> GlyphObject a
-setCompiledData o a = o { compiledData = a }
+setCompiledData o a = o {compiledData = a}
setVertexAttribute :: GlyphObject a -> AttribLocation -> GlyphObject a
-setVertexAttribute o a = o { vertexAttribute = a }
+setVertexAttribute o a = o {vertexAttribute = a}
setNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setNormalAttribute o a = o { normalAttribute = a }
+setNormalAttribute o a = o {normalAttribute = a}
-setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setColorAttribute o a = o { colorAttribute = a }
+setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setColorAttribute o a = o {colorAttribute = a}
setTextureAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setTextureAttribute o a = o { textureAttribute = a }
+setTextureAttribute o a = o {textureAttribute = a}
setResources :: GlyphObject a -> a -> GlyphObject a
-setResources o a = o { resources = a }
+setResources o a = o {resources = a}
setSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
-setSetupRoutine o a = o { setupRoutine = a }
+setSetupRoutine o a = o {setupRoutine = a}
setTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
-setTeardownRoutine o a = o { teardownRoutine = a }
+setTeardownRoutine o a = o {teardownRoutine = a}
setPrimitiveMode :: GlyphObject a -> PrimitiveMode -> GlyphObject a
-setPrimitiveMode o a = o { primitiveMode = a }
-
-newGlyphObject :: Builder GLfloat x ->
- AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- a ->
- Maybe (GlyphObject a -> IO ()) ->
- Maybe (GlyphObject a -> IO ()) ->
- PrimitiveMode ->
- IO (GlyphObject a)
-
+setPrimitiveMode o a = o {primitiveMode = a}
+
+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
+ 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 = a { setupRoutine = (Just b) }
+prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
+prepare a b = a {setupRoutine = (Just b)}
-teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-teardown a b = a { teardownRoutine = Just b }
+teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
+teardown a b = a {teardownRoutine = Just b}
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'
+ 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++"]"
-
+ 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
-
-
+ newGlyphObject
+ builder
+ (AttribLocation 0) -- vertex
+ (Just $ AttribLocation 1) -- normal
+ (Just $ AttribLocation 2) -- color
+ (Just $ AttribLocation 3) -- texture
+ resources
+ Nothing -- setup
+ Nothing -- teardown
+ Triangles -- primitive
generated by cgit (git 2.34.1) at 2025-04-28 12:26:47 +0000