diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index 2c99de49d..23e861239 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -26,7 +26,7 @@ data RenderData = RenderData , _colorBlurShader :: FullShader , _barrelShader :: FullShader , _grayscaleShader :: FullShader - , _pictureShaders :: MV.MVector (PrimState IO) VShader + , _pictureShaders :: MV.MVector (PrimState IO) FullShader , _fbo2 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject) , _fboFourth1 :: (FramebufferObject, TextureObject) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 19323aa4b..9f8b76e78 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -82,7 +82,7 @@ doDrawing pdata w = do layerCounts <- UMV.replicate (6*6) 0 pokeBindFoldableLayer shadV layerCounts $ worldPictures w - renderLayer' 0 shadV layerCounts + renderLayer 0 shadV layerCounts nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs] @@ -92,14 +92,14 @@ doDrawing pdata w = do clear [ColorBuffer] blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - renderLayer' 1 shadV layerCounts + renderLayer 1 shadV layerCounts bindFramebuffer Framebuffer $= fst (_fboColor pdata) clear [ColorBuffer] depthMask $= Disabled - renderLayer' 3 shadV layerCounts - renderLayer' 4 shadV layerCounts - renderLayer' 5 shadV layerCounts + renderLayer 3 shadV layerCounts + renderLayer 4 shadV layerCounts + renderLayer 5 shadV layerCounts depthMask $= Enabled bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata) @@ -143,7 +143,7 @@ doDrawing pdata w = do depthFunc $= Just Lequal --mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2) - renderLayer' 2 shadV layerCounts + renderLayer 2 shadV layerCounts renderWindows pdata windowPoints depthFunc $= Just Always diff --git a/src/Layers.hs b/src/Layers.hs deleted file mode 100644 index 591bc8bd2..000000000 --- a/src/Layers.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -{- | -Concerns a custom layers datatype that has a fixed number of strict elements. -Contains helpers that use the structure with indices. - -} -module Layers - ( Layers (..) - , Lay (..) - , lay0 - , lay1 - , lay2 - , lay3 - , lay4 - , lay5 - , layIndices - , getLay - , foldLayersr - , sequenceLayers - , sequenceLayers_ - ) where -import Control.Lens - -data Lay = L0 | L1 | L2 | L3 | L4 | L5 - -getLay :: Int -> Layers a -> a -{-# INLINE getLay #-} -getLay 0 = _lay0 -getLay 1 = _lay1 -getLay 2 = _lay2 -getLay 3 = _lay3 -getLay 4 = _lay4 -getLay 5 = _lay5 -getLay _ = undefined - -layIndices :: Layers Int -layIndices = Layers 0 1 2 3 4 5 - -foldLayersr :: (Int -> a -> b -> b) -> b -> Layers a -> b -foldLayersr f x Layers - { _lay0 = x0 - , _lay1 = x1 - , _lay2 = x2 - , _lay3 = x3 - , _lay4 = x4 - , _lay5 = x5 - } - = f 0 x0 . f 1 x1 . f 2 x2 . f 3 x3 . f 4 x4 $ f 5 x5 x -sequenceLayers_ :: (Int -> a -> IO b) -> Layers a -> IO () -sequenceLayers_ f lays = sequence_ $ f <$> layIndices <*> lays --- f Layers --- { _lay0 = x0 --- , _lay1 = x1 --- , _lay2 = x2 --- , _lay3 = x3 --- , _lay4 = x4 --- , _lay5 = x5 --- } --- = f 0 x0 >> f 1 x1 >> f 2 x2 >> f 3 x3 >> f 4 x4 >> f 5 x5 >> return () ---foldLayersl' :: (Int -> b -> a -> b) -> b -> Layers a -> b ---foldLayersl' f x Layers --- { _lay0 = x0 --- , _lay1 = x1 --- , _lay2 = x2 --- , _lay3 = x3 --- , _lay4 = x4 --- , _lay5 = x5 --- } --- = f 0 x0 . f 1 x1 . f 2 x2 . f 3 x3 . f 4 x4 $ f 5 x5 x - -sequenceLayers :: (Int -> a -> IO b) -> Layers a -> IO (Layers b) -sequenceLayers f lays = sequence $ f <$> layIndices <*> lays - -data Layers a = Layers - { _lay0 :: a - , _lay1 :: a - , _lay2 :: a - , _lay3 :: a - , _lay4 :: a - , _lay5 :: a - } --- boilerplate folows -instance Functor Layers where - {-# INLINE fmap #-} - fmap f Layers - { _lay0 = the0 - , _lay1 = the1 - , _lay2 = the2 - , _lay3 = the3 - , _lay4 = the4 - , _lay5 = the5 - } - = Layers - { _lay0 = f the0 - , _lay1 = f the1 - , _lay2 = f the2 - , _lay3 = f the3 - , _lay4 = f the4 - , _lay5 = f the5 - } -instance Applicative Layers where - {-# INLINE pure #-} - pure a = Layers a a a a a a - {-# INLINE (<*>) #-} - (<*>) Layers - { _lay0 = f0 - , _lay1 = f1 - , _lay2 = f2 - , _lay3 = f3 - , _lay4 = f4 - , _lay5 = f5 - } - Layers - { _lay0 = x0 - , _lay1 = x1 - , _lay2 = x2 - , _lay3 = x3 - , _lay4 = x4 - , _lay5 = x5 - } - = Layers - { _lay0 = f0 x0 - , _lay1 = f1 x1 - , _lay2 = f2 x2 - , _lay3 = f3 x3 - , _lay4 = f4 x4 - , _lay5 = f5 x5 - } -instance Foldable Layers where - {-# INLINE foldr #-} - foldr f x Layers - { _lay0 = x0 - , _lay1 = x1 - , _lay2 = x2 - , _lay3 = x3 - , _lay4 = x4 - , _lay5 = x5 - } - = f x0 . f x1 . f x2 . f x3 . f x4 $ f x5 x -instance Traversable Layers where - {-# INLINE traverse #-} - traverse f Layers - { _lay0 = x0 - , _lay1 = x1 - , _lay2 = x2 - , _lay3 = x3 - , _lay4 = x4 - , _lay5 = x5 - } = Layers <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5 - -makeLenses ''Layers diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 5ac4afd38..83c521e2f 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -63,14 +63,14 @@ preloadRender = do <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency >>= addUniforms ["lightPos"] -- 2D draw shaders - bslist <- makeVShader "twoD/basic" [vert,frag] [3,4] ETriangles - aslist <- makeVShader "twoD/arc" [vert,frag] [3,4,3] ETriangles - eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles - bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip - cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles + bslist <- makeShader "twoD/basic" [vert,frag] [3,4] ETriangles + aslist <- makeShader "twoD/arc" [vert,frag] [3,4,3] ETriangles + eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles + bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip + cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles >>= vaddTextureNoFilter "data/texture/charMap.png" -- this should really be a 2d texture array - basicTweakZShad <- makeVShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles + basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles -- fullscreen shaders fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord diff --git a/src/Render.hs b/src/Render.hs index db35ea80f..92bdf387b 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -22,7 +22,7 @@ import Foreign hiding (rotate) import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T) --import Data.Foldable --import Data.Tuple.Extra -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM import qualified SDL import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV @@ -146,7 +146,7 @@ drawTextureOnFramebuffer fs fbo to = do drawShader fs 4 pokeBindFoldable - :: MV.MVector (PrimState IO) VShader + :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> [Verx] -> IO () @@ -154,11 +154,8 @@ pokeBindFoldable shadV counts m = do pokeVerxs shadV counts m bindShader shadV counts -zeroCounts :: PicShads Int -zeroCounts = PicShads 0 0 0 0 0 0 - pokeBindFoldableLayer - :: MV.MVector (PrimState IO) VShader + :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Picture -> IO () @@ -167,7 +164,7 @@ pokeBindFoldableLayer shadV counts m = do bindShaderLayers shadV counts renderFoldable - :: MV.MVector (PrimState IO) VShader + :: MV.MVector (PrimState IO) FullShader -> [Verx] -> IO () renderFoldable shadV struct = do @@ -176,7 +173,7 @@ renderFoldable shadV struct = do MV.imapM_ (drawShaderLay' 0 counts) shadV renderFoldableTimed - :: MV.MVector (PrimState IO) VShader + :: MV.MVector (PrimState IO) FullShader -> [Verx] -> IO Word32 renderFoldableTimed shadV struct = do @@ -188,18 +185,14 @@ renderFoldableTimed shadV struct = do return $ pokeEndTicks - pokeStartTicks ------------------------------end renderFoldable -renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO () -renderLayer layer shads counts = sequence_ $ drawShaderLay layer <$> shads <*> counts IM.! layer - -renderLayer' +renderLayer :: Int - -> MV.MVector (PrimState IO) VShader + -> MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () -renderLayer' layer shads counts = do +renderLayer layer shads counts = do let layerCounts = UMV.slice (layer * 6) 6 counts MV.imapM_ (drawShaderLay' layer layerCounts) shads - -- sequence_ $ drawShaderLay layer <$> shads <*> counts IM.! layer pokeTwoOff :: Ptr Float diff --git a/src/Shader.hs b/src/Shader.hs index 6452474fc..cae5e93ff 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -41,11 +41,11 @@ bindArrayBuffers numVs theVBO = do (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) (_vboPtr theVBO) -bindShaderLayers :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> IO () +bindShaderLayers :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () bindShaderLayers shads counts = MV.imapM_ f shads where f i shad = do - let theVBO = _vaoVBO $ _vshaderVAO shad + let theVBO = _vaoVBO $ _shaderVAO shad stride = sum $ _vboAttribSizes theVBO bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO) mapM_ (g stride theVBO) [0..5] @@ -60,12 +60,11 @@ bindShaderLayers shads counts = MV.imapM_ f shads (_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay)) - --lay counts = sequence_ $ bindArrayBuffersLayer lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads) -bindShader :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> IO () +bindShader :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () bindShader shads counts = MV.imapM_ f shads where - f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _vshaderVAO $ shad) + f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _shaderVAO $ shad) bindShaderBuffers :: [FullShader] -> [Int] -> IO () @@ -73,28 +72,28 @@ bindShaderBuffers = zipWithM_ f where f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs -drawShaderLay :: Int -> VShader -> Int -> IO () +drawShaderLay :: Int -> FullShader -> Int -> IO () {-# INLINE drawShaderLay #-} drawShaderLay l fs i = do - currentProgram $= Just (_vshaderProgram fs) - bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs) - case _vshaderTexture fs of + currentProgram $= Just (_shaderProgram fs) + bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) + case _shaderTexture fs of Just ShaderTexture{_textureObject = txo} -> textureBinding Texture2D $= Just txo _ -> return () - glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i) + glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i) -drawShaderLay' :: Int -> UMV.MVector (PrimState IO) Int -> Int -> VShader -> IO () +drawShaderLay' :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> IO () {-# INLINE drawShaderLay' #-} drawShaderLay' l countsVector shadIn fs = do i <- UMV.read countsVector shadIn - currentProgram $= Just (_vshaderProgram fs) - bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs) - case _vshaderTexture fs of + currentProgram $= Just (_shaderProgram fs) + bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) + case _shaderTexture fs of Just ShaderTexture{_textureObject = txo} -> textureBinding Texture2D $= Just txo _ -> return () - glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i) + glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i) drawShader :: FullShader -> Int -> IO () {-# INLINE drawShader #-} diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs index f8ef5bba9..c2c48f14b 100644 --- a/src/Shader/AuxAddition.hs +++ b/src/Shader/AuxAddition.hs @@ -35,7 +35,7 @@ addTexture texturePath shad = do generateMipmap' Texture2D return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb} -vaddTextureNoFilter :: String -> VShader -> IO VShader +vaddTextureNoFilter :: String -> FullShader -> IO FullShader vaddTextureNoFilter texturePath shad = do Right cmap <- readImage texturePath let tex = convertRGBA8 cmap @@ -48,7 +48,7 @@ vaddTextureNoFilter texturePath shad = do glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex withArray texData $ \ptr -> do glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr - return $ shad & vshaderTexture ?~ ShaderTexture {_textureObject = textureOb} + return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb} addTextureNoFilter :: String -> FullShader -> IO FullShader addTextureNoFilter texturePath shad = do diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 1df0316b7..998ae4767 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -1,6 +1,6 @@ module Shader.Compile ( makeShader - , makeVShader + --, makeVShader , makeShaderSized , makeShaderUsingShaderVAO , makeSourcedShader @@ -16,28 +16,28 @@ import Control.Monad --import Control.Lens import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) -{- | -Compiles a vertex shader found within the shader directory. -The shader is made up of files begining with the inputted string with extensions .vert, .geom etc. --} -makeVShader - :: String -- ^ First part of the name of the shader - -> [ShaderType] -- ^ Filetype extensions - -> [Int] -- ^ The input vertex sizes - -> EPrimitiveMode - -> IO VShader -makeVShader s shaderlist sizes pm = do - prog <- makeSourcedShader s shaderlist - vaob <- setupVAO sizes - return $ VShader - { _vshaderProgram = prog - , _vshaderVAO = vaob - , _vshaderTexture = Nothing - , _vshaderCustomUnis = [] - , _vshaderDrawPrimitive = pm - } +--{- | +--Compiles a vertex shader found within the shader directory. +--The shader is made up of files begining with the inputted string with extensions .vert, .geom etc. +---} +--makeVShader +-- :: String -- ^ First part of the name of the shader +-- -> [ShaderType] -- ^ Filetype extensions +-- -> [Int] -- ^ The input vertex sizes +-- -> EPrimitiveMode +-- -> IO VShader +--makeVShader s shaderlist sizes pm = do +-- prog <- makeSourcedShader s shaderlist +-- vaob <- setupVAO sizes +-- return $ VShader +-- { _vshaderProgram = prog +-- , _vshaderVAO = vaob +-- , _vshaderTexture = Nothing +-- , _vshaderCustomUnis = [] +-- , _vshaderDrawPrimitive = pm +-- } --- | Takes the VAO and poke strategy from another shader +-- | Takes the VAO from another shader makeShaderUsingShaderVAO :: String -- ^ First part of the name of the shader -> [ShaderType] -- ^ Filetype extensions @@ -60,7 +60,8 @@ makeShader :: String -- ^ First part of the name of the shader -> [ShaderType] -- ^ Filetype extensions -> [Int] -- ^ The input vertex sizes - -> EPrimitiveMode -> IO FullShader + -> EPrimitiveMode + -> IO FullShader makeShader s shaderlist sizes pm = do prog <- makeSourcedShader s shaderlist vaob <- setupVAO sizes diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index d10c15df7..709c89288 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -1,154 +1,55 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{- | -Datatypes used to setup and pass data to shaders. --} +{- | Datatypes used to setup and pass data to shaders. -} module Shader.Data ( VAO (..) , VBO (..) , FullShader (..) - , VShader (..) , ShaderTexture (..) , EPrimitiveMode (..) - , PicShads (..) -- | Lens functions , vao , vaoVBO - , shaderProgram , shaderVAO , shaderDrawPrimitive , shaderTexture , shaderCustomUnis - - , vshaderProgram - , vshaderVAO - , vshaderDrawPrimitive - , vshaderTexture - , vshaderCustomUnis - - , psPoly - , psPolyz - , psBez - , psText - , psArc - , psEll - + , vbo + , vboPtr + , vboAttribSizes + , vboStride +-- | Synonyms , vert , geom , frag - --- TODO make lenses for VBO object --- , textureObject ) where ---import Geometry.Data - import Graphics.Rendering.OpenGL import Foreign import Control.Lens ---import Graphics.GL.Types +{- | Datatype containing the necessary information for a single shader. -} +data FullShader = FullShader + { _shaderProgram :: Program + , _shaderVAO :: VAO + , _shaderDrawPrimitive :: EPrimitiveMode + , _shaderTexture :: Maybe ShaderTexture + , _shaderCustomUnis :: [UniformLocation] + } {- | Vertex array object: contains the reference to the object, and its buffer targets. -} data VAO = VAO - { _vao :: VertexArrayObject - , _vaoVBO :: VBO + { _vao :: VertexArrayObject + , _vaoVBO :: VBO } {- | Vertex buffer object: contains the reference to the object, a pointer to a location with space that can be written to the buffer, and a list of attribute pointer sizes. Vertex attributes are interleaved within the vbo. -} data VBO = VBO - { _vbo :: BufferObject - , _vboPtr :: Ptr Float + { _vbo :: BufferObject + , _vboPtr :: Ptr Float , _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not - , _vboStride :: Int - } -data VShader = VShader - { _vshaderProgram :: Program - , _vshaderVAO :: VAO - , _vshaderDrawPrimitive :: EPrimitiveMode - , _vshaderTexture :: Maybe ShaderTexture - , _vshaderCustomUnis :: [UniformLocation] - } -data PicShads a = PicShads - { _psPoly :: a - , _psPolyz :: a - , _psBez :: a - , _psText :: a - , _psArc :: a - , _psEll :: a - } --- boilerplate folows -instance Functor PicShads where - fmap f PicShads - { _psPoly = thePoly - , _psPolyz = thePolyz - , _psBez = theBez - , _psText = theText - , _psArc = theArc - , _psEll = theEll - } - = PicShads - { _psPoly = f thePoly - , _psPolyz = f thePolyz - , _psBez = f theBez - , _psText = f theText - , _psArc = f theArc - , _psEll = f theEll - } -instance Applicative PicShads where - pure a = PicShads a a a a a a - (<*>) PicShads - { _psPoly = fPoly - , _psPolyz = fPolyz - , _psBez = fBez - , _psText = fText - , _psArc = fArc - , _psEll = fEll - } - PicShads - { _psPoly = thePoly - , _psPolyz = thePolyz - , _psBez = theBez - , _psText = theText - , _psArc = theArc - , _psEll = theEll - } - = PicShads - { _psPoly = fPoly thePoly - , _psPolyz = fPolyz thePolyz - , _psBez = fBez theBez - , _psText = fText theText - , _psArc = fArc theArc - , _psEll = fEll theEll - } -instance Foldable PicShads where - foldr f x PicShads - { _psPoly = thePoly - , _psPolyz = thePolyz - , _psBez = theBez - , _psText = theText - , _psArc = theArc - , _psEll = theEll - } - = f thePoly . f thePolyz . f theBez . f theText . f theArc $ f theEll x -instance Traversable PicShads where - {-# INLINE traverse #-} - traverse f PicShads - { _psPoly = x0 - , _psPolyz = x1 - , _psBez = x2 - , _psText = x3 - , _psArc = x4 - , _psEll = x5 - } = PicShads <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5 -{- | Datatype containing the necessary information for a single shader. -} -data FullShader = FullShader - { _shaderProgram :: Program - , _shaderVAO :: VAO - , _shaderDrawPrimitive :: EPrimitiveMode - , _shaderTexture :: Maybe ShaderTexture - , _shaderCustomUnis :: [UniformLocation] + , _vboStride :: Int } {- | Datatype containing the reference to a texture object. -} newtype ShaderTexture = ShaderTexture @@ -166,14 +67,11 @@ data EPrimitiveMode | EQuadStrip | EPolygon | EPatches - -- | Short synonyms for shader types vert, geom, frag :: ShaderType vert = VertexShader geom = GeometryShader frag = FragmentShader - makeLenses ''VAO +makeLenses ''VBO makeLenses ''FullShader -makeLenses ''VShader -makeLenses ''PicShads diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 746ac5dc7..1ed2ffa02 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -1,22 +1,17 @@ --{-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} module Shader.Poke - ( pokeArrayOff + ( pokeVerxs + , pokeLayVerxs + , pokeArrayOff , pokePoint3s , pokePoint33s - , pokeVerxs - , pokeLayVerxs , poke224s - , picShadToUMV - , picShadToMV - , vToPicShad - , vToPicShadMV ) where import Shader.Data import Shader.Parameters import Picture.Data import Geometry.Data ---import Layers --import qualified Streaming.Prelude as SP --import Data.Maybe @@ -32,16 +27,16 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VS import Control.Monad.Primitive pokeVerxs - :: MV.MVector (PrimState IO) VShader + :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> [Verx] -> IO () pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs -pokeVerx :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () +pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do typeOff <- UMV.unsafeRead offsets sn - basePtr <- fmap (_vboPtr . _vaoVBO . _vshaderVAO) $ MV.read vbos sn + basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.read vbos sn let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize) poke34 thePtr thePos theCol pokeArrayOff thePtr 7 ext @@ -49,37 +44,37 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the where sn = _unShadNum theShadNum -vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int) -{-# INLINE vToPicShad #-} -vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 - -vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int) -{-# INLINE vToPicShadMV #-} -vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 - -picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int) -{-# INLINE picShadToUMV #-} -picShadToUMV (PicShads a b c d e f) = do - theVec <- UMV.new 6 - UMV.write theVec 0 a - UMV.write theVec 1 b - UMV.write theVec 2 c - UMV.write theVec 3 d - UMV.write theVec 4 e - UMV.write theVec 5 f - return theVec - -picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a) -{-# INLINE picShadToMV #-} -picShadToMV (PicShads a b c d e f) = do - theVec <- MV.new 6 - MV.write theVec 0 a - MV.write theVec 1 b - MV.write theVec 2 c - MV.write theVec 3 d - MV.write theVec 4 e - MV.write theVec 5 f - return theVec +--vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int) +--{-# INLINE vToPicShad #-} +--vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 +-- +--vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int) +--{-# INLINE vToPicShadMV #-} +--vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 +-- +--picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int) +--{-# INLINE picShadToUMV #-} +--picShadToUMV (PicShads a b c d e f) = do +-- theVec <- UMV.new 6 +-- UMV.write theVec 0 a +-- UMV.write theVec 1 b +-- UMV.write theVec 2 c +-- UMV.write theVec 3 d +-- UMV.write theVec 4 e +-- UMV.write theVec 5 f +-- return theVec +-- +--picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a) +--{-# INLINE picShadToMV #-} +--picShadToMV (PicShads a b c d e f) = do +-- theVec <- MV.new 6 +-- MV.write theVec 0 a +-- MV.write theVec 1 b +-- MV.write theVec 2 c +-- MV.write theVec 3 d +-- MV.write theVec 4 e +-- MV.write theVec 5 f +-- return theVec poke34 :: Ptr Float -> Point3 -> Point4 -> IO () @@ -125,17 +120,17 @@ pokePoint3s ptr vals0 = go vals0 0 off i = n*3 + i pokeLayVerxs - :: MV.MVector (PrimState IO) VShader + :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> [Verx] -> IO () pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs -pokeLayVerx :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () +pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () --{-# INLINE pokeLayVerx #-} pokeLayVerx vbos counts vx = do theOff <- UMV.unsafeRead counts vecPos - basePtr <- fmap (_vboPtr . _vaoVBO . _vshaderVAO) $ MV.unsafeRead vbos sn + basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.unsafeRead vbos sn let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize) poke34 thePtr thePos theCol pokeArrayOff thePtr 7 (_vxExt vx) @@ -146,7 +141,6 @@ pokeLayVerx vbos counts vx = do theLayer = _vxLayer vx thePos = _vxPos vx theCol = _vxCol vx - --basePtr = _vboPtr $ vboFromType vbos sn layOff = theLayer * numSubElements theStride = pokeStride sn