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

2023-03-16 15:34:32 +00:00
parent 249262b2b6
commit 24c1264f96
7 changed files with 190 additions and 24 deletions
@@ -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)
-memoTopPrismEdgeIndices = V.generate 10
-    $ UV.fromList . topPrismEdgeIndices . (+ 2)
+triangulate :: [Int] -> [Int]
+triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is)
+    
+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