Performance tweaks

src/Shape.hs

@@ -4,6 +4,7 @@ module Shape
     , translateSH
     , emptySH
     , polyCirc
+    , upperPrismPoly
     , prismPoly
     , flatCirc
     , translateSHz
@@ -19,9 +20,12 @@ import Geometry.ConvexPoly
 import Shape.Data
 import Color
 
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
+--import qualified Data.DList as DL
+
 emptySH :: Shape
 {-# INLINE emptySH #-}
-emptySH = Shape [] []
+emptySH = Shape mempty mempty
 
 flatCirc :: Float -> Shape
 {-# INLINE flatCirc #-}
@@ -31,36 +35,60 @@ polyCirc :: Int -> Float -> [Point2]
 {-# INLINE polyCirc #-}
 polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/(fromIntegral n)..]
 
+upperPrismPoly 
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE upperPrismPoly #-}
+upperPrismPoly h ps = Shape
+    { _shVertices = topFace <> sideFaces
+    , _shEdges = topEdges <> bottomEdges <> sideEdges
+    }
+  where
+    topFace = shVfromList $ polyToTris $ map f' ps
+    f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = 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}
+    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 = Shape
-    { _shVertices = topFace ++ bottomFace ++ sideFaces
-    , _shEdges = topEdges ++ bottomEdges ++ sideEdges
+    { _shVertices = topFace <> bottomFace <> sideFaces
+    , _shEdges = topEdges <> bottomEdges <> sideEdges
     }
   where
-    topFace = polyToTris $ map f' ps
+    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 }
-    bottomFace = polyToTris $ map f $ reverse ps
-    sideFaces = map addCol $ concat 
+    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}
     extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
-    topEdges = concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
+    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 = concat $ zipWith makeBottomEdge ps (tail ps ++ [head 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 = concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
+    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]
 
 flatPoly :: [Point2] -> Shape
 flatPoly ps = Shape
-    { _shVertices = polyToTris $ map f ps
-    , _shEdges = concat $ zipWith g ps (tail ps ++ [head ps])
+    { _shVertices = shVfromList $ polyToTris $ map f ps
+    , _shEdges = shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps])
     }
   where
     f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
@@ -82,15 +110,15 @@ colorSH col = overCol $ const col
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overCol #-}
 overCol f Shape{_shVertices=vs,_shEdges=es} = Shape 
-    {_shVertices = map (overColVertex f) vs
+    {_shVertices = fmap (overColVertex f) vs
     ,_shEdges    = es
     }
 
 overPos :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPos #-}
 overPos f Shape{_shVertices=vs,_shEdges=es} = Shape 
-    {_shVertices = map (overPosVertex f) vs
-    ,_shEdges    = map f es
+    {_shVertices = fmap (overPosVertex f) vs
+    ,_shEdges    = fmap f es
     }
 
 translateSH :: Point3 -> Shape -> Shape
@@ -99,11 +127,11 @@ translateSH !p = overPos (+.+.+ p)
 
 translateSHf :: Float -> Float -> Shape -> Shape
 {-# INLINE translateSHf #-}
-translateSHf x y = translateSH (V3 x y 0)
+translateSHf !x !y = translateSH (V3 x y 0)
 
 translateSHz :: Float -> Shape -> Shape
 {-# INLINE translateSHz #-}
-translateSHz z = translateSH (V3 0 0 z)
+translateSHz !z = translateSH (V3 0 0 z)
 
 rotateSH :: Float -> Shape -> Shape
 {-# INLINE rotateSH #-}