diff options
Diffstat (limited to 'Graphics/Glyph/BufferBuilder.hs')
| -rw-r--r-- | Graphics/Glyph/BufferBuilder.hs | 466 |
1 files changed, 250 insertions, 216 deletions
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 |