Refactor, move towards adding cylinders

2023-03-16 17:01:58 +00:00
parent 24c1264f96
commit 46d6d91138
4 changed files with 70 additions and 62 deletions
@@ -26,22 +26,22 @@ 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
+--testShape :: Shape
+--testShape = translateSHz 10 . rotateSHx 0 . 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
--                [ 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
@@ -100,34 +100,53 @@ pokeShapeObj
 {-# INLINE pokeShapeObj #-}
 pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
    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)
+    FlatFaces size -> pokeBox col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces col size ptr iptr ieptr counts shVerts
+    Cylinder size -> pokeCylinder col size ptr iptr ieptr counts shVerts
  where
    midp = centroidNum shVerts

+pokeRoundedFaces :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort
+    -> (Int,Int,Int)
+    -> [Point3]
+    -> IO (Int,Int,Int)
+pokeRoundedFaces col size ptr iptr ieptr (nv,nshapeindices,nei) (tc:bc:svs) = do
+    nv' <- pokeRoundedCurve col ptr tc bc svs nv
+    nsi' <- UV.foldM' (pokeIndex nv iptr) nshapeindices 
+        --(memoTopPrismIndices     V.! (size - 2))
+        (memoTopPrismIndices     V.! (size - 3))
+    nei' <- UV.foldM' (pokeIndex nv ieptr) nei
+        $ memoTopPrismEdgeIndices V.! (size - 3)
+    return (nv',nsi',nei')
+pokeRoundedFaces _ _ _ _ _ _ _ = undefined
+
 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
+    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))
+    nei' <- UV.foldM' (pokeIndex 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
+pokeRoundedCurve :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int
+pokeRoundedCurve 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

-pokeCylinderEnds = undefined
+pokeCylinderCaps :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO 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

 pokeBox :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort
    -> (Int,Int,Int)
@@ -136,9 +155,9 @@ pokeBox :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort
 {-# 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 
+    nshapeindices' <- UV.foldM' (pokeIndex nv iptr) nshapeindices 
        (memoFlatIndices V.! (size -3))
-    nei' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nei
+    nei' <- UV.foldM' (pokeIndex nv ieptr) nei
        $ memoBoxEdgeIndices V.! (size - 3)
    return (nv', nshapeindices', nei')

@@ -166,9 +185,6 @@ 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 
@@ -179,17 +195,20 @@ 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))
-    nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
+        --(memoTopPrismIndices     V.! (size - 2))
+        (memoTopPrismIndices     V.! (size - 3))
+    nedgeindices' <- UV.foldM' (pokeIndex nv ieptr) nedgeindices
        (memoTopPrismEdgeIndices V.! (size - 3))
    return (nv', nshapeindices', nedgeindices')

-pokeTopPrismEdgeIndex :: Int -> Ptr GLushort 
-    -> Int
-    -> Int 
+pokeIndex
+    :: Int -- ^ base index
+    -> Ptr GLushort 
+    -> Int -- ^ number poked
+    -> Int -- ^ index offset
    -> IO Int
--{-# INLINE pokeTopPrismEdgeIndex #-}
-pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do
+{-# INLINE pokeIndex #-}
+pokeIndex nv eiptr nedgeindices ioff = do
    pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff)
    return $ nedgeindices + 1

@@ -209,7 +228,7 @@ 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)]
+        | otherwise = [0,(x+2),(x+1)]

 memoFlatIndices :: V.Vector (UV.Vector Int)
 memoFlatIndices = V.generate 10
@@ -217,12 +236,7 @@ memoFlatIndices = V.generate 10

 memoTopPrismIndices :: V.Vector (UV.Vector Int)
 memoTopPrismIndices = V.generate 10 
-    $ UV.fromList . topPrismIndices . (+ 2)
-
-memoCylinderIndices :: V.Vector (UV.Vector Int)
-memoCylinderIndices = V.generate 10 
-    $ UV.fromList . cylinderIndices . (+ 2)
-    -- $ UV.fromList . topPrismIndices . (+ 2)
+    $ UV.fromList . topPrismIndices . (+ 3)

 memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
 memoTopPrismEdgeIndices = V.generate 10
@@ -258,6 +272,12 @@ 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
+
 topPrismIndices :: Int -> [Int]
 topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
    ++  concatMap f' [1..n-2]   -- triangles on bottom face
@@ -271,20 +291,11 @@ 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)
-pokeJustV :: Point3
+pokeJustV 
+    :: Point3
    -> Point4
    -> Ptr Float
    -> Int
@@ -78,7 +78,7 @@ upperBox
    -> [Point2] 
    -> Shape
 {-# INLINE upperBox #-}
-upperBox h ps = singleShape (Surface (TopBox n) (f ps) white)
+upperBox h ps = singleShape (Surface (FlatFaces n) (f ps) white)
  where
    n = length ps
    g h' (V2 x y) = V3 x y h'
@@ -90,7 +90,7 @@ upperCylinder
    -> [Point2] 
    -> Shape
 {-# INLINE upperCylinder #-}
-upperCylinder h ps = singleShape (Surface (TopCylinder n) (addZ h cc:addZ 0 cc:f ps) black)
+upperCylinder h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black)
  where
    cc = centroid ps
    n = length ps
@@ -13,16 +13,13 @@ import Data.Aeson
 import Data.Aeson.TH
 import Geometry.Data

-{-# INLINE shVfromList #-}
-shVfromList = id
-
-{-# INLINE shEfromList #-}
-shEfromList = id
-data ShapeType = TopPrism { _prismSize :: Int }
-    | TopBox { _topBoxSize :: Int }
-    | TopCylinder { _topCylinderSize :: Int }
+data ShapeType 
+    = TopPrism { _prismSize :: Int }
+    | FlatFaces { _topBoxSize :: Int }
+    | RoundedFaces { _shapeHalfSize :: Int }
+    | Cylinder { _cylinderSize :: Int }
    deriving (Eq, Ord, Show, Read)
-- for TopCylinder, the first vertex in _sfVs should be the center of the top
+-- for RoundedFaces, 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