Refactor shapes, prepare for different normals at single vertex pos

shader/lighting/texture.frag

@@ -13,7 +13,6 @@ void main() {
   vec3 norm = normbit.xyz - pos;
   float y1 = float(normbit.w == 0 ? 1 : dot(normalize(norm), normalize(distVec)));
   float y = float(y1 > 0 ? 1 : 0);
-//  float y = float(normbit.w == 1 ? 1 : 0);
   float dist = dot(distVec, distVec);
   if (dist > rad) {
     discard;

src/Dodge/Render/Shadow.hs

@@ -3,19 +3,19 @@ module Dodge.Render.Shadow where
 --import Data.Vector.Unboxed as UV
 
 --import Dodge.Data.Universe
-import Control.Lens
+--import Control.Lens
 import Data.Preload.Render
-import qualified Data.Vector as V
+--import qualified Data.Vector as V
 --import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
-import Foreign
+--import Foreign
 import Geometry
 --import Graphics.GL.Core45
-import Linear.V3 (cross)
+--import Linear.V3 (cross)
 --import Shader.Data
 --import Shader.ExtraPrimitive
 --import Shader.Parameters
 import Shape.Data
-
+--
 drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO ()
 drawCPUShadows _ _ _ _ = return ()
 --drawCPUShadows pdata s pos rad = do
@@ -35,71 +35,71 @@ drawCPUShadows _ _ _ _ = return ()
 --        (fromIntegral i)
 --    return ()
 
-pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int
+--pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int
-pokeShapeShad pos r theptr i so = do
+--pokeShapeShad pos r theptr i so = do
-    let vs = V.fromList $ map _svPos (_shVs so)
+--    let vs = V.fromList $ map _svPos (_shVs so)
-        is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2)
+--        is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2)
-    V.foldM' (pokeShadEdge pos r theptr vs) i is
+--    V.foldM' (pokeShadEdge pos r theptr vs) i is
 
-pokeShadEdge ::
+--pokeShadEdge ::
-    Point3 ->
+--    Point3 ->
-    Float ->
+--    Float ->
-    Ptr Float ->
+--    Ptr Float ->
-    V.Vector Point3 ->
+--    V.Vector Point3 ->
-    Int ->
+--    Int ->
-    (Int, Int, Int, Int) ->
+--    (Int, Int, Int, Int) ->
-    IO Int
+--    IO Int
-pokeShadEdge pos _ ptr vxs i (a, b, x, y) = do
+--pokeShadEdge pos _ ptr vxs i (a, b, x, y) = do
-    let p0 = vxs V.! a
+--    let p0 = vxs V.! a
-        p1 = vxs V.! b
+--        p1 = vxs V.! b
-        --mid = 0.5 * (p0 + p1)
+--        --mid = 0.5 * (p0 + p1)
-        n0a = vxs V.! x
+--        n0a = vxs V.! x
-        n1a = vxs V.! y -- this should almost certainly be done with backpermute
+--        n1a = vxs V.! y -- this should almost certainly be done with backpermute
-        n0 = cross (p1 - p0) (n0a - p0)
+--        n0 = cross (p1 - p0) (n0a - p0)
-        n1 = cross (p0 - p1) (n1a - p1)
+--        n1 = cross (p0 - p1) (n1a - p1)
-        lightdir = p0 - pos
+--        lightdir = p0 - pos
-        shift' p = p + (10000 *.*.* (p - pos))
+--        shift' p = p + (10000 *.*.* (p - pos))
-    --        projNear p =
+--    --        projNear p =
-    --        shiftNear p =
+--    --        shiftNear p =
-    if dotV3 n0 lightdir * dotV3 n1 lightdir <= 0
+--    if dotV3 n0 lightdir * dotV3 n1 lightdir <= 0
-        then do
+--        then do
-            let p2 = shift' p0
+--            let p2 = shift' p0
-                p3 = shift' p1
+--                p3 = shift' p1
-            if dotV3 n0 lightdir > 0
+--            if dotV3 n0 lightdir > 0
-                then
+--                then
-                    pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2
+--                    pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2
-                        >>= pokeV3 ptr p0
+--                        >>= pokeV3 ptr p0
-                        >>= pokeV3 ptr p2
+--                        >>= pokeV3 ptr p2
-                        >>= pokeV3 ptr p3
+--                        >>= pokeV3 ptr p3
-                else
+--                else
-                    pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3
+--                    pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3
-                        >>= pokeV3 ptr p1
+--                        >>= pokeV3 ptr p1
-                        >>= pokeV3 ptr p3
+--                        >>= pokeV3 ptr p3
-                        >>= pokeV3 ptr p2
+--                        >>= pokeV3 ptr p2
-        else return i
+--        else return i
-
+--
-pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int
+--pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int
-pokeV3 ptr (V3 x y z) i = do
+--pokeV3 ptr (V3 x y z) i = do
-    pokeElemOff ptr (3 * i) x
+--    pokeElemOff ptr (3 * i) x
-    pokeElemOff ptr (3 * i + 1) y
+--    pokeElemOff ptr (3 * i + 1) y
-    pokeElemOff ptr (3 * i + 2) z
+--    pokeElemOff ptr (3 * i + 2) z
-    return (i + 1)
+--    return (i + 1)
-
+--
-memoTopPrismEdges :: V.Vector (V.Vector (Int, Int, Int, Int))
+--memoTopPrismEdges :: V.Vector (V.Vector (Int, Int, Int, Int))
-memoTopPrismEdges =
+--memoTopPrismEdges =
-    V.generate 10 $
+--    V.generate 10 $
-        V.fromList . topPrismEdges . (+ 2)
+--        V.fromList . topPrismEdges . (+ 2)
-
+--
-topPrismEdges :: Int -> [(Int, Int, Int, Int)]
+--topPrismEdges :: Int -> [(Int, Int, Int, Int)]
-topPrismEdges n = concatMap f [0 .. n -1]
+--topPrismEdges n = concatMap f [0 .. n -1]
-  where
+--  where
-    f i =
+--    f i =
-        map
+--        map
-            h
+--            h
-            [ (0, 2, 1, 4)
+--            [ (0, 2, 1, 4)
-            , (0, 1, -2, 3)
+--            , (0, 1, -2, 3)
-            , (1, 3, -1, 2)
+--            , (1, 3, -1, 2)
-            ]
+--            ]
-      where
+--      where
-        h (a, b, c, d) = (g a, g b, g c, g d)
+--        h (a, b, c, d) = (g a, g b, g c, g d)
-        g j = (2 * i + j) `mod` (2 * n)
+--        g j = (2 * i + j) `mod` (2 * n)

src/Dodge/Room/Foreground.hs

@@ -144,7 +144,7 @@ putShape sh =
 --shapePoints :: Shape -> Stream (Of Point2) Identity ()
 --shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
 shapePoints :: Shape -> [Point2]
-shapePoints = concatMap (map (stripZ . _svPos) . _shVs)
+shapePoints = concatMap (map stripZ . _sfVs)
 
 shapeBounds :: Shape -> (Float, Float, Float, Float)
 shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints

src/Shader/Poke.hs

@@ -85,7 +85,7 @@ pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
 
 pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort 
     -> (Int,Int,Int)
-    -> [ShapeObj]
+    -> [Surface]
     -> IO (Int,Int,Int)
 pokeShape ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj ptr iptr ieptr) is . VFSM.fromList
 
@@ -94,22 +94,23 @@ pokeShapeObj
     -> Ptr GLushort 
     -> Ptr GLushort 
     -> (Int,Int,Int)
-    -> ShapeObj
+    -> Surface
     -> IO (Int,Int,Int)
 {-# INLINE pokeShapeObj #-}
-pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of
+pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
-    TopPrism size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
+    TopPrism size -> pokeTopPrism midp col (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
+--    TopCylinder size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
   where
-    midp = centroidNum $ map _svPos shVerts
+    midp = centroidNum shVerts
 
-pokeTopPrism :: Point3 -> Int -> Ptr Float -> Ptr GLushort 
+pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort 
     -> (Int,Int,Int)
-    -> VFSM.Stream IO ShapeV
+    -> VFSM.Stream IO Point3
     -> IO (Int,Int,Int)
 {-# INLINE pokeTopPrism #-}
-pokeTopPrism cp size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
+pokeTopPrism cp col size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
-    nv' <- VFSM.foldlM' (pokeJustV cp ptr) nv svs
+    nv' <- VFSM.foldlM' (pokeJustV cp col ptr) nv svs
     nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices 
         (memoTopPrismIndices     V.! size)
     nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
@@ -170,22 +171,20 @@ topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
 -- and just doing two pokes rather than seven
 -- (especially if adding normal data)
 pokeJustV :: Point3
+    -> Point4
     -> Ptr Float
     -> Int
-    -> ShapeV 
+    -> Point3 
     -> IO Int
 {-# INLINE pokeJustV #-}
-pokeJustV cp ptr nv sh = do
+pokeJustV 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    = _svPos sh
+    V3 x y z    = sh
-    V4 r g b a  = _svCol sh
+    V4 r g b a  = col
     V3 nx ny nz = cp
-    --nx = x
-    --ny = y
-    --nz = z - 1
 
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) (FullShader ,VBO)

src/Shape.hs

@@ -22,11 +22,11 @@ import Geometry
 import Shape.Data
 import Color
 
-singleShape :: ShapeObj -> Shape
+singleShape :: Surface -> Shape
 {-# INLINE singleShape #-}
 singleShape = (:[])
 
-shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
+shMap :: (Surface -> Surface) -> Shape -> Shape
 {-# INLINE shMap #-}
 shMap = map
 
@@ -52,23 +52,22 @@ prismPoly
     -> [Point3] 
     -> Shape
 {-# INLINE prismPoly #-}
-prismPoly upps downps = singleShape (ShapeObj (TopPrism n) (f upps downps))
+prismPoly upps downps = singleShape (Surface (TopPrism n) (f upps downps) black)
   where
     n = length upps
-    f (a:as) (b:bs) = g a:g b:f as bs
+    f (a:as) (b:bs) = a:b:f as bs
     f [] _ = []
     f _ [] = []
-    g p = ShapeV p black
 
 upperPrismPoly 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPoly #-}
-upperPrismPoly h ps = singleShape (ShapeObj (TopPrism n) (f ps))
+upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black)
   where
     n = length ps
-    g h' (V2 x y) = pairToSV (V3 x y h', black)
+    g h' (V2 x y) = V3 x y h'
     f (x:xs) = g h x : g 0 x : f xs
     f _ = []
 
@@ -77,15 +76,15 @@ upperPrismPolyHalf
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPolyHalf #-}
-upperPrismPolyHalf h ps = singleShape (ShapeObj (TopPrism n) (f upps downps))
+upperPrismPolyHalf h ps = singleShape (Surface (TopPrism n) (f upps downps) black)
   where
     n = length ps
     upps = map f' ps
     downps = map f'' ps
     f (a:as) (b:bs) = a:b:f as bs
     f _ _ = []
-    f' (V2 x y) = pairToSV (V3 (0.5 * x) (0.5 * y) h, black)
+    f' (V2 x y) = (V3 (0.5 * x) (0.5 * y) h)
-    f'' (V2 x y) = pairToSV (V3 x y 0, black)
+    f'' (V2 x y) = (V3 x y 0)
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
@@ -123,22 +122,14 @@ scaleSH :: Point3 -> Shape -> Shape
 {-# INLINE scaleSH #-}
 scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
 
-overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
+overColObj :: (Point4 -> Point4) -> Surface -> Surface
 {-# INLINE overColObj #-}
-overColObj f (ShapeObj st vs) = ShapeObj st (fmap (overColVertex f) vs)
+overColObj f (Surface st vs col) = Surface st vs (f col)
 
 --overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
 --{-# INLINE overColObjM #-}
 --overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs
 
-overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
+overPosObj :: (Point3 -> Point3) -> Surface -> Surface
-{-# INLINE overColVertex #-}
-overColVertex f (ShapeV a b) = ShapeV a (f b)
-
-overPosObj :: (Point3 -> Point3) -> ShapeObj -> ShapeObj
 {-# INLINE overPosObj #-}
-overPosObj f (ShapeObj st vs) = ShapeObj st $ fmap (overPosVertex f) vs
+overPosObj f (Surface st vs col) = Surface st (map f vs) col
-
-overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
-{-# INLINE overPosVertex #-}
-overPosVertex f (ShapeV a b) = ShapeV (f a) b

src/Shape/Data.hs

@@ -18,38 +18,27 @@ shVfromList = id
 
 {-# INLINE shEfromList #-}
 shEfromList = id
-newtype ShapeType = TopPrism { _prismSize :: Int }
+data ShapeType = TopPrism { _prismSize :: Int }
-    deriving newtype (Eq, Ord, Show, Read)
+--    | Surface { _surfaceSize :: Int}
+    deriving (Eq, Ord, Show, Read)
     --deriving stock Generic
     --deriving anyclass Flat
 
 
-data ShapeObj = ShapeObj
+data Surface = Surface
-    { _shType :: ShapeType
+    { _sfType :: ShapeType
-    , _shVs :: [ShapeV]
+    , _sfVs :: [Point3]
+    , _sfColor :: Point4
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
--- edges are given by four consecutive points
+makeLenses ''Surface
-data ShapeV = ShapeV
-    { _svPos :: Point3
-    , _svCol :: Point4
-    }
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
-pairToSV :: (Point3, Point4) -> ShapeV
-{-# INLINE pairToSV #-}
-pairToSV = uncurry ShapeV
-
-makeLenses ''ShapeV
-makeLenses ''ShapeObj
 makeLenses ''ShapeType
 
-type Shape = [ShapeObj]
+type Shape = [Surface]
 
 nShapeVerxComp :: Int
 nShapeVerxComp = 12
 
 deriveJSON defaultOptions ''ShapeType
-deriveJSON defaultOptions ''ShapeV
+deriveJSON defaultOptions ''Surface
-deriveJSON defaultOptions ''ShapeObj

src/ShapePicture.hs

@@ -21,7 +21,7 @@ import Geometry
 import Data.Bifunctor
 import Control.Lens
 
-shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
+shMap :: (Surface -> Surface) -> Shape -> Shape
 shMap = map
 
 -- should all this be inlined/inlinable?
@@ -63,12 +63,12 @@ rotateSP a = bimap (rotateSH a) (rotate a)
 
 mirrorSPxz :: SPic -> SPic
 {-# INLINE mirrorSPxz #-}
-mirrorSPxz = bimap (shMap (over shVs reverse) . overPosSH flipy) mirrorxz
+mirrorSPxz = bimap (shMap (over sfVs reverse) . overPosSH flipy) mirrorxz
   where
     flipy (V3 x y z) = V3 x (negate y) z
 
 mirrorSPyz :: SPic -> SPic
 {-# INLINE mirrorSPyz #-}
-mirrorSPyz = bimap (shMap (over shVs reverse) . overPosSH flipx) mirroryz
+mirrorSPyz = bimap (shMap (over sfVs reverse) . overPosSH flipx) mirroryz
   where
     flipx (V3 x y z) = V3 (negate x) y z