Refactor, move towards adding cylinders

src/Dodge/Creature/Picture.hs

@@ -26,22 +26,22 @@ basicCrPict :: Creature -> SPic
 basicCrPict cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) 
     <> (basicCrShape cr, mempty)
 
-testShape :: Shape
+--testShape :: Shape
-testShape = translateSHz 10 . rotateSHx 1 . upperBox 20 $ polyCirc 2 10
+--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 = colorSH white $ tr $ rotdir testShape
---    | otherwise =
+    | otherwise =
---        tr . scaleSH (V3 crsize crsize crsize) $
+        tr . scaleSH (V3 crsize crsize crsize) $
---            mconcat
+            mconcat
---                [ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
+                [ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
---                , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
+                , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
---                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
---                ]
+                ]
   where
     cskin = _crType cr
     crsize = 0.1 * _crRad cr

src/Shader/Poke.hs

@@ -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
+    FlatFaces size -> pokeBox col size ptr iptr ieptr counts shVerts
-    TopCylinder size -> pokeCylinder col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces col size ptr iptr ieptr counts shVerts
---    TopCylinder size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList 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' <- pokeRoundedCurve col ptr tc bc svs nv >>= pokeCylinderCaps col ptr tc bc svs
-    --nv' <- VFSM.foldlM' (pokeJustV tc col ptr) nv $ VFSM.fromList svs
+    nsi' <- UV.foldM' (pokeIndex nv iptr) nshapeindices 
-    nsi' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices 
+        --(memoTopPrismIndices     V.! (size - 2))
-        --(memoCylinderIndices     V.! (size - 2))
+        (memoTopPrismIndices     V.! (size - 3))
-        (memoTopPrismIndices     V.! (size - 2))
+    nei' <- UV.foldM' (pokeIndex nv ieptr) nei
-    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
+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))
+        --(memoTopPrismIndices     V.! (size - 2))
-    nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
+        (memoTopPrismIndices     V.! (size - 3))
+    nedgeindices' <- UV.foldM' (pokeIndex nv ieptr) nedgeindices
         (memoTopPrismEdgeIndices V.! (size - 3))
     return (nv', nshapeindices', nedgeindices')
 
-pokeTopPrismEdgeIndex :: Int -> Ptr GLushort 
+pokeIndex
-    -> Int
+    :: Int -- ^ base index
-    -> Int 
+    -> Ptr GLushort 
+    -> Int -- ^ number poked
+    -> Int -- ^ index offset
     -> IO Int
---{-# INLINE pokeTopPrismEdgeIndex #-}
+{-# INLINE pokeIndex #-}
-pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do
+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)
+    $ UV.fromList . topPrismIndices . (+ 3)
-
-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
@@ -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

src/Shape.hs

@@ -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

src/Shape/Data.hs

@@ -13,16 +13,13 @@ import Data.Aeson
 import Data.Aeson.TH
 import Geometry.Data
 
-{-# INLINE shVfromList #-}
+data ShapeType 
-shVfromList = id
+    = TopPrism { _prismSize :: Int }
-
+    | FlatFaces { _topBoxSize :: Int }
-{-# INLINE shEfromList #-}
+    | RoundedFaces { _shapeHalfSize :: Int }
-shEfromList = id
+    | Cylinder { _cylinderSize :: Int }
-data ShapeType = TopPrism { _prismSize :: Int }
-    | TopBox { _topBoxSize :: Int }
-    | TopCylinder { _topCylinderSize :: 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