Working element buffer object

src/Shape.hs

@@ -20,12 +20,11 @@ import Geometry.ConvexPoly
 import Shape.Data
 import Color
 
---import qualified Data.Vector.Fusion.Stream.Monadic as VS
---import qualified Data.DList as DL
+import Data.Bifunctor
 
 emptySH :: Shape
 {-# INLINE emptySH #-}
-emptySH = Shape mempty mempty
+emptySH = mempty
 
 flatCirc :: Float -> Shape
 {-# INLINE flatCirc #-}
@@ -40,16 +39,16 @@ upperPrismPoly
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPoly #-}
-upperPrismPoly h ps = Shape
-    { _shVertices = topFace <> sideFaces
-    , _shEdges = topEdges <> bottomEdges <> sideEdges
-    }
+upperPrismPoly h ps =
+    ( topFace <> sideFaces
+    , topEdges <> bottomEdges <> sideEdges
+    )
   where
     topFace = shVfromList $ polyToTris $ map f' ps
-    f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black }
+    f' (V2 x y) = pairToSV (V3 x y h, black)
     sideFaces = shVfromList $ map addCol $ concat 
         $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
-    addCol x = ShapeV {_svPos = x, _svCol = black}
+    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]
@@ -64,18 +63,18 @@ prismPoly
     -> [Point2] 
     -> Shape
 {-# INLINE prismPoly #-}
-prismPoly h ps = Shape
-    { _shVertices = topFace <> bottomFace <> sideFaces
-    , _shEdges = topEdges <> bottomEdges <> sideEdges
-    }
+prismPoly h ps =
+    ( topFace <> bottomFace <> sideFaces
+    , topEdges <> bottomEdges <> sideEdges
+    )
   where
     topFace = shVfromList $ polyToTris $ map f' ps
-    f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black }
-    f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
+    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 = ShapeV {_svPos = x, _svCol = black}
+    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]
@@ -86,12 +85,12 @@ prismPoly h ps = Shape
     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]
 
 flatPoly :: [Point2] -> Shape
-flatPoly ps = Shape
-    { _shVertices = shVfromList $ polyToTris $ map f ps
-    , _shEdges = shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps])
-    }
+flatPoly ps =
+    ( shVfromList $ polyToTris $ map f ps
+    , shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps])
+    )
   where
-    f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
+    f (V2 x y) = pairToSV ( V3 x y 0,  black )
     g (V2 x y) (V2 a b) =
         [ V3 x y   0
         , V3 a b   0
@@ -100,8 +99,6 @@ flatPoly ps = Shape
         ]
       where
         n = addZ 0 $ vNormal (V2 (a-x) (b-y))
---  where
-    --n = 
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
@@ -109,17 +106,11 @@ colorSH col = overCol $ const col
 
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overCol #-}
-overCol f Shape{_shVertices=vs,_shEdges=es} = Shape 
-    {_shVertices = fmap (overColVertex f) vs
-    ,_shEdges    = es
-    }
+overCol f = first (fmap $ overColVertex f)
 
 overPos :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPos #-}
-overPos f Shape{_shVertices=vs,_shEdges=es} = Shape 
-    {_shVertices = fmap (overPosVertex f) vs
-    ,_shEdges    = fmap f es
-    }
+overPos f = bimap (fmap $ overPosVertex f) (fmap f)
 
 translateSH :: Point3 -> Shape -> Shape
 {-# INLINE translateSH #-}
@@ -143,14 +134,8 @@ scaleSH !(V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
 
 overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
 {-# INLINE overColVertex #-}
-overColVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
-    {_svPos = pos
-    ,_svCol = f col
-    }
+overColVertex f (ShapeV a b) = ShapeV a (f b)
 
 overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
 {-# INLINE overPosVertex #-}
-overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
-    {_svPos = f pos
-    ,_svCol = col
-    }
+overPosVertex f (ShapeV a b) = ShapeV (f a) b