Broken commit, just to restore deleted function

src/Dodge/Creature/Picture.hs

@@ -174,22 +174,9 @@ scalp cr
     | oneH   cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
     | otherwise = translateSHf (0.25 * crad) 0 fhead
   where
-    --fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
+    fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
-    fhead = ([ShapeObj TopHexahedron $ map (flip ShapeV (greyN 0.9)) aBox] , mempty)
     crad = _crRad cr
 
-aBox :: [Point3]
-aBox =
-    [ V3 0 0 5
-    , V3 5 0 5
-    , V3 5 5 5
-    , V3 0 5 5
-    , V3 0 0 0
-    , V3 5 0 0
-    , V3 5 5 0
-    , V3 0 5 0
-    ]
-
 oneH :: Creature -> Bool
 oneH cr = crIsAiming' cr && crIt ^? itAimStance == Just OneHand
   where

src/Dodge/Default.hs

@@ -36,7 +36,7 @@ defaultCreature = Creature
     , _crOldDir = 0
     , _crMvDir  = 0
     , _crID     = 1
-    , _crPict   = \_ _ -> (,) (flatCirc 10) blank
+    , _crPict   = \_ _ -> (,) (mempty) blank
     , _crUpdate = \cr _ -> (Endo id , Just cr)
     , _crRad    = 10
     , _crMass   = 10

src/Dodge/Render.hs

@@ -81,7 +81,7 @@ doDrawing pdata w = do
         ElementArrayBuffer
         WriteToBuffer
         0
-        (fromIntegral $ glushortSize * nIndices)
+        (fromIntegral $ glushortSize * nSilIndices)
         (_eboPtr $ _silhouetteEBO pdata)
     -- set the coordinate uniform ready for drawing elements using world coordinates
     bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
@@ -120,7 +120,7 @@ doDrawing pdata w = do
     drawShader (_textureArrayShader pdata) nTextArrayVs
     --draw lightmap for base buffer
     bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
-    createLightMap pdata lightPoints nWalls nSils numShapeVs (snd $ snd $ _fboBase pdata)
+    createLightMap pdata lightPoints nWalls nSilIndices numShapeVs (snd $ snd $ _fboBase pdata)
     --createLightMap pdata lightPoints nWalls 0 0 (snd $ snd $ _fboBase pdata)
     colorMask $= Color4 Enabled Enabled Enabled Enabled
     clearColor $= Color4 0 0 0 0
@@ -175,7 +175,7 @@ doDrawing pdata w = do
         depthMask $= Disabled
         blend $= Enabled
         bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
-        createLightMap pdata lightPoints nWalls nSils numShapeVs (snd $ snd $ _fboCloud pdata)
+        createLightMap pdata lightPoints nWalls nSilIndices numShapeVs (snd $ snd $ _fboCloud pdata)
         colorMask $= Color4 Enabled Enabled Enabled Enabled
         clearColor $= Color4 0 0 0 0
     --apply lightmap to cloud buffer

src/Shader/Poke.hs

@@ -58,13 +58,27 @@ pokeShapeObjs
     :: Ptr Float 
     -> Ptr GLushort 
     -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeObj] -> IO (Int, Int,Int,Int)
-pokeShapeObjs ptr iptr ieptr count = VS.foldlM' (pokeShapeObj ptr iptr) count . VS.fromList
+pokeShapeObjs ptr iptr _ count = VS.foldlM' (pokeShapeObj ptr iptr) count . VS.fromList
 
 pokeShapeObj :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeObj -> IO (Int,Int,Int,Int)
 pokeShapeObj ptr iptr counts (ShapeObj shType shVerts) = case shType of
     ListV -> pokeShapeVs ptr iptr counts shVerts
-    TopHexahedron -> pokeTopHexahedron ptr iptr counts shVerts
+    TopPrism size -> pokeTopPrism size ptr iptr counts shVerts
 
+pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int,Int)
+pokeTopPrism size ptr iptr count svs = do
+    count' <- pokeTopPrismIndices size iptr count
+    VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs)
+
+pokeTopPrismIndices :: Int -> Ptr GLushort -> (Int,Int,Int,Int) -> IO (Int,Int,Int,Int)
+pokeTopPrismIndices size iptr (nv,ne,ni,nei) = do
+    ni' <- foldM (pokeTopPrismIndex nv iptr) ni (topPrismIndices size)
+    return (nv,ne,ni',nei)
+
+pokeTopPrismIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int
+pokeTopPrismIndex nv iptr ni ioff = do
+    pokeElemOff iptr ni (fromIntegral $ nv + ioff)
+    return (ni + 1)
 
 pokeShapeVs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int, Int,Int,Int)
 pokeShapeVs ptr iptr count = VS.foldlM' (pokeShapeV ptr iptr) count . VS.fromList
@@ -78,26 +92,18 @@ pokeShapeE eptr ieptr (nv,n,ni,nei) (V3 a b c) = do
     pokeElemOff eptr (n * 3) a
     pokeElemOff eptr (n * 3 + 1) b
     pokeElemOff eptr (n * 3 + 2) c
-    pokeElemOff ieptr nei (fromIntegral nei)
+    pokeElemOff ieptr nei (fromIntegral n)
     return $ (nv,n + 1,ni,nei+1)
 
-pokeTopHexahedron :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int,Int)
+topPrismIndices :: Int -> [Int]
-pokeTopHexahedron ptr iptr count svs = do
+topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
-    count' <- pokeHexahedronIndices iptr count
+    ++ [2*n-2,2*n-1,1
-    VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs)
+        ,2*n-2,1,0]                         -- last side triangle (applies mod 2n)
-
+    ++ concatMap g [0..n-2]                 -- other triangles on sides
-pokeHexahedronIndices :: Ptr GLushort -> (Int,Int,Int,Int) -> IO (Int,Int,Int,Int)
+  where
-pokeHexahedronIndices iptr (nv,ne,ni,nei) = do
+    f x = [0,2*x,2*x+2]
-    ni' <- foldM (pokeHexhedronIndex nv iptr) ni hexIndices
+    g x = [2*x,2*x+1,2*x+3
-    return (nv,ne,ni',nei)
+            ,2*x,2*x+3,2*x+2]
-
-pokeHexhedronIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int
-pokeHexhedronIndex nv iptr ni ioff = do
-    pokeElemOff iptr ni (fromIntegral $ nv + ioff)
-    return (ni + 1)
-
-hexIndices :: [Int]
-hexIndices = [0,1,2,0,2,3,0,4,5,0,5,1,1,5,6,1,6,2,2,6,7,2,7,8,3,7,4,3,4,0]
 
 pokeJustV :: Ptr Float -> (Int,Int,Int,Int) -> ShapeV -> IO (Int,Int,Int,Int)
 pokeJustV ptr (nv,ne,ni,nei) sh = do

src/Shape.hs

@@ -3,10 +3,7 @@ module Shape
     ( module Shape.Data
     , translateSH
     , emptySH
-    , polyCirc
     , upperPrismPoly
-    , prismPoly
-    , flatCirc
     , translateSHz
     , translateSHf
     , rotateSH
@@ -26,13 +23,9 @@ emptySH :: Shape
 {-# INLINE emptySH #-}
 emptySH = mempty
 
-flatCirc :: Float -> Shape
-{-# INLINE flatCirc #-}
-flatCirc = flatPoly . polyCirc 3
-
 polyCirc :: Int -> Float -> [Point2]
-{-# INLINE polyCirc #-}
+{-# INLINE polycirc #-}
-polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/(fromIntegral n)..]
+polyCirc n r = map (\i -> rotateV ) [0..n]
 
 upperPrismPoly 
     :: Float    -- ^ height, expected to be strictly positive
@@ -40,42 +33,18 @@ upperPrismPoly
     -> Shape
 {-# INLINE upperPrismPoly #-}
 upperPrismPoly h ps =
-    ( [ShapeObj ListV (topFace <> sideFaces)]
+    ( [ShapeObj (TopPrism n) (f upps downps)]
     , topEdges <> bottomEdges <> sideEdges
     )
   where
-    topFace = shVfromList $ polyToTris $ map f' ps
+    n = length ps
+    upps = map f' ps
+    downps = map f'' ps
+    f (a:as) (b:bs) = a:b:f as bs
+    f [] _ = []
+    f _ [] = []
     f' (V2 x y) = pairToSV (V3 x y h, black)
-    sideFaces = shVfromList $ map addCol $ concat 
+    f'' (V2 x y) = pairToSV (V3 x y 0, black)
-        $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
-    addCol x = pairToSV ( x,  black)
-    extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
-    topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
-    makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
-    V2 xcen ycen = centroid ps
-    bottomEdges = shEfromList $ concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
-    makeBottomEdge (V2 x' y') (V2 x y) = [V3 x y 0,V3 x' y' 0,V3 x y h,V3 xcen ycen 0]
-    sideEdges = shEfromList $ concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
-    makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
-
-prismPoly 
-    :: Float    -- ^ height, expected to be strictly positive
-    -> [Point2] 
-    -> Shape
-{-# INLINE prismPoly #-}
-prismPoly h ps =
-    ( [ShapeObj ListV (topFace <> bottomFace <> sideFaces)]
-    , topEdges <> bottomEdges <> sideEdges
-    )
-  where
-    topFace = shVfromList $ polyToTris $ map f' ps
-    f' (V2 x y) = pairToSV ( V3 x y h, black )
-    f (V2 x y) = pairToSV ( V3 x y 0,  black )
-    bottomFace = shVfromList $ polyToTris $ map f $ reverse ps
-    sideFaces = shVfromList $ map addCol $ concat 
-        $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
-    addCol x = pairToSV ( x,  black)
-    extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
     topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
     makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
     V2 xcen ycen = centroid ps

src/Shape/Data.hs

@@ -39,9 +39,9 @@ data ShapeObj = ShapeObj
     }
 
 data ShapeType
-    = ListV
+    = TopPrism Int
-    | TopHexahedron    -- ^ assumed convex, eight vertices
+    | ListV
-    | TopPrism Int
+--    | TopHexahedron    -- ^ assumed convex, eight vertices
 
 -- edges are given by four consecutive points
 data ShapeV = ShapeV