Add cylinder shapes

src/Shape.hs

@@ -16,9 +16,9 @@ module Shape
     , scaleSH
     , colorSH
     , overColSH
---    , overColSHM
     , overPosSH
     , upperCylinder
+    , upperRounded
     ) where
 import Geometry
 import Shape.Data
@@ -90,7 +90,20 @@ upperCylinder
     -> [Point2] 
     -> Shape
 {-# INLINE upperCylinder #-}
-upperCylinder h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black)
+upperCylinder h ps = singleShape (Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 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 _ = []
+
+upperRounded 
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE upperRounded #-}
+upperRounded h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black)
   where
     cc = centroid ps
     n = length ps
@@ -110,8 +123,8 @@ upperPrismPolyHalf h ps = singleShape (Surface (TopPrism n) (f upps downps) blac
     downps = map f'' ps
     f (a:as) (b:bs) = a:b:f as bs
     f _ _ = []
-    f' (V2 x y) = (V3 (0.5 * x) (0.5 * y) h)
-    f'' (V2 x y) = (V3 x y 0)
+    f' (V2 x y) = V3 (0.5 * x) (0.5 * y) h
+    f'' (V2 x y) = V3 x y 0
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}