diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index f5ac91e7b..0af1792a0 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -15,11 +15,76 @@ import Foreign import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth) +import qualified Control.Foldl as F + +import Control.Monad + +import Data.Traversable + +data RenderType + = RenderPoly [(Point3,Point4)] + | RenderText [(Point3,Point4,Point3)] + | RenderCirc (Point3,Point4,Float) + | RenderArc (Point3,Point4,Point4) + | RenderLine [(Point3,Point4)] + | RenderEllipse [(Point3,Point4)] + + data VAO = VAO { _vao :: VertexArrayObject , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)] } +data FullShader = FullShader + { _shaderProgram :: Program + , _shaderUniforms :: [UniformLocation] + , _shaderVAO :: VAO + , _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int + , _shaderDrawPrimitive :: PrimitiveMode + } makeLenses ''VAO +makeLenses ''FullShader + +bindShaderBuffers :: [FullShader] -> [Int] -> IO () +bindShaderBuffers fss is = + zipWithM_ f fss is + where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs + +fSize = sizeOf (0 :: Float) + +bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO () +{-# INLINE bindArrayBuffers #-} +bindArrayBuffers numVs ps = do + forM_ ps $ \(bo,ptr,i) -> do + bindBuffer ArrayBuffer $= Just bo + bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw) + + +pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int] +pokeShaders fss = traverse pokeShader fss + +pokeShader :: FullShader -> F.FoldM IO RenderType Int +pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return + where vao = _shaderVAO fs + (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao + fls = _shaderPokeStrategy fs + +pokeRender :: (RenderType -> [[[Float]]]) + -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int +pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt) + +pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int +pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss + +pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int +pokePtrs ptrIs n fss = do + zipWithM_ f ptrIs fss + return $ n + 1 + where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs + +pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO () +pokeArrayOff ptr i xs = + zipWithM_ (pokeElemOff ptr) [i..] xs + type RGBA = (Float,Float,Float,Float) type Color = (Float,Float,Float,Float) @@ -65,21 +130,6 @@ flat4 (x,y,z,w) = [x,y,z,w] {-# INLINE flat3 #-} {-# INLINE flat4 #-} -data FullShader = FullShader - { _shaderProgram :: Program - , _shaderUniforms :: [UniformLocation] - , _shaderVAO :: VAO --- , _shaderPokeStrategy :: [Ptr Float] -> F.FoldM IO RenderType Int - } - -data RenderType - = RenderPoly [(Point3,Point4)] - | RenderText [(Point3,Point4,Point3)] - | RenderCirc (Point3,Point4,Float) - | RenderArc (Point3,Point4,Point4) - | RenderLine [(Point3,Point4)] - | RenderEllipse [(Point3,Point4)] - data Picture = Blank | Text Int String diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index b448bf988..b0a0d8dbb 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -333,14 +333,7 @@ rotate3 :: Float -> Point3 -> Point3 rotate3 a (x,y,z) = (x',y',z) where (x',y') = rotateV a (x,y) -fSize = sizeOf (0 :: Float) -bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO () -bindArrayBuffers numVs ps = do - forM_ ps $ \(bo,ptr,i) -> do - bindBuffer ArrayBuffer $= Just bo - bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw) - twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float) {-# INLINE twoPtrsVAO #-} twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of