From ba59711a51b4fee34009b1fe6afdce9ef8e60ae0 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 3 Dec 2022 17:37:59 -0700 Subject: run ormolu formatter --- Graphics/Glyph/ArrayGenerator.hs | 41 +-- Graphics/Glyph/BufferBuilder.hs | 466 ++++++++++++++++-------------- Graphics/Glyph/ExtendedGL.hs | 11 +- Graphics/Glyph/ExtendedGL/Base.hs | 124 ++++---- Graphics/Glyph/ExtendedGL/Framebuffers.hs | 137 +++++---- Graphics/Glyph/GLMath.hs | 431 +++++++++++++++++---------- Graphics/Glyph/GeometryBuilder.hs | 249 ++++++++-------- Graphics/Glyph/GlyphObject.hs | 189 ++++++------ Graphics/Glyph/ObjLoader.hs | 166 +++++------ Graphics/Glyph/Shaders.hs | 144 ++++----- Graphics/Glyph/Textures.hs | 47 +-- Graphics/Glyph/Util.hs | 265 ++++++++--------- Graphics/Rendering/HelpGL.hs | 12 +- Graphics/SDL/SDLHelp.hs | 203 ++++++------- 14 files changed, 1359 insertions(+), 1126 deletions(-) (limited to 'Graphics') diff --git a/Graphics/Glyph/ArrayGenerator.hs b/Graphics/Glyph/ArrayGenerator.hs index 16fe41f..088ccc7 100644 --- a/Graphics/Glyph/ArrayGenerator.hs +++ b/Graphics/Glyph/ArrayGenerator.hs @@ -1,9 +1,9 @@ {-# LANGUAGE UndecidableInstances #-} -module Graphics.Glyph.ArrayGenerator where -import qualified Data.Map as M +module Graphics.Glyph.ArrayGenerator where import Data.Array +import qualified Data.Map as M import Data.Maybe data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b @@ -13,33 +13,36 @@ instance (Ord ix) => Functor (ArrayTransaction ix a) where instance (Ord ix) => Applicative (ArrayTransaction ix a) where (<*>) afn aa = do - fn <- afn - a <- aa - return (fn a) + fn <- afn + a <- aa + return (fn a) pure = return instance (Ord ix) => Monad (ArrayTransaction ix a) where - return = ArrayBuilderM_ M.empty - (ArrayBuilderM_ map1 val) >>= f = - ArrayBuilderM_ (map1 `M.union` map2) val2 - where (ArrayBuilderM_ map2 val2) = f val + return = ArrayBuilderM_ M.empty + (ArrayBuilderM_ map1 val) >>= f = + ArrayBuilderM_ (map1 `M.union` map2) val2 + where + (ArrayBuilderM_ map2 val2) = f val class HasDefault a where - theDefault :: a + theDefault :: a instance (Num a) => HasDefault a where - theDefault = 0 -instance (HasDefault a, HasDefault b) => HasDefault (a,b) where - theDefault = (theDefault,theDefault) -instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a,b,c) where - theDefault = (theDefault,theDefault,theDefault) + theDefault = 0 + +instance (HasDefault a, HasDefault b) => HasDefault (a, b) where + theDefault = (theDefault, theDefault) + +instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a, b, c) where + theDefault = (theDefault, theDefault, theDefault) writeArray :: ix -> a -> ArrayTransaction ix a () writeArray index' val = ArrayBuilderM_ (M.singleton index' val) () -buildArray :: (Ix ix) => (ix,ix) -> e -> ArrayTransaction ix e () -> Array ix e +buildArray :: (Ix ix) => (ix, ix) -> e -> ArrayTransaction ix e () -> Array ix e buildArray bounds' def (ArrayBuilderM_ map' _) = - listArray bounds' [maybeLookup map' bound | bound <- range bounds'] - where maybeLookup map_ key = fromMaybe def (M.lookup key map_) - + listArray bounds' [maybeLookup map' bound | bound <- range bounds'] + where + maybeLookup map_ key = fromMaybe def (M.lookup key map_) diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs index b23f6ba..8a41f9e 100644 --- a/Graphics/Glyph/BufferBuilder.hs +++ b/Graphics/Glyph/BufferBuilder.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + module Graphics.Glyph.BufferBuilder where -import Graphics.Rendering.OpenGL -import Foreign.Storable -import Foreign.Ptr -import Foreign.Marshal.Array import Data.Array.Storable import qualified Data.Foldable as Fold -import Data.Sequence as Seq import Data.Map as Map - -import Graphics.Glyph.Util +import Data.Sequence as Seq +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable import Graphics.Glyph.GLMath - +import Graphics.Glyph.Util +import Graphics.Rendering.OpenGL import System.IO.Unsafe import Unsafe.Coerce -data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End +data BufferBuilder3D = Plot BufferBuilder3D (GLfloat, GLfloat, GLfloat) Int Int | End + bufferSize :: BufferBuilder3D -> Int bufferSize End = 0 bufferSize (Plot _ _ l _) = l @@ -31,78 +31,78 @@ nelem (Plot _ _ _ l) = l sizeofGLfloat :: Int sizeofGLfloat = 4 -simpleCube :: Num a => [(a,a,a)] -simpleCube = trianglesFromQuads [ - (-1, 1,-1) - , ( 1, 1,-1) - , ( 1,-1,-1) - , (-1,-1,-1) - - , (-1, 1, 1) - , ( 1, 1, 1) - , ( 1,-1, 1) - , (-1,-1, 1) - - , (-1, 1, 1) - , ( 1, 1, 1) - , ( 1, 1,-1) - , (-1, 1,-1) - - , (-1,-1, 1) - , ( 1,-1, 1) - , ( 1,-1,-1) - , (-1,-1,-1) - - , (-1,-1, 1) - , (-1, 1, 1) - , (-1, 1,-1) - , (-1,-1,-1) - - , ( 1,-1, 1) - , ( 1, 1, 1) - , ( 1, 1,-1) - , ( 1,-1,-1) +simpleCube :: Num a => [(a, a, a)] +simpleCube = + trianglesFromQuads + [ (-1, 1, -1), + (1, 1, -1), + (1, -1, -1), + (-1, -1, -1), + (-1, 1, 1), + (1, 1, 1), + (1, -1, 1), + (-1, -1, 1), + (-1, 1, 1), + (1, 1, 1), + (1, 1, -1), + (-1, 1, -1), + (-1, -1, 1), + (1, -1, 1), + (1, -1, -1), + (-1, -1, -1), + (-1, -1, 1), + (-1, 1, 1), + (-1, 1, -1), + (-1, -1, -1), + (1, -1, 1), + (1, 1, 1), + (1, 1, -1), + (1, -1, -1) ] class Monad a => IsModelBuilder b a where - plotVertex3 :: b -> b -> b -> a () - plotNormal :: b -> b -> b -> a () - plotTexture :: b -> b ->a () + 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 + +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, + 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++"]" + show (CompiledBuild stride enabled n ptr nbytes) = + "[CompiledBuild stride=" ++! stride ++ " enabled" ++! enabled ++ " n=" ++! n ++ " ptr=" ++! ptr ++ " nbytes=" ++! nbytes ++ "]" instance Functor (BuilderM t) where fmap f b = b >>= (return . f) @@ -115,206 +115,240 @@ instance Applicative (BuilderM t) where return (fn a) instance 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') + (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 + b1@(BuilderM _ ret) >>= func = b1 >> func ret - return = BuilderM (LeafBuilder Seq.empty) + return = BuilderM (LeafBuilder Seq.empty) instance Functor Builder where - fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2)) - fmap f (LeafBuilder seq') = (LeafBuilder (fmap f seq')) + 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' + 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' + 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 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) initial func = - let (sequ,snow) = Fold.foldl' (\(seq', snowball) datum -> - let (snow',lst) = func snowball datum in - (seq' >< Seq.fromList lst,snow')) (Seq.empty,initial) seq1 in - (snow,LeafBuilder sequ) + 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) initial func = + let (sequ, snow) = + Fold.foldl' + ( \(seq', snowball) datum -> + let (snow', lst) = func snowball datum + in (seq' >< Seq.fromList lst, snow') + ) + (Seq.empty, initial) + seq1 + in (snow, LeafBuilder sequ) {- Add a vertex to the current builder -} -bVertex3 :: (a,a,a) -> BuilderM a () +bVertex3 :: (a, a, a) -> BuilderM a () bVertex3 vert = BuilderM (LeafBuilder (Seq.singleton $ VertexLink vert)) () -bTexture2 :: (a,a) -> BuilderM a () +bTexture2 :: (a, a) -> BuilderM a () bTexture2 tex = BuilderM (LeafBuilder (Seq.singleton $ TextureLink tex)) () -bNormal3 :: (a,a,a) -> BuilderM a () +bNormal3 :: (a, a, a) -> BuilderM a () bNormal3 norm = BuilderM (LeafBuilder (Seq.singleton $ NormalLink norm)) () -bColor4 :: (a,a,a,a) -> BuilderM a () +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 (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 _ = [] - 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 + tp3 True (a, b, c) = [a, b, c] + tp3 False _ = [] - 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 _ = [] + 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 + 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 -> Int -> Ptr b -> IO BufferObject ptrToBuffer target len ptr = do - -- len is length in bytes - [buffer] <- genObjectNames 1 - bindBuffer target $= Just buffer - bufferData target $= (fromIntegral len, ptr, StaticDraw) - return buffer + -- 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 +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 +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 +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 len arr 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) + 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 :: (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) - + 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 (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 :: (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 + BuilderM + ( flip fmap builder $ \datum -> + case datum of + VertexLink tup -> VertexLink $ zipWithT3 (+) tup trans + _ -> datum + ) + ret diff --git a/Graphics/Glyph/ExtendedGL.hs b/Graphics/Glyph/ExtendedGL.hs index a056c5b..4d77924 100644 --- a/Graphics/Glyph/ExtendedGL.hs +++ b/Graphics/Glyph/ExtendedGL.hs @@ -1,8 +1,7 @@ -module Graphics.Glyph.ExtendedGL - ( - module All - ) where +module Graphics.Glyph.ExtendedGL + ( module All, + ) +where -import Graphics.Glyph.ExtendedGL.Framebuffers as All hiding (framebufferBasicParameteri) import Graphics.Glyph.ExtendedGL.Base as All - +import Graphics.Glyph.ExtendedGL.Framebuffers as All hiding (framebufferBasicParameteri) diff --git a/Graphics/Glyph/ExtendedGL/Base.hs b/Graphics/Glyph/ExtendedGL/Base.hs index 88566f4..9b50ddb 100644 --- a/Graphics/Glyph/ExtendedGL/Base.hs +++ b/Graphics/Glyph/ExtendedGL/Base.hs @@ -1,111 +1,117 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Graphics.Glyph.ExtendedGL.Base where +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} -import qualified Graphics.Rendering.OpenGL as GL -import Graphics.GL.Core43 -import Graphics.GL.Compatibility30 +module Graphics.Glyph.ExtendedGL.Base where +import Control.Monad +import Data.Proxy +import Data.StateVar +import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable -import Foreign.C.Types - +import Graphics.GL.Compatibility30 +import Graphics.GL.Core43 +import qualified Graphics.Rendering.OpenGL as GL import System.IO.Unsafe -import Control.Monad - -import Data.StateVar import Unsafe.Coerce -import Data.Proxy -data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show,Enum) +data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show, Enum) class IsBindable a where - bind :: a -> IO () + bind :: a -> IO () + class IsGLEnumMarshallable a where - toGLEnum :: a -> GLenum + toGLEnum :: a -> GLenum + class IsGenerable a where - generate :: IO a + generate :: IO a + class IsWrappedPrimitive t a where - unwrap :: a -> t - wrap :: t -> a + unwrap :: a -> t + wrap :: t -> a + class HasIntegerParam t a where - parami :: t -> a -> SettableStateVar GLuint + parami :: t -> a -> SettableStateVar GLuint + class HasFloatParam t a where - paramf :: t -> a -> SettableStateVar GLfloat + paramf :: t -> a -> SettableStateVar GLfloat + class HasParamOfType b t a where - param :: t -> a -> SettableStateVar b + param :: t -> a -> SettableStateVar b class IsPrimitiveModeMarshallable a where - marshalPrimitiveMode :: a -> GLuint + marshalPrimitiveMode :: a -> GLuint castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => Proxy t -> a -> b castPrimitive _ x = wrap unw - where - unw :: t - unw = unwrap x + where + unw :: t + unw = unwrap x instance (IsWrappedPrimitive a a) where - unwrap = id - wrap = id + unwrap = id + wrap = id + instance (IsWrappedPrimitive GLenum a) => IsGLEnumMarshallable a where - toGLEnum = unwrap + toGLEnum = unwrap instance IsPrimitiveModeMarshallable ExPrimitiveMode where - marshalPrimitiveMode x = case x of - Points -> GL_POINTS - Triangles -> GL_TRIANGLES - Lines -> GL_LINES - Patches -> GL_PATCHES + marshalPrimitiveMode x = case x of + Points -> GL_POINTS + Triangles -> GL_TRIANGLES + Lines -> GL_LINES + Patches -> GL_PATCHES instance IsPrimitiveModeMarshallable GL.PrimitiveMode where - marshalPrimitiveMode x = case x of - GL.Points -> 0x0 - GL.Lines -> 0x1 - GL.LineLoop -> 0x2 - GL.LineStrip -> 0x3 - GL.Triangles -> 0x4 - GL.TriangleStrip -> 0x5 - GL.TriangleFan -> 0x6 - GL.Quads -> 0x7 - GL.QuadStrip -> 0x8 - GL.Polygon -> 0x9 + marshalPrimitiveMode x = case x of + GL.Points -> 0x0 + GL.Lines -> 0x1 + GL.LineLoop -> 0x2 + GL.LineStrip -> 0x3 + GL.Triangles -> 0x4 + GL.TriangleStrip -> 0x5 + GL.TriangleFan -> 0x6 + GL.Quads -> 0x7 + GL.QuadStrip -> 0x8 + GL.Polygon -> 0x9 instance IsPrimitiveModeMarshallable GLuint where - marshalPrimitiveMode = id + marshalPrimitiveMode = id vertexAttributeDivisor :: GL.AttribLocation -> SettableStateVar GLuint vertexAttributeDivisor (GL.AttribLocation loc) = - makeSettableStateVar $ \val -> - glVertexAttribDivisor loc val + makeSettableStateVar $ \val -> + glVertexAttribDivisor loc val {- Sets the number of vertices per patch - for OpenGL -} patchVertices :: (Integral a) => SettableStateVar a -patchVertices = - makeSettableStateVar $ \val -> - glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val +patchVertices = + makeSettableStateVar $ \val -> + glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val {- Returns the maximum number of patches - for a tessilation shader -} maxPatchVertices :: IO CInt maxPatchVertices = - alloca $ \ptr -> do - glGetIntegerv GL_MAX_PATCH_VERTICES ptr - fromIntegral <$> peek ptr + alloca $ \ptr -> do + glGetIntegerv GL_MAX_PATCH_VERTICES ptr + fromIntegral <$> peek ptr getGLVersion :: IO String getGLVersion = - let lift2 (a,b) = do - x <- a ; y <- b ; return (x,y) - in - alloca $ \ptr1 -> alloca $ \ptr2 -> do + let lift2 (a, b) = do + x <- a + y <- b + return (x, y) + in alloca $ \ptr1 -> alloca $ \ptr2 -> do glGetIntegerv GL_MAJOR_VERSION ptr1 glGetIntegerv GL_MINOR_VERSION ptr2 - (v1,v2) <- lift2 (peek ptr1, peek ptr2) + (v1, v2) <- lift2 (peek ptr1, peek ptr2) return ("OpenGL " ++ show v1 ++ "." ++ show v2) coerced :: a -coerced = unsafeCoerce (0::Int) +coerced = unsafeCoerce (0 :: Int) diff --git a/Graphics/Glyph/ExtendedGL/Framebuffers.hs b/Graphics/Glyph/ExtendedGL/Framebuffers.hs index a6c2891..1de7781 100644 --- a/Graphics/Glyph/ExtendedGL/Framebuffers.hs +++ b/Graphics/Glyph/ExtendedGL/Framebuffers.hs @@ -1,109 +1,120 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} module Graphics.Glyph.ExtendedGL.Framebuffers where -import Graphics.GL.Compatibility30 -import Graphics.GL.Core43 -import qualified Graphics.Rendering.OpenGL as GL - -import Graphics.Glyph.ExtendedGL.Base - +import Control.Monad +import Data.StateVar +import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable -import Foreign.C.Types - -import Data.StateVar -import Control.Monad - +import Graphics.GL.Compatibility30 +import Graphics.GL.Core43 +import Graphics.Glyph.ExtendedGL.Base +import qualified Graphics.Rendering.OpenGL as GL import Unsafe.Coerce - -class ( - HasParamOfType GLuint FramebufferParameter a, +class + ( HasParamOfType GLuint FramebufferParameter a, HasIntegerParam GLenum a, IsGenerable a, - IsBindable a, IsWrappedPrimitive GLuint a) => IsFramebuffer a where - - -- this function MUST discard the argument - getType :: a -> GLenum + IsBindable a, + IsWrappedPrimitive GLuint a + ) => + IsFramebuffer a + where + -- this function MUST discard the argument + getType :: a -> GLenum framebufferBasicParameteri :: (IsFramebuffer a) => GLenum -> a -> GLenum -> SettableStateVar GLuint framebufferBasicParameteri typ fb enum = - makeSettableStateVar (\value -> do + makeSettableStateVar + ( \value -> do bind fb - glFramebufferParameteri typ enum $ fromIntegral value) + glFramebufferParameteri typ enum $ fromIntegral value + ) data Renderbuffer = Renderbuffer GLuint + instance IsWrappedPrimitive GLuint Renderbuffer where - unwrap (Renderbuffer x) = x + unwrap (Renderbuffer x) = x + instance IsGenerable Renderbuffer where - generate = alloca $ \ptr -> do - glGenRenderbuffers 1 ptr - liftM Renderbuffer $ peek ptr + generate = alloca $ \ptr -> do + glGenRenderbuffers 1 ptr + liftM Renderbuffer $ peek ptr + instance IsBindable Renderbuffer where - bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap + bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap + +data RenderbufferArgument + = DepthAttachment -data RenderbufferArgument = - DepthAttachment instance IsWrappedPrimitive GLenum RenderbufferArgument where - unwrap DepthAttachment = GL_DEPTH_ATTACHMENT + unwrap DepthAttachment = GL_DEPTH_ATTACHMENT renderBufferStorageRaw :: (IsGLEnumMarshallable a, IsGLEnumMarshallable b) => a -> b -> Int -> Int -> IO () -renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ) - (toGLEnum enum) (fromIntegral w) (fromIntegral h) -renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a,Int,Int) -renderBufferStorage buffer = makeSettableStateVar $ \(en,w,h) -> do - bind buffer - renderBufferStorageRaw GL_RENDERBUFFER en w h - -frameBufferRenderBuffer :: forall a b. (IsFramebuffer a,IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a +renderBufferStorageRaw typ enum w h = + glRenderbufferStorage + (toGLEnum typ) + (toGLEnum enum) + (fromIntegral w) + (fromIntegral h) + +renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a, Int, Int) +renderBufferStorage buffer = makeSettableStateVar $ \(en, w, h) -> do + bind buffer + renderBufferStorageRaw GL_RENDERBUFFER en w h + +frameBufferRenderBuffer :: forall a b. (IsFramebuffer a, IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a frameBufferRenderBuffer rb e = do - let enum :: GLenum - enum = getType test - unw :: GLuint - unw = unwrap rb - bind rb - glFramebufferRenderbuffer enum (toGLEnum e) GL_RENDERBUFFER (unwrap rb) - return $ wrap unw - where - test :: a - test = coerced + let enum :: GLenum + enum = getType test + unw :: GLuint + unw = unwrap rb + bind rb + glFramebufferRenderbuffer enum (toGLEnum e) GL_RENDERBUFFER (unwrap rb) + return $ wrap unw + where + test :: a + test = coerced data DrawFramebuffer = DrawFramebuffer GLuint + data FramebufferParameter = DefaultWidth | DefaultHeight instance IsWrappedPrimitive GLenum FramebufferParameter where - unwrap p = case p of - DefaultWidth -> GL_FRAMEBUFFER_DEFAULT_WIDTH - DefaultHeight -> GL_FRAMEBUFFER_DEFAULT_HEIGHT - wrap x | x == GL_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth - | x == GL_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight - | otherwise = undefined + unwrap p = case p of + DefaultWidth -> GL_FRAMEBUFFER_DEFAULT_WIDTH + DefaultHeight -> GL_FRAMEBUFFER_DEFAULT_HEIGHT + wrap x + | x == GL_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth + | x == GL_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight + | otherwise = undefined instance HasIntegerParam GLenum DrawFramebuffer where - parami p fb = framebufferBasicParameteri GL_DRAW_FRAMEBUFFER fb p + parami p fb = framebufferBasicParameteri GL_DRAW_FRAMEBUFFER fb p {- Has parameters of type GLuint which are acessable by the data FramebufferParameter for - the type DrawFramebuffer -} instance HasParamOfType GLuint FramebufferParameter DrawFramebuffer where - param = parami . toGLEnum + param = parami . toGLEnum instance IsGenerable DrawFramebuffer where - generate = alloca $ \ptr -> do - glGenFramebuffers 1 ptr - liftM DrawFramebuffer $ peek ptr + generate = alloca $ \ptr -> do + glGenFramebuffers 1 ptr + liftM DrawFramebuffer $ peek ptr instance IsBindable DrawFramebuffer where - bind (DrawFramebuffer fb) = glBindFramebuffer GL_DRAW_FRAMEBUFFER fb + bind (DrawFramebuffer fb) = glBindFramebuffer GL_DRAW_FRAMEBUFFER fb instance IsWrappedPrimitive GLuint DrawFramebuffer where - unwrap (DrawFramebuffer fb) = fb - wrap = DrawFramebuffer + unwrap (DrawFramebuffer fb) = fb + wrap = DrawFramebuffer instance IsFramebuffer DrawFramebuffer where - getType _ = GL_DRAW_FRAMEBUFFER + getType _ = GL_DRAW_FRAMEBUFFER diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs index ac3e93a..7614cf7 100644 --- a/Graphics/Glyph/GLMath.hs +++ b/Graphics/Glyph/GLMath.hs @@ -1,44 +1,51 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + 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 Data.Maybe import Debug.Trace +import Graphics.Glyph.Mat4 +import Graphics.Rendering.OpenGL (GLfloat, Uniform, UniformComponent, Vertex3 (..), uniform) +import qualified Graphics.Rendering.OpenGL as GL + +data Vec2 a = Vec2 (a, a) deriving (Show, Eq) + +data Vec3 a = Vec3 (a, a, a) deriving (Show, Eq) -data Vec2 a = Vec2 (a,a) deriving (Show,Eq) -data Vec3 a = Vec3 (a,a,a) deriving (Show,Eq) -data Vec4 a = Vec4 (a,a,a,a) deriving (Show,Eq) +data Vec4 a = Vec4 (a, a, a, a) deriving (Show, Eq) 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) - uniformv _ = undefined + 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) + uniformv _ = undefined 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) - uniformv _ = undefined + 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) + uniformv _ = undefined 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 - + (<+>) :: 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 @@ -47,168 +54,294 @@ class (Floating flT) => Vector flT b where (|||) = 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) + (<+>) (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) + (<+>) (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) + (<+>) (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 ) +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 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 - Matrix4 (sx, ux, -fx, 0, - sy, uy, -fy, 0, - sz, uz, -fz, 0, - -(s<.>e) , -(u'<.>e), f<.>e, 1 ) + 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 Matrix4 + ( sx, + ux, + - fx, + 0, + sy, + uy, + - fy, + 0, + sz, + uz, + - fz, + 0, + - (s <.> e), + - (u' <.> e), + f <.> e, + 1 + ) orthoMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat orthoMatrix top bot right left near far = - Matrix4 (2 / (right-left), 0, 0, - (right + left) / (right - left), - 0, 2 / (top-bot), 0, - (top+bot) / (top-bot), - 0, 0, -2 / (far-near), - (far+near) / (far - near), - 0, 0, 0, 1) + Matrix4 + ( 2 / (right - left), + 0, + 0, + - (right + left) / (right - left), + 0, + 2 / (top - bot), + 0, + - (top + bot) / (top - bot), + 0, + 0, + -2 / (far - near), + - (far + near) / (far - near), + 0, + 0, + 0, + 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) $ - Matrix4 (res00, 0, 0, 0, - 0, res11, 0, 0, - 0, 0, res22, res23, - 0, 0, res32, 0) + 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) $ + Matrix4 + ( 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 + 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 ) - - + 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 + vTranslate mat (Vec4 tmp) = translateMat4 mat tmp + mat -*| tmp = glslMatMul mat tmp glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a -glslMatMul (Matrix4 (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 ) +glslMatMul + ( Matrix4 + ( 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 + ) glslModelViewToNormalMatrix :: Mat4 GLfloat -> Mat3 GLfloat -glslModelViewToNormalMatrix = fromJust.inverse.transpose.trunc4 +glslModelViewToNormalMatrix = fromJust . inverse . transpose . trunc4 (==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a (==>) = glslMatTranslate + glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a glslMatTranslate - mat@(Matrix4 (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 - Matrix4 (m00,m01,m02,m03, - m10,m11,m12,m13, - m20,m21,m22,m23, - m30+v0,m31+v1,m32+v2,m33+v3) - + mat@( Matrix4 + ( 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 Matrix4 + ( m00, + m01, + m02, + m03, + m10, + m11, + m12, + m13, + m20, + m21, + m22, + m23, + m30 + v0, + m31 + v1, + m32 + v2, + m33 + v3 + ) + rotationMatrix :: GLfloat -> Vec3 GLfloat -> Mat3 GLfloat -rotationMatrix ang (Vec3 (u,v,w)) = - let l = (u*u + v*v + w*w) - u2 = u*u - v2 = v*v - w2 = w*w in - Matrix3 ( - (u2 + (v2 + w2) * cos(ang)) / l, - (u * v * (1 - cos(ang)) - w * sqrt(l) * sin(ang)) / l, - (u * w * (1 - cos(ang)) + v * sqrt(l) * sin(ang)) / l, - - (u * v * (1 - cos(ang)) + w * sqrt(l) * sin(ang)) / l, - (v2 + (u2 + w2) * cos(ang)) / l, - (v * w * (1 - cos(ang)) - u * sqrt(l) * sin(ang)) / l, - - (u * w * (1 - cos(ang)) - v * sqrt(l) * sin(ang)) / l, - (v * w * (1 - cos(ang)) + u * sqrt(l) * sin(ang)) / l, - (w2 + (u2 + v2) * cos(ang)) / l +rotationMatrix ang (Vec3 (u, v, w)) = + let l = (u * u + v * v + w * w) + u2 = u * u + v2 = v * v + w2 = w * w + in Matrix3 + ( (u2 + (v2 + w2) * cos (ang)) / l, + (u * v * (1 - cos (ang)) - w * sqrt (l) * sin (ang)) / l, + (u * w * (1 - cos (ang)) + v * sqrt (l) * sin (ang)) / l, + (u * v * (1 - cos (ang)) + w * sqrt (l) * sin (ang)) / l, + (v2 + (u2 + w2) * cos (ang)) / l, + (v * w * (1 - cos (ang)) - u * sqrt (l) * sin (ang)) / l, + (u * w * (1 - cos (ang)) - v * sqrt (l) * sin (ang)) / l, + (v * w * (1 - cos (ang)) + u * sqrt (l) * sin (ang)) / l, + (w2 + (u2 + v2) * cos (ang)) / l ) zRotationMatrix :: GLfloat -> Mat3 GLfloat -zRotationMatrix ang = rotationMatrix ang (Vec3 (0,0,1)) +zRotationMatrix ang = rotationMatrix ang (Vec3 (0, 0, 1)) maybeNormalize :: (Vector f a, Eq f) => a f -> a f maybeNormalize x = if norm x == 0 then x else normalize x coordinateConvert :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat coordinateConvert forward up' vector = - if vector == Vec3 (0,0,0) then vector else - let right = forward × up' - up = right × forward in - case (normalize forward, normalize up, normalize right, vector) of - (za,ya,xa,Vec3 (x,y,z)) -> (x `vScale` xa) <+> (y `vScale` ya) <+> (z `vScale` za) - + if vector == Vec3 (0, 0, 0) + then vector + else + let right = forward × up' + up = right × forward + in case (normalize forward, normalize up, normalize right, vector) of + (za, ya, xa, Vec3 (x, y, z)) -> (x `vScale` xa) <+> (y `vScale` ya) <+> (z `vScale` za) + rotateFrom :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat rotateFrom vector relative newRelative = - if vector == Vec3 (0,0,0) then vector else - case (normalize relative, normalize newRelative) of - (r', n') -> - if r' == n' then vector else - let axis = r' × n' - ang = acos $ r' `vDot` n' in - rotationMatrix ang axis -*| vector - + if vector == Vec3 (0, 0, 0) + then vector + else case (normalize relative, normalize newRelative) of + (r', n') -> + if r' == n' + then vector + else + let axis = r' × n' + ang = acos $ r' `vDot` n' + in rotationMatrix ang axis -*| vector diff --git a/Graphics/Glyph/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs index 53c6681..0b87490 100644 --- a/Graphics/Glyph/GeometryBuilder.hs +++ b/Graphics/Glyph/GeometryBuilder.hs @@ -1,148 +1,156 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Graphics.Glyph.GeometryBuilder where - -import Data.Sequence as Seq -import Data.Maybe +{-# LANGUAGE TemplateHaskell #-} -import Graphics.Glyph.Util -import Graphics.Glyph.BufferBuilder +module Graphics.Glyph.GeometryBuilder where -import Data.ByteStringBuilder import Data.ByteString.Lazy import Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteStringBuilder import Data.Foldable as Fold - +import Data.Maybe +import Data.Sequence as Seq +import Graphics.Glyph.BufferBuilder +import Graphics.Glyph.Util import Text.Printf data OutType = TriangleStrip | Triangles + instance Show OutType where - show TriangleStrip = "triangle_strip" - show Triangles = "triangle_strip" + 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), - + 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 -} + } generating :: OutType -> GeometryBuilder () -> GeometryBuilder () -generating TriangleStrip builder = builder { gOutType = Just TriangleStrip } +generating TriangleStrip builder = builder {gOutType = Just TriangleStrip} generating Triangles builder = do - let (nSeq,_) = - Fold.foldl' (\(tSeq,cnt) datum -> - case datum of + let (nSeq, _) = + Fold.foldl' + ( \(tSeq, cnt) datum -> + case datum of EmitVertex -> - if cnt == (2::Int) then (tSeq |> datum |> EndPrimitive, 0) + if cnt == (2 :: Int) + then (tSeq |> datum |> EndPrimitive, 0) else (tSeq |> datum, cnt + 1) - _ -> (tSeq |> datum,cnt) - ) (Seq.empty, 0) (gList builder) + _ -> (tSeq |> datum, cnt) + ) + (Seq.empty, 0) + (gList builder) - builder { - gOutType = Just Triangles, + builder + { gOutType = Just Triangles, gList = nSeq } projectionMatrixUniform :: String -> GeometryBuilder () -projectionMatrixUniform str = (return ()) { pjMatrixUniform = (Just str) } +projectionMatrixUniform str = (return ()) {pjMatrixUniform = (Just str)} modelViewMatrixUniform :: String -> GeometryBuilder () -modelViewMatrixUniform str = (return ()) { mvMatrixUniform = (Just str) } +modelViewMatrixUniform str = (return ()) {mvMatrixUniform = (Just str)} maxVerticies :: Int -> GeometryBuilder () -maxVerticies i = (return ()) { maxVerts = (Just i) } +maxVerticies i = (return ()) {maxVerts = (Just i)} textureOutput :: String -> GeometryBuilder () -textureOutput str = (return ()) { textureOut = (Just str) } +textureOutput str = (return ()) {textureOut = (Just str)} normalOutput :: String -> GeometryBuilder () -normalOutput str = (return ()) { normalOut = (Just str) } +normalOutput str = (return ()) {normalOut = (Just str)} positionOutput :: String -> GeometryBuilder () -positionOutput str = (return ()) { positionOut = (Just str) } +positionOutput str = (return ()) {positionOut = (Just str)} gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder () -gVertex4 x y z w = (return ()) { gList = Seq.singleton $ Vertex x y z w } +gVertex4 x y z w = (return ()) {gList = Seq.singleton $ Vertex x y z w} gNormal3 :: Float -> Float -> Float -> GeometryBuilder () -gNormal3 x y z = (return ()) { gList = (Seq.singleton $ Normal x y z) } +gNormal3 x y z = (return ()) {gList = (Seq.singleton $ Normal x y z)} gTexture2 :: Float -> Float -> GeometryBuilder () -gTexture2 x y = (return ()) { gList = (Seq.singleton $ Texture x y) } +gTexture2 x y = (return ()) {gList = (Seq.singleton $ Texture x y)} gEmitVertex :: GeometryBuilder () -gEmitVertex = (return ()) { gList = (Seq.singleton $ EmitVertex) } +gEmitVertex = (return ()) {gList = (Seq.singleton $ EmitVertex)} gEndPrimitive :: GeometryBuilder () -gEndPrimitive = (return ()) { gList = Seq.singleton $ EndPrimitive } +gEndPrimitive = (return ()) {gList = Seq.singleton $ EndPrimitive} gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder () gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex @@ -152,38 +160,39 @@ instance Functor GeometryBuilder where instance Applicative GeometryBuilder where (<*>) afn aa = do - fn <- afn - a <- aa - return (fn a) + fn <- afn + a <- aa + return (fn a) pure = return 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 - + 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 instance IsModelBuilder Float GeometryBuilder where - plotVertex3 x y z = gVertex4E x y z 0 - plotNormal = gNormal3 - plotTexture = gTexture2 - + 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 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, setTeardownRouti