Add cylinder shapes

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

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

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 #-}