From 249262b2b657c169c67e77bc19120a5200d7ac1b Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 15 Mar 2023 21:43:00 +0000 Subject: [PATCH] Refactor shapes, prepare for different normals at single vertex pos --- shader/lighting/texture.frag | 1 - src/Dodge/Render/Shadow.hs | 144 +++++++++++++++++------------------ src/Dodge/Room/Foreground.hs | 2 +- src/Shader/Poke.hs | 31 ++++---- src/Shape.hs | 35 ++++----- src/Shape/Data.hs | 31 +++----- src/ShapePicture.hs | 6 +- 7 files changed, 114 insertions(+), 136 deletions(-) diff --git a/shader/lighting/texture.frag b/shader/lighting/texture.frag index e56e35eea..97a1ee072 100644 --- a/shader/lighting/texture.frag +++ b/shader/lighting/texture.frag @@ -13,7 +13,6 @@ void main() { vec3 norm = normbit.xyz - pos; float y1 = float(normbit.w == 0 ? 1 : dot(normalize(norm), normalize(distVec))); float y = float(y1 > 0 ? 1 : 0); -// float y = float(normbit.w == 1 ? 1 : 0); float dist = dot(distVec, distVec); if (dist > rad) { discard; diff --git a/src/Dodge/Render/Shadow.hs b/src/Dodge/Render/Shadow.hs index 4b72643e5..f9c3265c8 100644 --- a/src/Dodge/Render/Shadow.hs +++ b/src/Dodge/Render/Shadow.hs @@ -3,19 +3,19 @@ module Dodge.Render.Shadow where --import Data.Vector.Unboxed as UV --import Dodge.Data.Universe -import Control.Lens +--import Control.Lens import Data.Preload.Render -import qualified Data.Vector as V +--import qualified Data.Vector as V --import qualified Data.Vector.Fusion.Stream.Monadic as VFSM -import Foreign +--import Foreign import Geometry --import Graphics.GL.Core45 -import Linear.V3 (cross) +--import Linear.V3 (cross) --import Shader.Data --import Shader.ExtraPrimitive --import Shader.Parameters import Shape.Data - +-- drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO () drawCPUShadows _ _ _ _ = return () --drawCPUShadows pdata s pos rad = do @@ -35,71 +35,71 @@ drawCPUShadows _ _ _ _ = return () -- (fromIntegral i) -- return () -pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int -pokeShapeShad pos r theptr i so = do - let vs = V.fromList $ map _svPos (_shVs so) - is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2) - V.foldM' (pokeShadEdge pos r theptr vs) i is +--pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int +--pokeShapeShad pos r theptr i so = do +-- let vs = V.fromList $ map _svPos (_shVs so) +-- is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2) +-- V.foldM' (pokeShadEdge pos r theptr vs) i is -pokeShadEdge :: - Point3 -> - Float -> - Ptr Float -> - V.Vector Point3 -> - Int -> - (Int, Int, Int, Int) -> - IO Int -pokeShadEdge pos _ ptr vxs i (a, b, x, y) = do - let p0 = vxs V.! a - p1 = vxs V.! b - --mid = 0.5 * (p0 + p1) - n0a = vxs V.! x - n1a = vxs V.! y -- this should almost certainly be done with backpermute - n0 = cross (p1 - p0) (n0a - p0) - n1 = cross (p0 - p1) (n1a - p1) - lightdir = p0 - pos - shift' p = p + (10000 *.*.* (p - pos)) - -- projNear p = - -- shiftNear p = - if dotV3 n0 lightdir * dotV3 n1 lightdir <= 0 - then do - let p2 = shift' p0 - p3 = shift' p1 - if dotV3 n0 lightdir > 0 - then - pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2 - >>= pokeV3 ptr p0 - >>= pokeV3 ptr p2 - >>= pokeV3 ptr p3 - else - pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3 - >>= pokeV3 ptr p1 - >>= pokeV3 ptr p3 - >>= pokeV3 ptr p2 - else return i - -pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int -pokeV3 ptr (V3 x y z) i = do - pokeElemOff ptr (3 * i) x - pokeElemOff ptr (3 * i + 1) y - pokeElemOff ptr (3 * i + 2) z - return (i + 1) - -memoTopPrismEdges :: V.Vector (V.Vector (Int, Int, Int, Int)) -memoTopPrismEdges = - V.generate 10 $ - V.fromList . topPrismEdges . (+ 2) - -topPrismEdges :: Int -> [(Int, Int, Int, Int)] -topPrismEdges n = concatMap f [0 .. n -1] - where - f i = - map - h - [ (0, 2, 1, 4) - , (0, 1, -2, 3) - , (1, 3, -1, 2) - ] - where - h (a, b, c, d) = (g a, g b, g c, g d) - g j = (2 * i + j) `mod` (2 * n) +--pokeShadEdge :: +-- Point3 -> +-- Float -> +-- Ptr Float -> +-- V.Vector Point3 -> +-- Int -> +-- (Int, Int, Int, Int) -> +-- IO Int +--pokeShadEdge pos _ ptr vxs i (a, b, x, y) = do +-- let p0 = vxs V.! a +-- p1 = vxs V.! b +-- --mid = 0.5 * (p0 + p1) +-- n0a = vxs V.! x +-- n1a = vxs V.! y -- this should almost certainly be done with backpermute +-- n0 = cross (p1 - p0) (n0a - p0) +-- n1 = cross (p0 - p1) (n1a - p1) +-- lightdir = p0 - pos +-- shift' p = p + (10000 *.*.* (p - pos)) +-- -- projNear p = +-- -- shiftNear p = +-- if dotV3 n0 lightdir * dotV3 n1 lightdir <= 0 +-- then do +-- let p2 = shift' p0 +-- p3 = shift' p1 +-- if dotV3 n0 lightdir > 0 +-- then +-- pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2 +-- >>= pokeV3 ptr p0 +-- >>= pokeV3 ptr p2 +-- >>= pokeV3 ptr p3 +-- else +-- pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3 +-- >>= pokeV3 ptr p1 +-- >>= pokeV3 ptr p3 +-- >>= pokeV3 ptr p2 +-- else return i +-- +--pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int +--pokeV3 ptr (V3 x y z) i = do +-- pokeElemOff ptr (3 * i) x +-- pokeElemOff ptr (3 * i + 1) y +-- pokeElemOff ptr (3 * i + 2) z +-- return (i + 1) +-- +--memoTopPrismEdges :: V.Vector (V.Vector (Int, Int, Int, Int)) +--memoTopPrismEdges = +-- V.generate 10 $ +-- V.fromList . topPrismEdges . (+ 2) +-- +--topPrismEdges :: Int -> [(Int, Int, Int, Int)] +--topPrismEdges n = concatMap f [0 .. n -1] +-- where +-- f i = +-- map +-- h +-- [ (0, 2, 1, 4) +-- , (0, 1, -2, 3) +-- , (1, 3, -1, 2) +-- ] +-- where +-- h (a, b, c, d) = (g a, g b, g c, g d) +-- g j = (2 * i + j) `mod` (2 * n) diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 254c736f4..d20352ab3 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -144,7 +144,7 @@ putShape sh = --shapePoints :: Shape -> Stream (Of Point2) Identity () --shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs) shapePoints :: Shape -> [Point2] -shapePoints = concatMap (map (stripZ . _svPos) . _shVs) +shapePoints = concatMap (map stripZ . _sfVs) shapeBounds :: Shape -> (Float, Float, Float, Float) shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 1b9fe4bd6..b0342a442 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -85,7 +85,7 @@ pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort -> (Int,Int,Int) - -> [ShapeObj] + -> [Surface] -> IO (Int,Int,Int) pokeShape ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj ptr iptr ieptr) is . VFSM.fromList @@ -94,22 +94,23 @@ pokeShapeObj -> Ptr GLushort -> Ptr GLushort -> (Int,Int,Int) - -> ShapeObj + -> Surface -> IO (Int,Int,Int) {-# INLINE pokeShapeObj #-} -pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of - TopPrism size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts) +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) +-- TopCylinder size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts) where - midp = centroidNum $ map _svPos shVerts + midp = centroidNum shVerts -pokeTopPrism :: Point3 -> Int -> Ptr Float -> Ptr GLushort +pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort -> (Int,Int,Int) - -> VFSM.Stream IO ShapeV + -> VFSM.Stream IO Point3 -> IO (Int,Int,Int) {-# INLINE pokeTopPrism #-} -pokeTopPrism cp size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do - nv' <- VFSM.foldlM' (pokeJustV cp ptr) nv svs +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) nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices @@ -170,22 +171,20 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face -- and just doing two pokes rather than seven -- (especially if adding normal data) pokeJustV :: Point3 + -> Point4 -> Ptr Float -> Int - -> ShapeV + -> Point3 -> IO Int {-# INLINE pokeJustV #-} -pokeJustV cp ptr nv sh = do +pokeJustV cp 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 = _svPos sh - V4 r g b a = _svCol sh + V3 x y z = sh + V4 r g b a = col V3 nx ny nz = cp - --nx = x - --ny = y - --nz = z - 1 pokeLayVerxs :: MV.MVector (PrimState IO) (FullShader ,VBO) diff --git a/src/Shape.hs b/src/Shape.hs index ab25707c9..1a258b888 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -22,11 +22,11 @@ import Geometry import Shape.Data import Color -singleShape :: ShapeObj -> Shape +singleShape :: Surface -> Shape {-# INLINE singleShape #-} singleShape = (:[]) -shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape +shMap :: (Surface -> Surface) -> Shape -> Shape {-# INLINE shMap #-} shMap = map @@ -52,23 +52,22 @@ prismPoly -> [Point3] -> Shape {-# INLINE prismPoly #-} -prismPoly upps downps = singleShape (ShapeObj (TopPrism n) (f upps downps)) +prismPoly upps downps = singleShape (Surface (TopPrism n) (f upps downps) black) where n = length upps - f (a:as) (b:bs) = g a:g b:f as bs + f (a:as) (b:bs) = a:b:f as bs f [] _ = [] f _ [] = [] - g p = ShapeV p black upperPrismPoly :: Float -- ^ height, expected to be strictly positive -> [Point2] -> Shape {-# INLINE upperPrismPoly #-} -upperPrismPoly h ps = singleShape (ShapeObj (TopPrism n) (f ps)) +upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black) where n = length ps - g h' (V2 x y) = pairToSV (V3 x y h', black) + g h' (V2 x y) = V3 x y h' f (x:xs) = g h x : g 0 x : f xs f _ = [] @@ -77,15 +76,15 @@ upperPrismPolyHalf -> [Point2] -> Shape {-# INLINE upperPrismPolyHalf #-} -upperPrismPolyHalf h ps = singleShape (ShapeObj (TopPrism n) (f upps downps)) +upperPrismPolyHalf h ps = singleShape (Surface (TopPrism n) (f upps downps) black) where n = length ps upps = map f' ps downps = map f'' ps f (a:as) (b:bs) = a:b:f as bs f _ _ = [] - f' (V2 x y) = pairToSV (V3 (0.5 * x) (0.5 * y) h, black) - f'' (V2 x y) = pairToSV (V3 x y 0, black) + f' (V2 x y) = (V3 (0.5 * x) (0.5 * y) h) + f'' (V2 x y) = (V3 x y 0) colorSH :: Color -> Shape -> Shape {-# INLINE colorSH #-} @@ -123,22 +122,14 @@ scaleSH :: Point3 -> Shape -> Shape {-# INLINE scaleSH #-} scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c)) -overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj +overColObj :: (Point4 -> Point4) -> Surface -> Surface {-# INLINE overColObj #-} -overColObj f (ShapeObj st vs) = ShapeObj st (fmap (overColVertex f) vs) +overColObj f (Surface st vs col) = Surface st vs (f col) --overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj --{-# INLINE overColObjM #-} --overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs -overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV -{-# INLINE overColVertex #-} -overColVertex f (ShapeV a b) = ShapeV a (f b) - -overPosObj :: (Point3 -> Point3) -> ShapeObj -> ShapeObj +overPosObj :: (Point3 -> Point3) -> Surface -> Surface {-# INLINE overPosObj #-} -overPosObj f (ShapeObj st vs) = ShapeObj st $ fmap (overPosVertex f) vs - -overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV -{-# INLINE overPosVertex #-} -overPosVertex f (ShapeV a b) = ShapeV (f a) b +overPosObj f (Surface st vs col) = Surface st (map f vs) col diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 664a25903..160160054 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -18,38 +18,27 @@ shVfromList = id {-# INLINE shEfromList #-} shEfromList = id -newtype ShapeType = TopPrism { _prismSize :: Int } - deriving newtype (Eq, Ord, Show, Read) +data ShapeType = TopPrism { _prismSize :: Int } +-- | Surface { _surfaceSize :: Int} + deriving (Eq, Ord, Show, Read) --deriving stock Generic --deriving anyclass Flat -data ShapeObj = ShapeObj - { _shType :: ShapeType - , _shVs :: [ShapeV] +data Surface = Surface + { _sfType :: ShapeType + , _sfVs :: [Point3] + , _sfColor :: Point4 } deriving (Eq, Ord, Show, Read) --Generic, Flat) --- edges are given by four consecutive points -data ShapeV = ShapeV - { _svPos :: Point3 - , _svCol :: Point4 - } - deriving (Eq, Ord, Show, Read) --Generic, Flat) - -pairToSV :: (Point3, Point4) -> ShapeV -{-# INLINE pairToSV #-} -pairToSV = uncurry ShapeV - -makeLenses ''ShapeV -makeLenses ''ShapeObj +makeLenses ''Surface makeLenses ''ShapeType -type Shape = [ShapeObj] +type Shape = [Surface] nShapeVerxComp :: Int nShapeVerxComp = 12 deriveJSON defaultOptions ''ShapeType -deriveJSON defaultOptions ''ShapeV -deriveJSON defaultOptions ''ShapeObj +deriveJSON defaultOptions ''Surface diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index c4fcd26b8..5c2f79c01 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -21,7 +21,7 @@ import Geometry import Data.Bifunctor import Control.Lens -shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape +shMap :: (Surface -> Surface) -> Shape -> Shape shMap = map -- should all this be inlined/inlinable? @@ -63,12 +63,12 @@ rotateSP a = bimap (rotateSH a) (rotate a) mirrorSPxz :: SPic -> SPic {-# INLINE mirrorSPxz #-} -mirrorSPxz = bimap (shMap (over shVs reverse) . overPosSH flipy) mirrorxz +mirrorSPxz = bimap (shMap (over sfVs reverse) . overPosSH flipy) mirrorxz where flipy (V3 x y z) = V3 x (negate y) z mirrorSPyz :: SPic -> SPic {-# INLINE mirrorSPyz #-} -mirrorSPyz = bimap (shMap (over shVs reverse) . overPosSH flipx) mirroryz +mirrorSPyz = bimap (shMap (over sfVs reverse) . overPosSH flipx) mirroryz where flipx (V3 x y z) = V3 (negate x) y z