Initial pass at shadows from level geometry

src/Dodge/Room/Foreground.hs

@@ -8,6 +8,7 @@ import Geometry
 import Geometry.Data
 import Geometry.Vector3D
 import Polyhedra
+import Polyhedra.Data
 
 import Data.List
 import Data.Maybe
@@ -47,14 +48,13 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
         ]
     yN = d * 0.5 *.* normalizeV (pa -.- pb)
 
-highPipe :: Point2 -> Point2 -> Picture
-highPipe x@(xx,xy) y = pictures 
-    --[color orange . pictures . map (poly3D . map ( ( , black) . ( +.+.+ (x,y,50)))) $ boxXYZ 
-    [ color orange . pictures . map (poly3D . map ( (,black) . (+.+.+ (xx,xy,50)))) 
+highPipe :: Point2 -> Point2 -> [Polyhedra]
+highPipe x@(xx,xy) y = 
+    [ Polyhedron . map (map ( (,orange) . (+.+.+ (xx,xy,50)))) 
         $ boxABC (a,b,0) (a',b',0) (0,0,10)
-    ,verticalPipe 5 orange x 0 100 
-    ,verticalPipe 5 orange y 0 100 
-    ,verticalPipe 5 orange (0.5 *.* (x +.+ y)) 50 100 
+--    ,verticalPipe 5 orange x 0 100 
+--    ,verticalPipe 5 orange y 0 100 
+--    ,verticalPipe 5 orange (0.5 *.* (x +.+ y)) 50 100 
     ]
   where
     (a,b) = y -.- x

src/Dodge/Room/Start.hs

@@ -7,7 +7,7 @@ import Dodge.Room.Procedural
 import Dodge.Room.Foreground
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
-import Picture
+--import Picture
 --import Geometry
 
 import Data.Tree
@@ -22,12 +22,10 @@ startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
-    let fground = sPS (0,0) 0 $ PutForeground $ pictures
-            [ highPipe (0,h/3) (w, h/3)
-            , girderV cola 10 (0,3*h/4) (w, 3*h/4)
-            , girder colb 5 (0,5*h/8) (w, 5*h/8)
-            ]
+    let fground = sPS (0,0) 0 $ PutForeground $ highPipe (0,h/3) (w, h/3)
+--            , girderV cola 10 (0,3*h/4) (w, 3*h/4)
+--            , girder colb 5 (0,5*h/8) (w, 5*h/8)
     treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
-  where
-    cola = dark . dark . light . light $ light red
-    colb = dark . dark . light . light $ light blue
+--  where
+--    cola = dark . dark . light . light $ light red
+--    colb = dark . dark . light . light $ light blue