From 24c1264f96b7d199fbf71622c6d4b15747756dbc Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 16 Mar 2023 15:34:32 +0000 Subject: [PATCH] Implement shading for more types of shapes (cylinders, boxes) --- src/Dodge/Creature/Picture.hs | 21 +++-- src/Dodge/Render.hs | 3 + src/Dodge/Room/Foreground.hs | 2 - src/Preload/Render.hs | 2 +- src/Shader/Poke.hs | 146 ++++++++++++++++++++++++++++++++-- src/Shape.hs | 27 +++++++ src/Shape/Data.hs | 13 +-- 7 files changed, 190 insertions(+), 24 deletions(-) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index d4ff8c615..6787173f0 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -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 diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 6355cbb63..6b173c1dc 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -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 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index d20352ab3..88abb77bb 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -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) diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 0dd20c516..05864f964 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -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 diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index b0342a442..4e17ed1b8 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -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 diff --git a/src/Shape.hs b/src/Shape.hs index 1a258b888..196a349a4 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -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] diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 160160054..0d1edcbc3 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -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