diff options
Diffstat (limited to 'Graphics/Glyph/BufferBuilder.hs')
| -rw-r--r-- | Graphics/Glyph/BufferBuilder.hs | 163 |
1 files changed, 163 insertions, 0 deletions
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs new file mode 100644 index 0000000..e43e48a --- /dev/null +++ b/Graphics/Glyph/BufferBuilder.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Graphics.Glyph.BufferBuilder where + +import Control.Monad +import Graphics.Rendering.OpenGL +import Foreign.Storable +import Foreign.Ptr +import Data.Array.Storable +import Data.Setters +import Debug.Trace +import qualified Data.Foldable as Fold +import Data.Sequence as Seq + +import Graphics.Glyph.Mat4 +import Graphics.Glyph.Util + +import System.IO.Unsafe + +data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End +bufferSize :: BufferBuilder3D -> Int +bufferSize End = 0 +bufferSize (Plot _ _ l _) = l + +nelem :: BufferBuilder3D -> Int +nelem End = 0 +nelem (Plot _ _ _ l) = l + +sizeofGLfloat :: Int +sizeofGLfloat = 4 + +{- A state monad that keeps track of operations + - and will compile them into a buffer -} +data Builder b a = Builder { + bList :: Seq (BuildDatum b), + bReturn :: a +} | BuildError String + +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 :: StorableArray Int b +} + +bufferLength :: (Integral a) => CompiledBuild b -> a +bufferLength = fromIntegral . nElems + +instance Show (CompiledBuild x) where + show (CompiledBuild stride enabled n _) = + "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++"]" + +instance (Num t) => Monad (Builder t) where + (Builder lst1 _) >> (Builder lst2 ret) = Builder (lst2 >< lst1) ret + BuildError str >> _ = BuildError str + _ >> BuildError str = BuildError str + + b1@(Builder _ ret1) >>= func = b1 >> func ret1 + BuildError str >>= _ = BuildError str + + return = Builder empty + fail = BuildError + +{- Add a vertex to the current builder -} +bVertex3 :: (a,a,a) -> Builder a () +bVertex3 vert = Builder (Seq.singleton $ VertexLink vert) () + +bTexture2 :: (a,a) -> Builder a () +bTexture2 tex = Builder (Seq.singleton $ TextureLink tex) () + +bNormal3 :: (a,a,a) -> Builder a () +bNormal3 norm = Builder (Seq.singleton $ NormalLink norm) () + +bColor4 :: (a,a,a,a) -> Builder a () +bColor4 col = Builder (Seq.singleton $ ColorLink col) () + +compilingBuilder :: (Storable b, Num b, Show b) => Builder b x -> IO (CompiledBuild b) +compilingBuilder (Builder lst _) = do + -- Size of the elements + let sizeof = sizeOf $ tmp (Seq.index lst 0) + where tmp (VertexLink (a,_,_)) = a + tmp _ = 0 + {- Simply figure out what types of elementse + - exist in this buffer -} + let en@(bn,bc,bt) = Fold.foldl (\(bn,bc,bt) ele -> + case ele of + NormalLink _ -> (True,bc,bt) + ColorLink _ -> (bn,True,bt) + TextureLink _ -> (bn,bc,True) + VertexLink _ -> (bn,bc,bt)) (False,False,False) lst + {- Calculate the stride; number of floats per element -} + let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof + where (?) True = 1 + (?) False = 0 + -- Cur color normal texture buffer + let (_,_,_,buffer) = + Fold.foldl (\(cn,cc,ct,ll) ele -> + -- trace ("foldl " ++! ele) $ + case ele of + NormalLink nn -> (nn,cc,ct,ll) + ColorLink nc -> (cn,nc,ct,ll) + TextureLink nt -> (cn,cc,nt,ll) + VertexLink vert -> + (cn,cc,ct, + ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct) + )) ( (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 (Seq.length buffer `div` stride * sizeof) 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 + +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 + +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 + +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 + +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 +createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject +createBufferObject target (CompiledBuild _ _ _ arr) = storableArrayToBuffer target arr |