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

Try to add compute shaders

Browse Source
This commit is contained in:
justin
2023-04-11 14:55:57 +01:00
parent 69a76dbf93
commit d79216555b
21 changed files with 457 additions and 246 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shader/Compile.hs
+6 -3
View File
@@ -12,6 +12,7 @@ module Shader.Compile (
setupVAOvbo',
setupEBO,
setupVertexAttribPointer,
makeSourcedShader,
) where
import Control.Lens
@@ -66,7 +67,8 @@ makeShaderEBO s shaderlist sizes pm vbo = do
shad <- makeShaderUsingVBO s shaderlist sizes pm vbo
ebo <- setupEBO (shad ^. shaderVAO)
glVertexArrayElementBuffer (shad ^. shaderVAO . vaoName) (ebo ^. eboName)
return ( shad
return
( shad
, ebo
)
@@ -81,7 +83,7 @@ makeShaderUsingVBO ::
VBO ->
IO Shader
makeShaderUsingVBO s shaderlist sizes pm vbo = do
vao <- setupVAOUsingVBO sizes vbo
vao <- setupVAOUsingVBO sizes vbo
makeShaderUsingVAO s shaderlist pm vao
setupVBO :: Int -> IO VBO
@@ -183,6 +185,7 @@ shaderTypeExt :: GLenum -> String
shaderTypeExt GL_VERTEX_SHADER = ".vert"
shaderTypeExt GL_GEOMETRY_SHADER = ".geom"
shaderTypeExt GL_FRAGMENT_SHADER = ".frag"
shaderTypeExt GL_COMPUTE_SHADER = ".comp"
shaderTypeExt _ = undefined
-- I think that this requires that the correct shader program is bound?
@@ -207,7 +210,7 @@ setupVAOUsingVBO sizes vbo = do
vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname
setupVertexAttribs vbo vaoname sizes strd
return VAO { _vaoName = vaoname }
return VAO{_vaoName = vaoname}
setupEBO :: VAO -> IO EBO
setupEBO vao = do
src/Shader/Poke.hs
+110 -47
View File
@@ -3,22 +3,23 @@ module Shader.Poke (
pokeLayVerxs,
pokeArrayOff,
pokeShape,
pokeShape',
pokeWallsWindows,
memoTopPrismEdgeIndices,
pokeFloors
pokeFloors,
) where
import Geometry.Vector
import Dodge.Data.Wall
import Geometry.Triangulate
import Control.Monad.Primitive
import qualified Data.Vector as V
import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector.Unboxed as UV
import qualified Data.Vector.Unboxed.Mutable as UMV
import Dodge.Data.Wall
import Foreign
import Geometry.Data
import Geometry.Triangulate
import Geometry.Vector
import Graphics.GL.Core45
import Linear.V3 (cross)
import Picture.Data
@@ -34,6 +35,7 @@ pokeVerxs ::
pokeVerxs vbos count = VFSM.mapM_ (pokeVerx vbos count) . VFSM.fromList
pokeVerx :: MV.MVector (PrimState IO) (Shader, VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
{-# INLINE pokeVerx #-}
pokeVerx vbos offsets Verx{_vxPos = thePos, _vxCol = theCol, _vxExt = ext, _vxShadNum = shadnum} = do
typeOff <- UMV.unsafeRead offsets sn
basePtr <- _vboPtr . snd <$> MV.unsafeRead vbos sn
@@ -53,9 +55,10 @@ pokeWallsWindows ::
pokeWallsWindows wiptr truewlptr wis truewls = do
wlcounts2 <- VFSM.foldlM' (pokeW wiptr) 0 (VFSM.fromList wis)
wlcounts3 <- VFSM.foldlM' (pokeWall truewlptr) 0 (VFSM.fromList truewls)
return ( wlcounts2, wlcounts3)
return (wlcounts2, wlcounts3)
pokeFloors :: Ptr Float ->
pokeFloors ::
Ptr Float ->
[(Point3, Point3)] ->
IO Int
pokeFloors flptr fls = VFSM.foldlM' (pokeF flptr) 0 (VFSM.fromList fls)
@@ -72,8 +75,9 @@ pokeF ptr i' (V3 a b c, V3 d e f) = do
return $ i' + 1
pokeWall :: Ptr Float -> Int -> Wall -> IO Int
{-# INLINE pokeWall #-}
pokeWall ptr nw wl = do
UV.imapM_ f $ UV.fromList [x,y,x1,y1,t,a,1,1]
UV.imapM_ f $ UV.fromList [x, y, x1, y1, t, a, 1, 1]
return $ nw + 1
where
f i = pokeElemOff ptr (nw * 8 + i)
@@ -94,6 +98,15 @@ pokeW ptr i' ((V2 a b, V2 c d), V4 e f g h) = do
pokeElemOff ptr (i + 7) h
return $ i' + 1
pokeShape' ::
Ptr Float ->
Ptr GLushort ->
Ptr GLushort ->
(Int, Int, Int) ->
[Surface] ->
IO (Int, Int, Int)
pokeShape' = pokeShape $ const False
pokeShape ::
(Surface -> Bool) ->
Ptr Float ->
@@ -102,8 +115,9 @@ pokeShape ::
(Int, Int, Int) ->
[Surface] ->
IO (Int, Int, Int)
pokeShape shadowtest ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is
. VFSM.fromList
pokeShape shadowtest ptr iptr ieptr is =
VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is
. VFSM.fromList
pokeShapeObj ::
(Surface -> Bool) ->
@@ -139,12 +153,17 @@ pokeRoundedFaces sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = d
(pokeIndex nv iptr)
nsi
(memoTopPrismIndices V.! (size - 3))
nei' <- if sfid then return nei
else UV.foldM' (pokeIndex nv ieptr) nei $
memoTopPrismEdgeIndices V.! (size - 3)
nei' <-
if sfid
then return nei
else
UV.foldM' (pokeIndex nv ieptr) nei $
memoTopPrismEdgeIndices V.! (size - 3)
return (nv', nsi', nei')
where
xdata | sfid = 0
xdata
| sfid = 0 -- this records whether the shadow should be shown or not
-- honestly, I think things where faster without this
| otherwise = 1
pokeRoundedFaces _ _ _ _ _ _ _ _ = undefined
@@ -166,13 +185,16 @@ pokeCylinder sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do
(pokeIndex nv iptr)
nsi
(memoCylinderIndices V.! (size - 3))
nei' <- if sfid
then return nei
else UV.foldM' (pokeIndex nv ieptr) nei $
memoTopPrismEdgeIndices V.! (size - 3)
nei' <-
if sfid
then return nei
else
UV.foldM' (pokeIndex nv ieptr) nei $
memoTopPrismEdgeIndices V.! (size - 3)
return (nv', nsi', nei')
where
xdata | sfid = 0
xdata
| sfid = 0
| otherwise = 1
pokeCylinder _ _ _ _ _ _ _ _ = undefined
@@ -180,11 +202,12 @@ pokeRoundedCurve :: Float -> Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3]
{-# INLINE pokeRoundedCurve #-}
pokeRoundedCurve xdata col ptr tc bc = go True
where
go True (x : xs) n = pokeJustV xdata tc col ptr n x >>= go False xs
go False (x : xs) n = pokeJustV xdata bc col ptr n x >>= go True xs
go True (x : xs) n = pokeJustV xdata tc col ptr n x >>= go False xs
go False (x : xs) n = pokeJustV xdata bc col ptr n x >>= go True xs
go _ [] n = return n
pokeCylinderCaps :: Float -> Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int
{-# INLINE pokeCylinderCaps #-}
pokeCylinderCaps xdata col ptr tc bc = go True
where
go True (x : xs) n = pokeJustVInvNormal xdata tc col ptr n x >>= go False xs
@@ -209,17 +232,22 @@ pokeBox sfid col size ptr iptr ieptr (nv, nsi, nei) svs = do
(pokeIndex nv iptr)
nsi
(memoFlatIndices V.! (size -3))
nei' <- if sfid then return nei
else UV.foldM' (pokeIndex nv ieptr) nei $
memoBoxEdgeIndices V.! (size - 3)
nei' <-
if sfid
then return nei
else
UV.foldM' (pokeIndex nv ieptr) nei $
memoBoxEdgeIndices V.! (size - 3)
return (nv', nsi', nei')
where
svsv = UV.fromList svs
xdata | sfid = 0
xdata
| sfid = 0
| otherwise = 1
-- should probably use a vector of Point3
pokeBoxSurface :: Float -> Point4 -> Ptr Float -> UV.Vector Point3 -> Int -> [Int] -> IO Int
{-# INLINE pokeBoxSurface #-}
pokeBoxSurface xdata col ptr vs n is =
UV.foldM'
(pokeFlatV xdata norm col ptr)
@@ -241,11 +269,11 @@ boxSurfaces size =
where
f x = map (`mod` (size * 2)) [x, x + 1, x + 3, x + 2]
boxSurfaces' :: Int -> [[Int]]
boxSurfaces' n =
boxSurfacesIndices :: Int -> [[Int]]
boxSurfacesIndices n =
[0 .. n -1] :
reverse [n .. n * 2 -1] :
[ map ((2 * n) +) [4 * i, 4 * i + 1, 4 * i + 2, 4 * i + 3] | i <- [0 .. n -1]]
[map ((2 * n) +) [4 * i, 4 * i + 1, 4 * i + 2, 4 * i + 3] | i <- [0 .. n -1]]
pokeIndex ::
-- | base index
@@ -261,11 +289,11 @@ pokeIndex nv eiptr ni ioff = do
pokeElemOff eiptr ni (fromIntegral $ nv + ioff)
return $ ni + 1
memoFlatIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoFlatIndices #-}
memoFlatIndices =
V.generate 10 $
UV.fromList . concatMap polyToTris . boxSurfaces' . (+ 3)
UV.fromList . concatMap polyToTris . boxSurfacesIndices . (+ 3)
memoTopPrismIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoTopPrismIndices #-}
@@ -289,10 +317,21 @@ topPrismEdgeIndices ::
[Int]
topPrismEdgeIndices n = concatMap f [0 .. n -1]
where
f i = map g
[ 0 , 2 , 1 , 4
, 0 , 1 , -2 , 3
, 1 , 3 , -1 , 2
f i =
map
g
[ 0
, 2
, 1
, 4
, 0
, 1
, -2
, 3
, 1
, 3
, -1
, 2
]
where
g j = (2 * i + j) `mod` (2 * n)
@@ -308,10 +347,20 @@ boxEdgeIndices ::
[Int]
boxEdgeIndices n = concatMap f [0 .. n -1]
where
f i = [ g 0 , g 1 ,n + g 0 , g 2
, g 0 , n + g 0 , n + g (-1) , g 1
, n + g 0 , n + g 1 , n + g (-1) , g 1
]
f i =
[ g 0
, g 1
, n + g 0
, g 2
, g 0
, n + g 0
, n + g (-1)
, g 1
, n + g 0
, n + g 1
, n + g (-1)
, g 1
]
where
g j = (i + j) `mod` n
@@ -323,14 +372,22 @@ cylinderIndices n =
cylinderRoundIndices :: Int -> [Int]
cylinderRoundIndices n =
[ 2 * n -2 , 2 * n -1 , 1
, 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n)
[ 2 * n -2
, 2 * n -1
, 1
, 2 * n -2
, 1
, 0 -- last side triangle (applies mod 2n)
]
++ concatMap g [0 .. n -2] -- other triangles on sides
where
g x =
[ 2 * x , 2 * x + 1 , 2 * x + 3
, 2 * x , 2 * x + 3 , 2 * x + 2
[ 2 * x
, 2 * x + 1
, 2 * x + 3
, 2 * x
, 2 * x + 3
, 2 * x + 2
]
topPrismIndices :: Int -> [Int]
@@ -338,21 +395,27 @@ topPrismIndices n =
concatMap f [1 .. n -2] -- triangles on top face
++ concatMap f' [1 .. n -2] -- triangles on bottom face
-- these should be checked
++ [ 2 * n -2 , 2 * n -1 , 1
, 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n)
++ [ 2 * n -2
, 2 * n -1
, 1
, 2 * n -2
, 1
, 0 -- last side triangle (applies mod 2n)
]
++ concatMap g [0 .. n -2] -- other triangles on sides
where
f x = [0, 2 * x, 2 * x + 2]
f' x = [1, 2 * x + 3, 2 * x + 1]
g x =
[ 2 * x , 2 * x + 1 , 2 * x + 3
, 2 * x , 2 * x + 3 , 2 * x + 2
[ 2 * x
, 2 * x + 1
, 2 * x + 3
, 2 * x
, 2 * x + 3
, 2 * x + 2
]
-- consider changing the position to a vec4
-- and just doing two pokes rather than seven
-- (especially if adding normal data)
pokeJustV ::
Float ->
Point3 ->
src/Shader/Poke/Cloud.hs
+3
View File
@@ -15,6 +15,7 @@ pokeCloud vptr iptr (nv,ni) cl = do
return (nv + 4, ni + 6)
pokeCloudVerx :: Ptr Float -> Cloud -> Int -> Int -> (Float, Float) -> IO ()
{-# INLINE pokeCloudVerx #-}
pokeCloudVerx ptr cl nv i (dx, dy) =
UV.imapM_ (pokeCloudFloat ptr (nv + i)) $ UV.fromList
[x, y, cz, 1, r, g, b, a, cx, cy, cz, rad, dx, dy, 0, 0]
@@ -26,7 +27,9 @@ pokeCloudVerx ptr cl nv i (dx, dy) =
a = a' * min 1 (fromIntegral (_clTimer cl) / fadet)
pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
{-# INLINE pokeCloudFloat #-}
pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)
pokeCloudIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
{-# INLINE pokeCloudIndex #-}
pokeCloudIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)