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

Add picture shader container datatype

Browse Source
This commit is contained in:
justin
2021-07-28 20:14:54 +02:00
parent a2b94965d7
commit ee553c6e49
9 changed files with 201 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shader/Compile.hs
+2
View File
@@ -151,6 +151,7 @@ setupVBO sizes = do
{ _vbo = vboName
, _vboPointer = thePtr
, _vboAttribSizes = sizes
, _vboStride = sum sizes
}
where
strd = sum sizes
@@ -173,6 +174,7 @@ setupVBOSized sizes ndraw = do
{ _vbo = vboName
, _vboPointer = thePtr
, _vboAttribSizes = sizes
, _vboStride = sum sizes
}
where
strd = sum sizes
src/Shader/Data.hs
+74
View File
@@ -9,6 +9,7 @@ module Shader.Data
, VShader (..)
, ShaderTexture (..)
, EPrimitiveMode (..)
, PicShads (..)
-- | Lens functions
, vao
, vaoVBO
@@ -27,6 +28,14 @@ module Shader.Data
, vshaderCustomUnis
, vshaderPokeTest
, psPoly
, psPolyz
, psBez
, psText
, psArc
, psEll
-- TODO make lenses for VBO object
-- , textureObject
) where
import Picture.Data
@@ -49,6 +58,7 @@ data VBO = VBO
{ _vbo :: BufferObject
, _vboPointer :: 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
@@ -58,6 +68,69 @@ data VShader = VShader
, _vshaderCustomUnis :: [UniformLocation]
, _vshaderPokeTest :: VertexType -> Bool
}
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
{- | Datatype containing the necessary information for a single shader. -}
data FullShader = FullShader
@@ -89,3 +162,4 @@ data EPrimitiveMode
makeLenses ''VAO
makeLenses ''FullShader
makeLenses ''VShader
makeLenses ''PicShads
src/Shader/Poke.hs
+44 -20
View File
@@ -1,9 +1,10 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
module Shader.Poke
( pokeArrayOff
, pokeShader
, pokeShaderLayer
, pokeVX
, pokeVX'
) where
import Shader.Data
import Shader.Parameters
@@ -22,11 +23,9 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride) (return 0) return
where
theVBO = _vaoVBO $ _shaderVAO fs
ptr = _vboPointer theVBO
stride = sum $ _vboAttribSizes theVBO
stride = _vboStride theVBO
fls = _shaderPokeStrategy fs
pokeVertices
:: (RenderType -> [[Float]])
-> Ptr Float
@@ -36,23 +35,47 @@ pokeVertices
-> IO Int
pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
pokeSL :: [(Int,[VShader])] -> [Verx] -> IO (IM.IntMap [(VShader,Int)])
pokeSL vslist vxs = do
foldM pokeVX (f vslist) vxs
where
f = IM.map (map (, 0)) . IM.fromList
getterPicShad :: VertexType -> Getting a (PicShads a) a
getterPicShad PolyV = psPoly
getterPicShad PolyzV{} = psPolyz
getterPicShad BezV{} = psBez
getterPicShad TextV{} = psText
getterPicShad ArcV{} = psArc
getterPicShad EllV = psEll
pokeVX :: IM.IntMap [(VShader,Int)] -> Verx -> IO (IM.IntMap [(VShader,Int)])
pokeVX count vx = do
let offset = _vxLayer vx
lshads = count IM.! offset
(vshad,n) = fromJust $ find (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
i = fromJust $ findIndex (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
--setterPicShad :: VertexType -> ASetter
setterPicShad PolyV = psPoly
setterPicShad PolyzV{} = psPolyz
setterPicShad BezV{} = psBez
setterPicShad TextV{} = psText
setterPicShad ArcV{} = psArc
setterPicShad EllV = psEll
pokeVX' :: PicShads VShader -> PicShads Int -> Verx -> IO (PicShads Int)
pokeVX' shads count vx = do
let f = setterPicShad (_vxType vx)
g = getterPicShad (_vxType vx)
vshad = shads ^. g
n = count ^. g
theVBO = _vaoVBO $ _vshaderVAO vshad
ptr = _vboPointer theVBO
stride = sum $ _vboAttribSizes theVBO
stride = _vboStride theVBO
pokeArrayOff ptr (stride * n) (toFls' vx)
return $ count & f +~ 1
pokeVX :: PicShads VShader -> IM.IntMap (PicShads Int) -> Verx -> IO (IM.IntMap (PicShads Int))
pokeVX shads laycounts vx = do
let theType = _vxType vx
offset = _vxLayer vx
counts = laycounts IM.! offset
getF = getterPicShad theType
vshad = shads ^. getF
n = counts ^. getF
theVBO = _vaoVBO $ _vshaderVAO vshad
ptr = _vboPointer theVBO
stride = _vboStride theVBO
pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx)
return $ count & ix offset . ix i . _2 +~ 1
return $ laycounts & ix offset . setterPicShad theType +~ 1
pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
@@ -60,7 +83,7 @@ pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stri
where
theVBO = _vaoVBO $ _vshaderVAO fs
ptr = _vboPointer theVBO
stride = sum $ _vboAttribSizes theVBO
stride = _vboStride theVBO
pokeVerticesOff
:: Ptr Float
@@ -108,5 +131,6 @@ pokeVertex ptr stride n fs = do
return $ n + 1
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
{-# INLINE pokeArrayOff #-}
pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
--{-# INLINE pokeArrayOff #-}
--pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))