justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Start cleanup

Browse Source
This commit is contained in:
justin
2021-08-12 15:02:26 +02:00
parent 62af1402ad
commit 53555865f6
10 changed files with 121 additions and 387 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Data/Preload/Render.hs
+1 -1
View File
@@ -26,7 +26,7 @@ data RenderData = RenderData
, _colorBlurShader :: FullShader , _colorBlurShader :: FullShader
, _barrelShader :: FullShader , _barrelShader :: FullShader
, _grayscaleShader :: FullShader , _grayscaleShader :: FullShader
, _pictureShaders :: MV.MVector (PrimState IO) VShader , _pictureShaders :: MV.MVector (PrimState IO) FullShader
, _fbo2 :: (FramebufferObject, TextureObject) , _fbo2 :: (FramebufferObject, TextureObject)
, _fbo3 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject)
, _fboFourth1 :: (FramebufferObject, TextureObject) , _fboFourth1 :: (FramebufferObject, TextureObject)
src/Dodge/Render.hs
+6 -6
View File
@@ -82,7 +82,7 @@ doDrawing pdata w = do
layerCounts <- UMV.replicate (6*6) 0 layerCounts <- UMV.replicate (6*6) 0
pokeBindFoldableLayer shadV layerCounts $ worldPictures w pokeBindFoldableLayer shadV layerCounts $ worldPictures w
renderLayer' 0 shadV layerCounts renderLayer 0 shadV layerCounts
nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs] bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]
@@ -92,14 +92,14 @@ doDrawing pdata w = do
clear [ColorBuffer] clear [ColorBuffer]
blendFunc $= (SrcAlpha,OneMinusSrcAlpha) blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderLayer' 1 shadV layerCounts renderLayer 1 shadV layerCounts
bindFramebuffer Framebuffer $= fst (_fboColor pdata) bindFramebuffer Framebuffer $= fst (_fboColor pdata)
clear [ColorBuffer] clear [ColorBuffer]
depthMask $= Disabled depthMask $= Disabled
renderLayer' 3 shadV layerCounts renderLayer 3 shadV layerCounts
renderLayer' 4 shadV layerCounts renderLayer 4 shadV layerCounts
renderLayer' 5 shadV layerCounts renderLayer 5 shadV layerCounts
depthMask $= Enabled depthMask $= Enabled
bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata) bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata)
@@ -143,7 +143,7 @@ doDrawing pdata w = do
depthFunc $= Just Lequal depthFunc $= Just Lequal
--mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2) --mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2)
renderLayer' 2 shadV layerCounts renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints renderWindows pdata windowPoints
depthFunc $= Just Always depthFunc $= Just Always
src/Layers.hs
-151
View File
@@ -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
src/Preload/Render.hs
+6 -6
View File
@@ -63,14 +63,14 @@ preloadRender = do
<- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency
>>= addUniforms ["lightPos"] >>= addUniforms ["lightPos"]
-- 2D draw shaders -- 2D draw shaders
bslist <- makeVShader "twoD/basic" [vert,frag] [3,4] ETriangles bslist <- makeShader "twoD/basic" [vert,frag] [3,4] ETriangles
aslist <- makeVShader "twoD/arc" [vert,frag] [3,4,3] ETriangles aslist <- makeShader "twoD/arc" [vert,frag] [3,4,3] ETriangles
eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles
bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip
cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles
>>= vaddTextureNoFilter "data/texture/charMap.png" >>= vaddTextureNoFilter "data/texture/charMap.png"
-- this should really be a 2d texture array -- 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 -- fullscreen shaders
fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip
pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord
src/Render.hs
+8 -15
View File
@@ -22,7 +22,7 @@ import Foreign hiding (rotate)
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T) import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
--import Data.Foldable --import Data.Foldable
--import Data.Tuple.Extra --import Data.Tuple.Extra
import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
import qualified SDL import qualified SDL
import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Unboxed.Mutable as UMV
import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Mutable as MV
@@ -146,7 +146,7 @@ drawTextureOnFramebuffer fs fbo to = do
drawShader fs 4 drawShader fs 4
pokeBindFoldable pokeBindFoldable
:: MV.MVector (PrimState IO) VShader :: MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> [Verx] -> [Verx]
-> IO () -> IO ()
@@ -154,11 +154,8 @@ pokeBindFoldable shadV counts m = do
pokeVerxs shadV counts m pokeVerxs shadV counts m
bindShader shadV counts bindShader shadV counts
zeroCounts :: PicShads Int
zeroCounts = PicShads 0 0 0 0 0 0
pokeBindFoldableLayer pokeBindFoldableLayer
:: MV.MVector (PrimState IO) VShader :: MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> Picture -> Picture
-> IO () -> IO ()
@@ -167,7 +164,7 @@ pokeBindFoldableLayer shadV counts m = do
bindShaderLayers shadV counts bindShaderLayers shadV counts
renderFoldable renderFoldable
:: MV.MVector (PrimState IO) VShader :: MV.MVector (PrimState IO) FullShader
-> [Verx] -> [Verx]
-> IO () -> IO ()
renderFoldable shadV struct = do renderFoldable shadV struct = do
@@ -176,7 +173,7 @@ renderFoldable shadV struct = do
MV.imapM_ (drawShaderLay' 0 counts) shadV MV.imapM_ (drawShaderLay' 0 counts) shadV
renderFoldableTimed renderFoldableTimed
:: MV.MVector (PrimState IO) VShader :: MV.MVector (PrimState IO) FullShader
-> [Verx] -> [Verx]
-> IO Word32 -> IO Word32
renderFoldableTimed shadV struct = do renderFoldableTimed shadV struct = do
@@ -188,18 +185,14 @@ renderFoldableTimed shadV struct = do
return $ pokeEndTicks - pokeStartTicks return $ pokeEndTicks - pokeStartTicks
------------------------------end renderFoldable ------------------------------end renderFoldable
renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO () renderLayer
renderLayer layer shads counts = sequence_ $ drawShaderLay layer <$> shads <*> counts IM.! layer
renderLayer'
:: Int :: Int
-> MV.MVector (PrimState IO) VShader -> MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> IO () -> IO ()
renderLayer' layer shads counts = do renderLayer layer shads counts = do
let layerCounts = UMV.slice (layer * 6) 6 counts let layerCounts = UMV.slice (layer * 6) 6 counts
MV.imapM_ (drawShaderLay' layer layerCounts) shads MV.imapM_ (drawShaderLay' layer layerCounts) shads
-- sequence_ $ drawShaderLay layer <$> shads <*> counts IM.! layer
pokeTwoOff pokeTwoOff
:: Ptr Float :: Ptr Float
src/Shader.hs
+14 -15
View File
@@ -41,11 +41,11 @@ bindArrayBuffers numVs theVBO = do
(fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO))
(_vboPtr 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 bindShaderLayers shads counts = MV.imapM_ f shads
where where
f i shad = do f i shad = do
let theVBO = _vaoVBO $ _vshaderVAO shad let theVBO = _vaoVBO $ _shaderVAO shad
stride = sum $ _vboAttribSizes theVBO stride = sum $ _vboAttribSizes theVBO
bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO) bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO)
mapM_ (g stride theVBO) [0..5] mapM_ (g stride theVBO) [0..5]
@@ -60,12 +60,11 @@ bindShaderLayers shads counts = MV.imapM_ f shads
(_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay)) (_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 bindShader shads counts = MV.imapM_ f shads
where 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 () bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
@@ -73,28 +72,28 @@ bindShaderBuffers = zipWithM_ f
where where
f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
drawShaderLay :: Int -> VShader -> Int -> IO () drawShaderLay :: Int -> FullShader -> Int -> IO ()
{-# INLINE drawShaderLay #-} {-# INLINE drawShaderLay #-}
drawShaderLay l fs i = do drawShaderLay l fs i = do
currentProgram $= Just (_vshaderProgram fs) currentProgram $= Just (_shaderProgram fs)
bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs) bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
case _vshaderTexture fs of case _shaderTexture fs of
Just ShaderTexture{_textureObject = txo} Just ShaderTexture{_textureObject = txo}
-> textureBinding Texture2D $= Just txo -> textureBinding Texture2D $= Just txo
_ -> return () _ -> 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' #-} {-# INLINE drawShaderLay' #-}
drawShaderLay' l countsVector shadIn fs = do drawShaderLay' l countsVector shadIn fs = do
i <- UMV.read countsVector shadIn i <- UMV.read countsVector shadIn
currentProgram $= Just (_vshaderProgram fs) currentProgram $= Just (_shaderProgram fs)
bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs) bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
case _vshaderTexture fs of case _shaderTexture fs of
Just ShaderTexture{_textureObject = txo} Just ShaderTexture{_textureObject = txo}
-> textureBinding Texture2D $= Just txo -> textureBinding Texture2D $= Just txo
_ -> return () _ -> return ()
glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i) glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
drawShader :: FullShader -> Int -> IO () drawShader :: FullShader -> Int -> IO ()
{-# INLINE drawShader #-} {-# INLINE drawShader #-}
src/Shader/AuxAddition.hs
+2 -2
View File
@@ -35,7 +35,7 @@ addTexture texturePath shad = do
generateMipmap' Texture2D generateMipmap' Texture2D
return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb} return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
vaddTextureNoFilter :: String -> VShader -> IO VShader vaddTextureNoFilter :: String -> FullShader -> IO FullShader
vaddTextureNoFilter texturePath shad = do vaddTextureNoFilter texturePath shad = do
Right cmap <- readImage texturePath Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap let tex = convertRGBA8 cmap
@@ -48,7 +48,7 @@ vaddTextureNoFilter texturePath shad = do
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
withArray texData $ \ptr -> do withArray texData $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr 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 :: String -> FullShader -> IO FullShader
addTextureNoFilter texturePath shad = do addTextureNoFilter texturePath shad = do
src/Shader/Compile.hs
+24 -23
View File
@@ -1,6 +1,6 @@
module Shader.Compile module Shader.Compile
( makeShader ( makeShader
, makeVShader --, makeVShader
, makeShaderSized , makeShaderSized
, makeShaderUsingShaderVAO , makeShaderUsingShaderVAO
, makeSourcedShader , makeSourcedShader
@@ -16,28 +16,28 @@ import Control.Monad
--import Control.Lens --import Control.Lens
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
{- | --{- |
Compiles a vertex shader found within the shader directory. --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. --The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
-} ---}
makeVShader --makeVShader
:: String -- ^ First part of the name of the shader -- :: String -- ^ First part of the name of the shader
-> [ShaderType] -- ^ Filetype extensions -- -> [ShaderType] -- ^ Filetype extensions
-> [Int] -- ^ The input vertex sizes -- -> [Int] -- ^ The input vertex sizes
-> EPrimitiveMode -- -> EPrimitiveMode
-> IO VShader -- -> IO VShader
makeVShader s shaderlist sizes pm = do --makeVShader s shaderlist sizes pm = do
prog <- makeSourcedShader s shaderlist -- prog <- makeSourcedShader s shaderlist
vaob <- setupVAO sizes -- vaob <- setupVAO sizes
return $ VShader -- return $ VShader
{ _vshaderProgram = prog -- { _vshaderProgram = prog
, _vshaderVAO = vaob -- , _vshaderVAO = vaob
, _vshaderTexture = Nothing -- , _vshaderTexture = Nothing
, _vshaderCustomUnis = [] -- , _vshaderCustomUnis = []
, _vshaderDrawPrimitive = pm -- , _vshaderDrawPrimitive = pm
} -- }
-- | Takes the VAO and poke strategy from another shader -- | Takes the VAO from another shader
makeShaderUsingShaderVAO makeShaderUsingShaderVAO
:: String -- ^ First part of the name of the shader :: String -- ^ First part of the name of the shader
-> [ShaderType] -- ^ Filetype extensions -> [ShaderType] -- ^ Filetype extensions
@@ -60,7 +60,8 @@ makeShader
:: String -- ^ First part of the name of the shader :: String -- ^ First part of the name of the shader
-> [ShaderType] -- ^ Filetype extensions -> [ShaderType] -- ^ Filetype extensions
-> [Int] -- ^ The input vertex sizes -> [Int] -- ^ The input vertex sizes
-> EPrimitiveMode -> IO FullShader -> EPrimitiveMode
-> IO FullShader
makeShader s shaderlist sizes pm = do makeShader s shaderlist sizes pm = do
prog <- makeSourcedShader s shaderlist prog <- makeSourcedShader s shaderlist
vaob <- setupVAO sizes vaob <- setupVAO sizes
src/Shader/Data.hs
+15 -117
View File
@@ -1,52 +1,40 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
{- | {- | Datatypes used to setup and pass data to shaders. -}
Datatypes used to setup and pass data to shaders.
-}
module Shader.Data module Shader.Data
( VAO (..) ( VAO (..)
, VBO (..) , VBO (..)
, FullShader (..) , FullShader (..)
, VShader (..)
, ShaderTexture (..) , ShaderTexture (..)
, EPrimitiveMode (..) , EPrimitiveMode (..)
, PicShads (..)
-- | Lens functions -- | Lens functions
, vao , vao
, vaoVBO , vaoVBO
, shaderProgram , shaderProgram
, shaderVAO , shaderVAO
, shaderDrawPrimitive , shaderDrawPrimitive
, shaderTexture , shaderTexture
, shaderCustomUnis , shaderCustomUnis
, vbo
, vshaderProgram , vboPtr
, vshaderVAO , vboAttribSizes
, vshaderDrawPrimitive , vboStride
, vshaderTexture -- | Synonyms
, vshaderCustomUnis
, psPoly
, psPolyz
, psBez
, psText
, psArc
, psEll
, vert , vert
, geom , geom
, frag , frag
-- TODO make lenses for VBO object
-- , textureObject
) where ) where
--import Geometry.Data
import Graphics.Rendering.OpenGL import Graphics.Rendering.OpenGL
import Foreign import Foreign
import Control.Lens 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, {- | Vertex array object: contains the reference to the object,
and its buffer targets. -} and its buffer targets. -}
data VAO = VAO data VAO = VAO
@@ -63,93 +51,6 @@ data VBO = VBO
, _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not , _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not
, _vboStride :: Int , _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]
}
{- | Datatype containing the reference to a texture object. -} {- | Datatype containing the reference to a texture object. -}
newtype ShaderTexture = ShaderTexture newtype ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject } { _textureObject :: TextureObject }
@@ -166,14 +67,11 @@ data EPrimitiveMode
| EQuadStrip | EQuadStrip
| EPolygon | EPolygon
| EPatches | EPatches
-- | Short synonyms for shader types -- | Short synonyms for shader types
vert, geom, frag :: ShaderType vert, geom, frag :: ShaderType
vert = VertexShader vert = VertexShader
geom = GeometryShader geom = GeometryShader
frag = FragmentShader frag = FragmentShader
makeLenses ''VAO makeLenses ''VAO
makeLenses ''VBO
makeLenses ''FullShader makeLenses ''FullShader
makeLenses ''VShader
makeLenses ''PicShads
src/Shader/Poke.hs
+40 -46
View File
@@ -1,22 +1,17 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
module Shader.Poke module Shader.Poke
( pokeArrayOff ( pokeVerxs
, pokeLayVerxs
, pokeArrayOff
, pokePoint3s , pokePoint3s
, pokePoint33s , pokePoint33s
, pokeVerxs
, pokeLayVerxs
, poke224s , poke224s
, picShadToUMV
, picShadToMV
, vToPicShad
, vToPicShadMV
) where ) where
import Shader.Data import Shader.Data
import Shader.Parameters import Shader.Parameters
import Picture.Data import Picture.Data
import Geometry.Data import Geometry.Data
--import Layers
--import qualified Streaming.Prelude as SP --import qualified Streaming.Prelude as SP
--import Data.Maybe --import Data.Maybe
@@ -32,16 +27,16 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VS
import Control.Monad.Primitive import Control.Monad.Primitive
pokeVerxs pokeVerxs
:: MV.MVector (PrimState IO) VShader :: MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> [Verx] -> [Verx]
-> IO () -> IO ()
pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs 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 pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
typeOff <- UMV.unsafeRead offsets sn 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) let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 ext pokeArrayOff thePtr 7 ext
@@ -49,37 +44,37 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
where where
sn = _unShadNum theShadNum sn = _unShadNum theShadNum
vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int) --vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int)
{-# INLINE vToPicShad #-} --{-# INLINE vToPicShad #-}
vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 --vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
--
vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int) --vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
{-# INLINE vToPicShadMV #-} --{-# INLINE vToPicShadMV #-}
vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 --vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
--
picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int) --picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int)
{-# INLINE picShadToUMV #-} --{-# INLINE picShadToUMV #-}
picShadToUMV (PicShads a b c d e f) = do --picShadToUMV (PicShads a b c d e f) = do
theVec <- UMV.new 6 -- theVec <- UMV.new 6
UMV.write theVec 0 a -- UMV.write theVec 0 a
UMV.write theVec 1 b -- UMV.write theVec 1 b
UMV.write theVec 2 c -- UMV.write theVec 2 c
UMV.write theVec 3 d -- UMV.write theVec 3 d
UMV.write theVec 4 e -- UMV.write theVec 4 e
UMV.write theVec 5 f -- UMV.write theVec 5 f
return theVec -- return theVec
--
picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a) --picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a)
{-# INLINE picShadToMV #-} --{-# INLINE picShadToMV #-}
picShadToMV (PicShads a b c d e f) = do --picShadToMV (PicShads a b c d e f) = do
theVec <- MV.new 6 -- theVec <- MV.new 6
MV.write theVec 0 a -- MV.write theVec 0 a
MV.write theVec 1 b -- MV.write theVec 1 b
MV.write theVec 2 c -- MV.write theVec 2 c
MV.write theVec 3 d -- MV.write theVec 3 d
MV.write theVec 4 e -- MV.write theVec 4 e
MV.write theVec 5 f -- MV.write theVec 5 f
return theVec -- return theVec
poke34 :: Ptr Float -> Point3 -> Point4 -> IO () poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
@@ -125,17 +120,17 @@ pokePoint3s ptr vals0 = go vals0 0
off i = n*3 + i off i = n*3 + i
pokeLayVerxs pokeLayVerxs
:: MV.MVector (PrimState IO) VShader :: MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> [Verx] -> [Verx]
-> IO () -> IO ()
pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs 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 #-} --{-# INLINE pokeLayVerx #-}
pokeLayVerx vbos counts vx = do pokeLayVerx vbos counts vx = do
theOff <- UMV.unsafeRead counts vecPos 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) let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
poke34 thePtr thePos theCol poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 (_vxExt vx) pokeArrayOff thePtr 7 (_vxExt vx)
@@ -146,7 +141,6 @@ pokeLayVerx vbos counts vx = do
theLayer = _vxLayer vx theLayer = _vxLayer vx
thePos = _vxPos vx thePos = _vxPos vx
theCol = _vxCol vx theCol = _vxCol vx
--basePtr = _vboPtr $ vboFromType vbos sn
layOff = theLayer * numSubElements layOff = theLayer * numSubElements
theStride = pokeStride sn theStride = pokeStride sn