From bbbddb844d1d0d9d20cad6569b1d58c4b68e70a1 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 16 Mar 2023 21:05:09 +0000 Subject: [PATCH] Add cylinder shapes --- src/Dodge/Creature/Picture.hs | 3 +-- src/Shader/Poke.hs | 46 +++++++++++++++++++++++++++-------- src/Shape.hs | 21 +++++++++++++--- 3 files changed, 54 insertions(+), 16 deletions(-) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index ebc35334c..408ad6e4f 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -27,14 +27,13 @@ basicCrPict cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawE <> (basicCrShape cr, mempty) --testShape :: Shape ---testShape = translateSHz 10 . rotateSHx 0 . upperCylinder 20 $ polyCirc 2 10 +--testShape = translateSHz 10 . rotateSHx 1 . upperCylinder 20 $ polyCirc 2 10 basicCrShape :: Creature -> Shape basicCrShape cr | _crCamouflage cr == Invisible = mempty --- | otherwise = colorSH white $ tr $ rotdir testShape | otherwise = tr . scaleSH (V3 crsize crsize crsize) $ mconcat diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 84af99646..9627b6911 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -127,8 +127,7 @@ pokeCylinder :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort pokeCylinder col size ptr iptr ieptr (nv,nshapeindices,nei) (tc:bc:svs) = do nv' <- pokeRoundedCurve col ptr tc bc svs nv >>= pokeCylinderCaps col ptr tc bc svs nsi' <- UV.foldM' (pokeIndex nv iptr) nshapeindices - --(memoTopPrismIndices V.! (size - 2)) - (memoTopPrismIndices V.! (size - 3)) + (memoCylinderIndices V.! (size - 3)) nei' <- UV.foldM' (pokeIndex nv ieptr) nei $ memoTopPrismEdgeIndices V.! (size - 3) return (nv',nsi',nei') @@ -145,8 +144,8 @@ pokeCylinderCaps :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int - pokeCylinderCaps col 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 + go True (x:xs) n = pokeJustVInvNormal tc col ptr n x >>= go False xs + go False (x:xs) n = pokeJustVInvNormal bc col ptr n x >>= go True xs pokeBox :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort -> (Int,Int,Int) @@ -195,7 +194,6 @@ 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 - 2)) (memoTopPrismIndices V.! (size - 3)) nedgeindices' <- UV.foldM' (pokeIndex nv ieptr) nedgeindices (memoTopPrismEdgeIndices V.! (size - 3)) @@ -238,6 +236,10 @@ memoTopPrismIndices :: V.Vector (UV.Vector Int) memoTopPrismIndices = V.generate 10 $ UV.fromList . topPrismIndices . (+ 3) +memoCylinderIndices :: V.Vector (UV.Vector Int) +memoCylinderIndices = V.generate 10 + $ UV.fromList . cylinderIndices . (+ 3) + memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int) memoTopPrismEdgeIndices = V.generate 10 $ UV.fromList . topPrismEdgeIndices . (+3) @@ -272,11 +274,18 @@ boxEdgeIndices n = concatMap f [0..n-1] where g j = (i + j) `mod` (2*n) ---cylinderIndices :: Int -> [Int] ---cylinderIndices n = topPrismIndices n --- ++ --- where --- x = length $ topPrismIndices n +cylinderIndices :: Int -> [Int] +cylinderIndices n = cylinderRoundIndices n + ++ triangulate [2*n, 2*n+2 .. 4*n - 1] + ++ triangulate [2*n+1, 2*n+3 .. 4*n - 1] + +cylinderRoundIndices :: Int -> [Int] +cylinderRoundIndices 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 + g x = [2*x,2*x+1,2*x+3 + ,2*x,2*x+3,2*x+2] topPrismIndices :: Int -> [Int] topPrismIndices n = concatMap f [1..n-2] -- triangles on top face @@ -311,6 +320,23 @@ pokeJustV cp col ptr nv sh = do V4 r g b a = col V3 nx ny nz = cp +pokeJustVInvNormal + :: Point3 + -> Point4 + -> Ptr Float + -> Int + -> Point3 + -> IO Int +{-# INLINE pokeJustVInvNormal #-} +pokeJustVInvNormal 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 = sh + V4 r g b a = col + V3 nx ny nz = (2*sh) - cp + pokeFlatV :: Point3 -> Point4 -> Ptr Float diff --git a/src/Shape.hs b/src/Shape.hs index 1e8bfe6fe..2d0a684a2 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -16,9 +16,9 @@ module Shape , scaleSH , colorSH , overColSH --- , overColSHM , overPosSH , upperCylinder + , upperRounded ) where import Geometry import Shape.Data @@ -90,7 +90,20 @@ upperCylinder -> [Point2] -> Shape {-# INLINE upperCylinder #-} -upperCylinder h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black) +upperCylinder h ps = singleShape (Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 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 _ = [] + +upperRounded + :: Float -- ^ height, expected to be strictly positive + -> [Point2] + -> Shape +{-# INLINE upperRounded #-} +upperRounded h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black) where cc = centroid ps n = length ps @@ -110,8 +123,8 @@ upperPrismPolyHalf h ps = singleShape (Surface (TopPrism n) (f upps downps) blac downps = map f'' ps f (a:as) (b:bs) = a:b:f as bs f _ _ = [] - f' (V2 x y) = (V3 (0.5 * x) (0.5 * y) h) - f'' (V2 x y) = (V3 x y 0) + 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 #-}