Almost working shadows

src/Dodge/Creature/Inanimate.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {-
 Inanimate objects such as lamps, barrels, etc
 -}
@@ -17,6 +18,8 @@ import Dodge.Creature.Update hiding (CRUpdate)
 import Picture
 import qualified IntMapHelp as IM
 import Geometry
+import Geometry.Vector3D
+import Polyhedra
 
 import Control.Lens
 
@@ -33,15 +36,15 @@ lamp = defaultInanimate
     }
 lampPic :: Picture
 lampPic = pictures
-    [ setDepth (0.049) $ color white $ polygon $ rectNSEW 5 (-5) 5 (-5)
-    , setDepth (0) $ color white $ circleSolid 3
+    [ pictures . map (Poly3D 0 . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 99
+    , setDepth (100) $ color white $ circleSolid 3
     ]
 
 initialiseLamp :: CRUpdate
 initialiseLamp w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp i)
   where
     i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
-    addLS = over lightSources (IM.insert i (lightAt (x,y,100) i))
+    addLS = over lightSources (IM.insert i (lightAt (x,y,20) i))
     (x,y) = _crPos cr
 
 updateLamp :: Int -> CRUpdate
@@ -53,7 +56,7 @@ updateLamp i = unrandUpdate handleLS internalUpdate
         | otherwise    = w & lightSources . ix i . lsPos .~ f cPos
       where
         cPos = _crPos cr
-        f (x,y) = (x,y,100)
+        f (x,y) = (x,y,120)
     internalUpdate cr 
         | _crHP cr < 0 = Nothing
         | otherwise    = Just $ doDamage cr

src/Dodge/LightSources.hs

@@ -14,7 +14,7 @@ lightAt (x,y,z) i =
     LS {_lsID = i
        ,_lsPos = (x,y,z)
        ,_lsDir = 0
-       ,_lsRad = 300
+       ,_lsRad = 500
        ,_lsIntensity = 0.75
        }
 basicLS :: PSType

src/Dodge/Room/Start.hs

@@ -23,8 +23,10 @@ startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     let fground = sPS (0,0) 0 $ PutForeground $ 
-            highPipe 80 (0,h/3) (w, 2*h/3)
-            ++ highPipe 20 (0,2*h/3) (w, h/3)
+            highPipe 80 (0,h/3) (w, h/2)
+            ++ highPipe 40 (0,h/2) (w, h/3)
+            ++ highPipe 60 (w/3,0) (w/3, h)
+            -- ++ highPipe 20 (0,2*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 :))