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

Implement shading for more types of shapes (cylinders, boxes)

Browse Source
This commit is contained in:
justin
2023-03-16 15:34:32 +00:00
parent 249262b2b6
commit 24c1264f96
7 changed files with 190 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Picture.hs
+13 -8
View File
@@ -9,6 +9,7 @@ module Dodge.Creature.Picture (
deadFeet,
) where
import Shape
import Control.Lens
import Dodge.Creature.HandPos (translateToLeftHand, translateToRightHand)
import Dodge.Creature.Test
@@ -18,25 +19,29 @@ import Dodge.Item.Draw
import Geometry
import Picture
import qualified Quaternion as Q
import Shape
--import Shape
import ShapePicture
basicCrPict :: Creature -> SPic
basicCrPict cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
<> (basicCrShape cr, mempty)
testShape :: Shape
testShape = translateSHz 10 . rotateSHx 1 . upperBox 20 $ polyCirc 2 10
basicCrShape ::
Creature ->
Shape
basicCrShape cr
| _crCamouflage cr == Invisible = mempty
| otherwise =
tr . scaleSH (V3 crsize crsize crsize) $
mconcat
[ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
, rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
]
| otherwise = colorSH white $ tr $ rotdir testShape
-- | otherwise =
-- tr . scaleSH (V3 crsize crsize crsize) $
-- mconcat
-- [ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
-- , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
-- , rotmdir $ colorSH (_skinLower cskin) $ feet cr
-- ]
where
cskin = _crType cr
crsize = 0.1 * _crRad cr
src/Dodge/Render.hs
+3
View File
@@ -141,11 +141,14 @@ doDrawing' win pdata u = do
let fs = _shapeShader pdata
glUseProgram (_shadName fs)
glBindVertexArray $ fs ^. shadVAO . vaoName
-- glEnable GL_CULL_FACE
-- glCullFace GL_BACK
glDrawElements
(marshalEPrimitiveMode $ _shadPrim' fs)
(fromIntegral nIndices)
GL_UNSIGNED_SHORT
nullPtr
-- glDisable GL_CULL_FACE
--draw floor onto base buffer
drawShader (fst $ _textureArrayShader pdata) nFls
--draw lightmap into its own buffer
src/Dodge/Room/Foreground.hs
-2
View File
@@ -141,8 +141,6 @@ putShape sh =
bnds = shapeBounds sh
m = midBounds bnds
--shapePoints :: Shape -> Stream (Of Point2) Identity ()
--shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
shapePoints :: Shape -> [Point2]
shapePoints = concatMap (map stripZ . _sfVs)
src/Preload/Render.hs
+1 -1
View File
@@ -141,7 +141,7 @@ preloadRender = do
positionalBlankShad <- makeShader "positional/blank" [vert, frag] [3] ETriangles
-- 2D draw shaders
bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] ETriangles
bslista <- makeShader4 "shape/basic" [vert, frag] [4, 4, 4] nShapeVerxComp ETriangles shVBO
bslista <- makeShader4 "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp ETriangles shVBO
glVertexArrayElementBuffer (bslista ^. shadVAO . vaoName) shEBOname
aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] ETriangles
eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] ETriangles
src/Shader/Poke.hs
+138 -8
View File
@@ -6,6 +6,7 @@ module Shader.Poke
, pokeWallsWindowsFloor
, memoTopPrismEdgeIndices
) where
import Linear.V3 (cross)
import Geometry.Polygon
import Shader.Data
import Shader.Parameters
@@ -98,11 +99,77 @@ pokeShapeObj
-> IO (Int,Int,Int)
{-# INLINE pokeShapeObj #-}
pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
TopPrism size -> pokeTopPrism midp col (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
TopPrism size -> pokeTopPrism midp col size ptr iptr ieptr counts (VFSM.fromList shVerts)
TopBox size -> pokeBox col size ptr iptr ieptr counts shVerts
TopCylinder size -> pokeCylinder col size ptr iptr ieptr counts shVerts
-- TopCylinder size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
where
midp = centroidNum shVerts
pokeCylinder :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort
-> (Int,Int,Int)
-> [Point3]
-> IO (Int,Int,Int)
pokeCylinder col size ptr iptr ieptr (nv,nshapeindices,nei) (tc:bc:svs) = do
nv' <- pokeCylinderCurve col size ptr tc bc svs nv
--nv' <- VFSM.foldlM' (pokeJustV tc col ptr) nv $ VFSM.fromList svs
nsi' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices
--(memoCylinderIndices V.! (size - 2))
(memoTopPrismIndices V.! (size - 2))
nei' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nei
$ memoTopPrismEdgeIndices V.! (size - 3)
return (nv',nsi',nei')
pokeCylinder _ _ _ _ _ _ _ = undefined
pokeCylinderCurve col size ptr tc bc svs nv = go True svs nv
where
go _ [] n = return n
go True (x:xs) n = pokeJustV tc col ptr n x >>= go False xs
go False (x:xs) n = pokeJustV bc col ptr n x >>= go True xs
pokeCylinderEnds = undefined
pokeBox :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort
-> (Int,Int,Int)
-> [Point3]
-> IO (Int,Int,Int)
{-# INLINE pokeBox #-}
pokeBox col size ptr iptr ieptr (nv,nshapeindices,nei) svs = do
nv' <- VFSM.foldM' (pokeBoxSurface col ptr svs) nv $ VFSM.fromList $ boxSurfaces size
nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices
(memoFlatIndices V.! (size -3))
nei' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nei
$ memoBoxEdgeIndices V.! (size - 3)
return (nv', nshapeindices', nei')
-- should probably use a vector of Point3
pokeBoxSurface :: Point4 -> Ptr Float -> [Point3] -> Int -> [Int] -> IO Int
pokeBoxSurface col ptr vs n is = foldM
(pokeFlatV norm col ptr)
n
v
where
v = (V.backpermute (V.fromList vs) (V.fromList is))
x = v V.! 0
y = v V.! 1
z = v V.! 2
norm = negate $ cross (x-y) (z-y)
boxSurfaces :: Int -> [[Int]]
boxSurfaces size = [0,2 .. size * 2 -1]
: [1,3 .. size * 2]
: map f [0,2 .. size * 2 - 1]
where
f x = map (`mod` (size *2)) [x, x+1, x+3, x+2]
boxSurfaces' :: Int -> [[Int]]
boxSurfaces' n = [0 .. n -1]
: reverse [n .. n * 2-1]
: map (map ((2*n)+)) [[4*i,4*i+1,4*i+2,4*i+3] | i <- [0..n-1]]
-- : map f [0,1 .. n - 1]
where
f x = map (`mod` (n *2)) [x, x+n, x+n+1, x+1]
pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort
-> Ptr GLushort
-> (Int,Int,Int)
@@ -112,9 +179,9 @@ pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort
pokeTopPrism cp col size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
nv' <- VFSM.foldlM' (pokeJustV cp col ptr) nv svs
nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices
(memoTopPrismIndices V.! size)
(memoTopPrismIndices V.! (size - 2))
nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
(memoTopPrismEdgeIndices V.! size)
(memoTopPrismEdgeIndices V.! (size - 3))
return (nv', nshapeindices', nedgeindices')
pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
@@ -130,20 +197,40 @@ pokeTopPrismIndex :: Int -> Ptr GLushort
-> Int
-> Int
-> IO Int
--{-# INLINE pokeTopPrismIndex #-}
{-# INLINE pokeTopPrismIndex #-}
pokeTopPrismIndex nv iptr nshapeindices ioff = do
pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
return $ nshapeindices + 1
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
memoTopPrismEdgeIndices = V.generate 10
$ UV.fromList . topPrismEdgeIndices . (+ 2)
triangulate :: [Int] -> [Int]
triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is)
triangulateIndices :: Int -> [Int]
triangulateIndices i = concatMap f [0..i-3]
where
f x | even x = [0,(x+1),(x+2)]
| odd x = [0,(x+2),(x+1)]
memoFlatIndices :: V.Vector (UV.Vector Int)
memoFlatIndices = V.generate 10
$ UV.fromList . concatMap triangulate . boxSurfaces' . (+3)
memoTopPrismIndices :: V.Vector (UV.Vector Int)
memoTopPrismIndices = V.generate 10
$ UV.fromList . topPrismIndices . (+ 2)
topPrismEdgeIndices :: Int -> [Int]
memoCylinderIndices :: V.Vector (UV.Vector Int)
memoCylinderIndices = V.generate 10
$ UV.fromList . cylinderIndices . (+ 2)
-- $ UV.fromList . topPrismIndices . (+ 2)
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
memoTopPrismEdgeIndices = V.generate 10
$ UV.fromList . topPrismEdgeIndices . (+3)
topPrismEdgeIndices
:: Int -- ^ the number of vertices on the top surface, ie. half the total
-> [Int]
topPrismEdgeIndices n = concatMap f [0..n-1]
where
f i = map g
@@ -154,6 +241,23 @@ topPrismEdgeIndices n = concatMap f [0..n-1]
where
g j = (2 * i + j) `mod` (2*n)
memoBoxEdgeIndices :: V.Vector (UV.Vector Int)
memoBoxEdgeIndices = V.generate 10
$ UV.fromList . boxEdgeIndices . (+3)
boxEdgeIndices
:: Int -- ^ the number of vertices on the top surface, ie. half the total
-> [Int]
boxEdgeIndices n = concatMap f [0..n-1]
where
f i = map g
[ 0 , 1 , n , 2
, 0 , n ,-1 , n+1
, n , n+1 ,n-1 , 1
]
where
g j = (i + j) `mod` (2*n)
topPrismIndices :: Int -> [Int]
topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
++ concatMap f' [1..n-2] -- triangles on bottom face
@@ -167,6 +271,16 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
g x = [2*x,2*x+1,2*x+3
,2*x,2*x+3,2*x+2]
cylinderIndices :: Int -> [Int]
cylinderIndices n = [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]
-- consider changing the position to a vec4
-- and just doing two pokes rather than seven
-- (especially if adding normal data)
@@ -186,6 +300,22 @@ pokeJustV cp col ptr nv sh = do
V4 r g b a = col
V3 nx ny nz = cp
pokeFlatV :: Point3
-> Point4
-> Ptr Float
-> Int
-> Point3
-> IO Int
{-# INLINE pokeFlatV #-}
pokeFlatV norm col ptr nv sh = do
zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1]
return (nv + 1)
where
f i = pokeElemOff ptr (nv*nShapeVerxComp + i)
V3 x y z = sh
V4 r g b a = col
V3 nx ny nz = sh - norm
pokeLayVerxs
:: MV.MVector (PrimState IO) (FullShader ,VBO)
-> UMV.MVector (PrimState IO) Int
src/Shape.hs
+27
View File
@@ -7,6 +7,7 @@ module Shape
, upperPrismPolyHalf
, prismPoly
, polyCirc
, upperBox
, translateSHz
, translateSHf
, rotateSH
@@ -17,6 +18,7 @@ module Shape
, overColSH
-- , overColSHM
, overPosSH
, upperCylinder
) where
import Geometry
import Shape.Data
@@ -71,6 +73,31 @@ upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black)
f (x:xs) = g h x : g 0 x : f xs
f _ = []
upperBox
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperBox #-}
upperBox h ps = singleShape (Surface (TopBox n) (f ps) white)
where
n = length ps
g h' (V2 x y) = V3 x y h'
f (x:xs) = g h x : g 0 x : f xs
f _ = []
upperCylinder
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperCylinder #-}
upperCylinder h ps = singleShape (Surface (TopCylinder n) (addZ h cc:addZ 0 cc:f ps) black)
where
cc = centroid ps
n = length ps
g h' (V2 x y) = V3 x y h'
f (x:xs) = g h x : g 0 x : f xs
f _ = []
upperPrismPolyHalf
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
src/Shape/Data.hs
+8 -5
View File
@@ -19,11 +19,11 @@ shVfromList = id
{-# INLINE shEfromList #-}
shEfromList = id
data ShapeType = TopPrism { _prismSize :: Int }
-- | Surface { _surfaceSize :: Int}
| TopBox { _topBoxSize :: Int }
| TopCylinder { _topCylinderSize :: Int }
deriving (Eq, Ord, Show, Read)
--deriving stock Generic
--deriving anyclass Flat
-- for TopCylinder, the first vertex in _sfVs should be the center of the top
-- plane, the second should be the center of the bottom plane.
data Surface = Surface
{ _sfType :: ShapeType
@@ -38,7 +38,10 @@ makeLenses ''ShapeType
type Shape = [Surface]
nShapeVerxComp :: Int
nShapeVerxComp = 12
nShapeVerxComp = sum shapeVerxSizes
shapeVerxSizes :: [Int]
shapeVerxSizes = [4,4,4]
deriveJSON defaultOptions ''ShapeType
deriveJSON defaultOptions ''Surface