Allow for items to cast shadows

src/Shape.hs

@@ -1,7 +1,16 @@
 {-# LANGUAGE BangPatterns  #-}
 module Shape
     ( module Shape.Data
-    , module Shape
+    , translateSH
+    , emptySH
+    , polyCirc
+    , prismPoly
+    , flatCirc
+    , translateSHz
+    , translateSHf
+    , rotateSH
+    , scaleSH
+    , colorSH
     )
   where
 import Geometry
@@ -10,16 +19,17 @@ import Geometry.ConvexPoly
 import Shape.Data
 import Color
 
-empty :: Shape
-{-# INLINE empty #-}
-empty = Shape [] []
+emptySH :: Shape
+{-# INLINE emptySH #-}
+emptySH = Shape [] []
 
 flatCirc :: Float -> Shape
-flatCirc = flatPoly . polyCirc
+{-# INLINE flatCirc #-}
+flatCirc = flatPoly . polyCirc 3
 
-polyCirc :: Float -> [Point2]
+polyCirc :: Int -> Float -> [Point2]
 {-# INLINE polyCirc #-}
-polyCirc x = map (\a -> rotateV a (V2 x 0)) $ take 8 [0,pi/4..]
+polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/(fromIntegral n)..]
 
 prismPoly 
     :: Float    -- ^ height, expected to be strictly positive
@@ -57,8 +67,8 @@ flatPoly ps = Shape
     g (V2 x y) (V2 a b) =
         [ V3 x y   0
         , V3 a b   0
-        , V3 x y 0 - n
-        , V3 a b 0 - n
+        , V3 x y 0 -.-.- n
+        , V3 a b 0 -.-.- n
         ]
       where
         n = addZ 0 $ vNormal (V2 (a-x) (b-y))
@@ -66,42 +76,52 @@ flatPoly ps = Shape
     --n = 
 
 colorSH :: Color -> Shape -> Shape
+{-# INLINE colorSH #-}
 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
     ,_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
     }
 
 translateSH :: Point3 -> Shape -> Shape
-translateSH !p = overPos (+p)
+{-# INLINE translateSH #-}
+translateSH !p = overPos (+.+.+ p)
 
 translateSHf :: Float -> Float -> Shape -> Shape
+{-# INLINE translateSHf #-}
 translateSHf x y = translateSH (V3 x y 0)
 
 translateSHz :: Float -> Shape -> Shape
+{-# INLINE translateSHz #-}
 translateSHz z = translateSH (V3 0 0 z)
 
 rotateSH :: Float -> Shape -> Shape
+{-# INLINE rotateSH #-}
 rotateSH a = overPos (rotate3 a)
 
 scaleSH :: Point3 -> Shape -> Shape
-scaleSH !p = overPos (*p)
+{-# INLINE scaleSH #-}
+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
     }
 
 overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
+{-# INLINE overPosVertex #-}
 overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
     {_svPos = f pos
     ,_svCol = col