Implement simple sweep light

src/Dodge/Data.hs

@@ -489,6 +489,13 @@ data Prop
         , _pjUpdate :: Prop -> World -> World
         , _pjTime :: Int
         }
+    | ShapeProp
+        { _pjPos :: Point2
+        , _pjID :: Int
+        , _pjRot :: Float
+        , _pjUpdate :: Prop -> World -> World
+        , _prDraw :: Prop -> SPic
+        }
     | Shell 
         { _pjPos :: Point2
         , _pjStartPos :: Point2

src/Dodge/LevelGen.hs

@@ -70,6 +70,7 @@ placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements
 {- | -}    
 placeSpot :: PlacementSpot -> World -> World
 placeSpot ps w = case _psType ps of
+    PutProp prop -> placeProp prop p rot w
     PutButton bt -> placeBt bt p rot w
     PutFlIt itm -> placeFlIt itm p rot w
     PutCrit cr -> placeCr cr p rot w
@@ -146,6 +147,17 @@ addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
     })
     wls
 
+-- TODO make rotation of props sensible
+placeProp 
+    :: Prop
+    -> Point2
+    -> Float -- ^ Rotation
+    -> World
+    -> World
+placeProp pr p a = over props addProp
+  where 
+    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs
+
 placeBt 
     :: Button
     -> Point2

src/Dodge/LevelGen/Data.hs

@@ -28,6 +28,7 @@ import System.Random
 data PSType = PutCrit {_unPutCrit :: Creature}
     | PutLS LightSource Picture
     | PutButton Button
+    | PutProp Prop
     | PutFlIt Item
     | PutPressPlate PressPlate
     | PutAutoDoor Point2 Point2

src/Dodge/LightSources.hs

@@ -4,11 +4,15 @@ module Dodge.LightSources
     , lightAt
     , colorLightAt
     , lampPic
+    , lampCover
     )
     where
 import Dodge.Data
 import Geometry.Data
 import Picture
+import ShapePicture
+import Shape
+import Geometry
 
 import Control.Lens
 
@@ -62,3 +66,31 @@ tLight t rmax col (V3 x y z) = TLS
 lampPic :: Float -> Picture
 --{-# INLINE lampPic #-}
 lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
+
+lampCover :: Float -> Prop
+lampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = updateLampCover
+    , _prDraw = drawLampCover h
+    }
+
+updateLampCover :: Prop -> World -> World
+updateLampCover pr w = w
+    & props . ix (_pjID pr) . pjRot +~ 0.15
+
+drawLampCover :: Float -> Prop -> SPic
+drawLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
+        $ rotateSH a $ mconcat
+        [ upperPrismPoly 5 $ rectNSEW 6 5    6 (-4)
+        , upperPrismPoly 5 $ rectNSEW 6 (-4) 6 5
+        --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
+        , upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr

src/Dodge/Room/Corridor.hs

@@ -17,8 +17,8 @@ corridor = defaultRoom
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
     , _rmPS    = 
-        [ sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
-        , sPS (V2 0 0)   0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
+        [-- sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
+         sPS (V2 0 0)   0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
         ]
     , _rmBound = [ rectNSWE 50 30 0 40 ]
     , _rmFloor = [makeTileFromPoly poly 2]  

src/Dodge/Room/Start.hs

@@ -8,6 +8,7 @@ import Dodge.Room.Placement
 import Dodge.Room.Foreground
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
+import Dodge.LightSources
 --import Picture
 import Geometry.Data
 
@@ -24,13 +25,21 @@ startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     let fground = sPS (V2 0 0) 0 $ PutForeground $ 
-               girderV 50 20 10 (V2  0    (h/5)) (V2  w    (h/5))
-            <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/3))
+               girderV 40 20 10 (V2  0    (h/6)) (V2  w    (h/6))
+            <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/2))
             <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
         theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.75 0.75)
     treeFromPost [Left rezBox, Left door] . Right 
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
-                $ roomRectAutoLinks w h & rmPS .~ [fground,theLamp])
+                $ roomRectAutoLinks w h & rmPS .~ 
+            [ fground
+            --, theLamp
+            , sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
+            , sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
+            ]
+            )
+  where
+    lampHeight = 41
 --  where
 --    cola = dark . dark . light . light $ light red
 --    colb = dark . dark . light . light $ light blue