Implement shading for more types of shapes (cylinders, boxes)

src/Dodge/Creature/Picture.hs

@@ -9,6 +9,7 @@ module Dodge.Creature.Picture (
     deadFeet,
 ) where
 
+import Shape
 import Control.Lens
 import Dodge.Creature.HandPos (translateToLeftHand, translateToRightHand)
 import Dodge.Creature.Test
@@ -18,25 +19,29 @@ import Dodge.Item.Draw
 import Geometry
 import Picture
 import qualified Quaternion as Q
-import Shape
+--import Shape
 import ShapePicture
 
 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
+
 basicCrShape ::
     Creature ->
     Shape
 basicCrShape cr
     | _crCamouflage cr == Invisible = mempty
-    | otherwise =
+    | otherwise = colorSH white $ tr $ rotdir testShape
-        tr . scaleSH (V3 crsize crsize crsize) $
+--    | otherwise =
-            mconcat
+--        tr . scaleSH (V3 crsize crsize crsize) $
-                [ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
+--            mconcat
-                , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
+--                [ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
-                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+--                , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
-                ]
+--                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+--                ]
   where
     cskin = _crType cr
     crsize = 0.1 * _crRad cr

src/Dodge/Render.hs

@@ -141,11 +141,14 @@ doDrawing' win pdata u = do
     let fs = _shapeShader pdata
     glUseProgram (_shadName fs)
     glBindVertexArray $ fs ^. shadVAO . vaoName
+--    glEnable GL_CULL_FACE
+--    glCullFace GL_BACK
     glDrawElements
         (marshalEPrimitiveMode $ _shadPrim' fs)
         (fromIntegral nIndices)
         GL_UNSIGNED_SHORT
         nullPtr
+--    glDisable GL_CULL_FACE
     --draw floor onto base buffer
     drawShader (fst $ _textureArrayShader pdata) nFls
     --draw lightmap into its own buffer

src/Dodge/Room/Foreground.hs

@@ -141,8 +141,6 @@ putShape sh =
     bnds = shapeBounds sh
     m = midBounds bnds
 
---shapePoints :: Shape -> Stream (Of Point2) Identity ()
---shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
 shapePoints :: Shape -> [Point2]
 shapePoints = concatMap (map stripZ . _sfVs)
 

src/Preload/Render.hs

@@ -141,7 +141,7 @@ preloadRender = do
     positionalBlankShad <- makeShader "positional/blank" [vert, frag] [3] ETriangles
     -- 2D draw shaders
     bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] ETriangles
-    bslista <- makeShader4 "shape/basic" [vert, frag] [4, 4, 4] nShapeVerxComp ETriangles shVBO
+    bslista <- makeShader4 "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp ETriangles shVBO
     glVertexArrayElementBuffer (bslista ^. shadVAO . vaoName) shEBOname
     aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] ETriangles
     eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] ETriangles

src/Shader/Poke.hs

@@ -6,6 +6,7 @@ module Shader.Poke
     , pokeWallsWindowsFloor
     , memoTopPrismEdgeIndices
     ) where
+import Linear.V3 (cross)
 import Geometry.Polygon
 import Shader.Data
 import Shader.Parameters
@@ -98,11 +99,77 @@ pokeShapeObj
     -> IO (Int,Int,Int)
 {-# INLINE pokeShapeObj #-}
 pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
-    TopPrism size -> pokeTopPrism midp col (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
+    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)
   where
     midp = centroidNum shVerts
 
+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
+        $ memoTopPrismEdgeIndices V.! (size - 3)
+    return (nv',nsi',nei')
+pokeCylinder _ _ _ _ _ _ _ = undefined
+
+pokeCylinderCurve col size 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
+
+pokeBox :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort
+    -> (Int,Int,Int)
+    -> [Point3]
+    -> IO (Int,Int,Int)
+{-# 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 
+        (memoFlatIndices V.! (size -3))
+    nei' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nei
+        $ memoBoxEdgeIndices V.! (size - 3)
+    return (nv', nshapeindices', nei')
+
+-- should probably use a vector of Point3
+pokeBoxSurface :: Point4 -> Ptr Float -> [Point3] -> Int -> [Int] -> IO Int
+pokeBoxSurface col ptr vs n is = foldM 
+    (pokeFlatV norm col ptr)
+    n
+    v
+  where
+    v = (V.backpermute (V.fromList vs) (V.fromList is))
+    x = v V.! 0
+    y = v V.! 1
+    z = v V.! 2
+    norm = negate $ cross (x-y) (z-y)
+
+boxSurfaces :: Int -> [[Int]]
+boxSurfaces size = [0,2 .. size * 2 -1]
+    : [1,3 .. size * 2]
+    : map f [0,2 .. size * 2 - 1]
+  where
+    f x = map (`mod` (size *2)) [x, x+1, x+3, x+2]
+
+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 
     -> (Int,Int,Int)
@@ -112,9 +179,9 @@ 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)
+        (memoTopPrismIndices     V.! (size - 2))
     nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
-        (memoTopPrismEdgeIndices V.! size)
+        (memoTopPrismEdgeIndices V.! (size - 3))
     return (nv', nshapeindices', nedgeindices')
 
 pokeTopPrismEdgeIndex :: Int -> Ptr GLushort 
@@ -130,20 +197,40 @@ pokeTopPrismIndex :: Int -> Ptr GLushort
     -> Int
     -> Int 
     -> IO Int
---{-# INLINE pokeTopPrismIndex #-}
+{-# INLINE pokeTopPrismIndex #-}
 pokeTopPrismIndex nv iptr nshapeindices ioff = do
     pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
     return $ nshapeindices + 1
 
-memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
+triangulate :: [Int] -> [Int]
-memoTopPrismEdgeIndices = V.generate 10
+triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is)
-    $ UV.fromList . topPrismEdgeIndices . (+ 2)
+    
+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)]
+
+memoFlatIndices :: V.Vector (UV.Vector Int)
+memoFlatIndices = V.generate 10
+    $ UV.fromList . concatMap triangulate  . boxSurfaces' . (+3)
 
 memoTopPrismIndices :: V.Vector (UV.Vector Int)
 memoTopPrismIndices = V.generate 10 
     $ UV.fromList . topPrismIndices . (+ 2)
 
-topPrismEdgeIndices :: Int -> [Int]
+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
+    $ UV.fromList . topPrismEdgeIndices . (+3)
+
+topPrismEdgeIndices 
+    :: Int  -- ^ the number of vertices on the top surface, ie. half the total
+    -> [Int]
 topPrismEdgeIndices n = concatMap f [0..n-1]
   where
     f i = map g
@@ -154,6 +241,23 @@ topPrismEdgeIndices n = concatMap f [0..n-1]
       where
         g j = (2 * i + j) `mod` (2*n)
 
+memoBoxEdgeIndices :: V.Vector (UV.Vector Int)
+memoBoxEdgeIndices = V.generate 10
+    $ UV.fromList . boxEdgeIndices . (+3)
+
+boxEdgeIndices 
+    :: Int  -- ^ the number of vertices on the top surface, ie. half the total
+    -> [Int]
+boxEdgeIndices n = concatMap f [0..n-1]
+  where
+    f i = map g
+        [ 0 , 1 , n , 2
+        , 0 , n ,-1 , n+1
+        , n , n+1 ,n-1 , 1
+        ]
+      where
+        g j = (i + j) `mod` (2*n)
+
 topPrismIndices :: Int -> [Int]
 topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
     ++  concatMap f' [1..n-2]   -- triangles on bottom face
@@ -167,6 +271,16 @@ 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)
@@ -186,6 +300,22 @@ pokeJustV cp col ptr nv sh = do
     V4 r g b a  = col
     V3 nx ny nz = cp
 
+pokeFlatV :: Point3
+    -> Point4
+    -> Ptr Float
+    -> Int
+    -> Point3 
+    -> IO Int
+{-# INLINE pokeFlatV #-}
+pokeFlatV norm 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 = sh - norm
+
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) (FullShader ,VBO)
     -> UMV.MVector (PrimState IO) Int

src/Shape.hs

@@ -7,6 +7,7 @@ module Shape
     , upperPrismPolyHalf
     , prismPoly
     , polyCirc
+    , upperBox
     , translateSHz
     , translateSHf
     , rotateSH
@@ -17,6 +18,7 @@ module Shape
     , overColSH
 --    , overColSHM
     , overPosSH
+    , upperCylinder
     ) where
 import Geometry
 import Shape.Data
@@ -71,6 +73,31 @@ upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black)
     f (x:xs) = g h x : g 0 x : f xs
     f _ = []
 
+upperBox 
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE upperBox #-}
+upperBox h ps = singleShape (Surface (TopBox n) (f ps) white)
+  where
+    n = length ps
+    g h' (V2 x y) = V3 x y h'
+    f (x:xs) = g h x : g 0 x : f xs
+    f _ = []
+
+upperCylinder 
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE upperCylinder #-}
+upperCylinder h ps = singleShape (Surface (TopCylinder n) (addZ h cc:addZ 0 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 _ = []
+
 upperPrismPolyHalf
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 

src/Shape/Data.hs

@@ -19,11 +19,11 @@ shVfromList = id
 {-# INLINE shEfromList #-}
 shEfromList = id
 data ShapeType = TopPrism { _prismSize :: Int }
---    | Surface { _surfaceSize :: Int}
+    | TopBox { _topBoxSize :: Int }
+    | TopCylinder { _topCylinderSize :: Int }
     deriving (Eq, Ord, Show, Read)
-    --deriving stock Generic
+-- for TopCylinder, the first vertex in _sfVs should be the center of the top
-    --deriving anyclass Flat
+-- plane, the second should be the center of the bottom plane.
-
 
 data Surface = Surface
     { _sfType :: ShapeType
@@ -38,7 +38,10 @@ makeLenses ''ShapeType
 type Shape = [Surface]
 
 nShapeVerxComp :: Int
-nShapeVerxComp = 12
+nShapeVerxComp = sum shapeVerxSizes
+
+shapeVerxSizes :: [Int]
+shapeVerxSizes = [4,4,4]
 
 deriveJSON defaultOptions ''ShapeType
 deriveJSON defaultOptions ''Surface