Implement moving mounted lights

src/Dodge/LevelGen/Data.hs

@@ -28,7 +28,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutTrigger (World -> Bool)
     | PutLineBlock Wall BlockMaterial Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
-    | PutSlideDr Bool Color (World -> Bool) Point2 Point2 Float
+    | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | RandPS (State StdGen PSType)
     | PutShape Shape

src/Dodge/Placement/Instance/Door.hs

@@ -16,16 +16,18 @@ import qualified Data.IntMap.Strict as IM
 
 putDoubleDoor :: Bool -> Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
 putDoubleDoor pathing col cond a b speed 
-    = putDoubleDoorThen pathing col cond a b speed (const $ const Nothing)
+    = putDoubleDoorThen pathing col cond 1 a b speed (const $ const Nothing)
 
 putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
-    -> Point2 -> Point2 -> Float 
+    -> Float -> Point2 -> Point2 -> Float 
     -> (Placement -> Placement -> Maybe Placement)
     -> Placement
-putDoubleDoorThen pathing col cond a b speed cont = pt0 (PutSlideDr pathing col cond a half speed)
+putDoubleDoorThen pathing col cond soff a b speed cont 
-    $ \pl1 -> Just $ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing 
+    = doorbetween a half
+    $ \pl1 -> Just $ doorbetween b half
     $ \pl2 -> cont pl1 pl2
   where
+    doorbetween pa pb = pt0 $ PutSlideDr pathing col cond soff pa pb speed
     half = 0.5 *.* (a +.+ b)
 
 putAutoDoor :: Point2 -> Point2 -> Placement
@@ -39,8 +41,9 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
 
 switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
 switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
-    $ \btid -> jsps0J (PutSlideDr False col (cond btid) dra drc 2)
+    $ \btid -> jsps0J (doorbetween btid dra drc)
-    $          sps0   (PutSlideDr False col (cond btid) drb drc 2)
+    $          sps0   (doorbetween btid drb drc)
   where
+    doorbetween btid a b = PutSlideDr False col (cond btid) 1 a b 2
     drc = 0.5 *.* (dra +.+ drb)
     cond btid w' = _btState (_buttons w' IM.! btid) == BtOn

src/Dodge/Placement/Instance/LightSource.hs

@@ -11,8 +11,44 @@ import Dodge.Default
 import Dodge.RandomHelp 
 import Color
 import Shape
+import ShapePicture
 
 import Control.Lens
+import Data.Maybe
+
+propLSThen :: (Prop -> World -> World)
+    -> (Prop -> World -> LightSource -> LightSource)
+    -> LightSource 
+    -> Prop
+    -> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
+    -> Placement
+propLSThen propf lsf ls prop cont = pt0 (PutLS $ ls)
+    $ \lspl -> Just $ pt0 (PutProp $ prop & pjUpdate .~ theupdate (fromJust $ _plMID lspl))
+    $ cont lspl
+  where
+    theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
+
+moveLSThen :: (World -> (Point2,Float))
+    -> Point3   -- ^ light source offset
+    -> Shape
+    -> (Placement -> Placement -> Maybe Placement)
+    -> Placement
+moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
+  where
+    propupdate pr w = w 
+        & props . ix (_pjID pr) . pjPos .~ fst (posf w)
+        & props . ix (_pjID pr) . pjRot .~ snd (posf w)
+    lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
+    thels = defaultLS
+    theprop = ShapeProp
+        { _pjPos = 0
+        , _pjID = 0
+        , _pjRot = 0
+        , _pjUpdate = const id
+        , _prDraw = \pr -> noPic $ uncurryV translateSHf (_pjPos pr) $ rotateSH (_pjRot pr) sh
+        , _prToggle = True
+        }
+    
 
 -- | mount a light source on a shape
 mntLSOn

src/Dodge/Placement/PlaceSpot.hs

@@ -99,8 +99,8 @@ placeSpotID ps pt w = case pt of
     RandPS      rgn         -> evaluateRandPS rgn ps w
     PutDoor     col f   pss -> plDoor col f (map (bimap doShift doShift) pss) w
     PutCoord    cp          -> plNewID   coordinates (doShift cp) w
-    PutSlideDr  pth col f  a   b spd 
+    PutSlideDr  pth col f off  a   b spd 
-                            -> plSlideDoor pth col f (doShift a) (doShift b) spd w
+                            -> plSlideDoor pth col f off (doShift a) (doShift b) spd w
     PutBlock    bm  hp  hps wl  ps' 
                             -> placeBlock (map doShift ps') hp wl hps bm w
     PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -98,9 +98,18 @@ doorMechanism drid speed wlidOpCps dr w
     doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
 
 -- TODO cut pathing if not pathable, reset when opened
-plSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld
+plSlideDoor 
+    :: Bool 
+    -> Color 
+    -> (World -> Bool) 
+    -> Float
+    -> Point2 
+    -> Point2 
+    -> Float 
+    -> GenWorld
     -> (Int, GenWorld)
-plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
+plSlideDoor isPathable col cond shiftOffset a b speed gw 
+    = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
   where
     w = _gWorld gw
     drid = IM.newKey $ _doors w
@@ -117,7 +126,7 @@ plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w
     addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs
     pairs = rectanglePairs 9 a b
     shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
-    shiftLeft  = (+.+ (a -.- b +.+ normalizeV (b -.- a)))
+    shiftLeft  = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
     wlids = take 4 [IM.newKey $ _walls w ..]
 -- old code that may help with pathing
 --import Dodge.LevelGen.Pathing

src/Dodge/Room/Airlock.hs

@@ -28,7 +28,7 @@ airlock0 = defaultRoom
     , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
     , _rmPmnts    = 
         [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
-            $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
+            $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) 1 (V2 (-1) 20) (V2 41 20) 2
                 $ \_ _ -> Just $ putDoubleDoor False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2
         ,spanLightI (V2 (-2) 30) (V2 (-2) 70)
         ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)

src/Dodge/Room/LongDoor.hs

@@ -22,11 +22,13 @@ import Dodge.LightSource
 import Picture
 import Geometry
 import LensHelp
+--import Shape
 
 import qualified Data.Set as S
 import Data.Tree
 import System.Random
 import Control.Monad.State
+import Data.Maybe
 --import Data.Tree
 import qualified Data.IntMap as IM
 
@@ -44,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom
     , _rmPath   = []
     , _rmPmnts     = 
         [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
-            $ \btid -> jsps0J (PutSlideDr False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
+            $ \btid -> jsps0J (PutSlideDr False col (cond' btid) 1 (V2 x 1) (V2 x h) wlSpeed)
-            $ ps0 (PutSlideDr False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
+            $ ps0 (PutSlideDr False col (cond' btid) 1 (V2 (-x) 1) (V2 (-x) h) wlSpeed)
             $ \did -> jps0 (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight)))
             $ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
         ]
@@ -117,8 +119,18 @@ addButtonSlowDoor x h rm = do
     belowH y = (sndV2 . fst) y < h - 40
     aboveH y = (sndV2 . fst) y > h + 40
     butDoor _ _ = putLitButOnPos col butPosCond
-        $  \btid -> Just $ putDoubleDoorThen False col (cond' btid) (V2 0 h) (V2 x h) 2
+        $  \btid -> Just $ putDoubleDoorThen False col (cond' btid) 30 (V2 0 h) (V2 x h) 2
-        $ \dr1 dr2 -> Nothing
+        $ \dr1 dr2 -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr1)) 
+                (V3 15 50 88) (aShape (V2 15 0) (V3 15 50 90))
+        $ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr2)) 
+                (V3 15 (-50) 88) (aShape (V2 15 0) (V3 15 (-50) 90))
+        $ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr2)) 
+                (V3 15 50 88) (aShape (V2 15 0) (V3 15 50 90))
+        $ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr1)) 
+                (V3 15 (-50) 88) (aShape (V2 15 0) (V3 15 (-50) 90))
+        $ \_ _ ->Nothing
+    getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
+        in (b, argV (a-.-b))
     butPosCond (UnusedLink (V2 x' y') a' _) _ | y' < 0.5 * h 
                 = Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink))
     butPosCond _ _ = Nothing
@@ -139,10 +151,9 @@ slowDoorRoom = do
     xs' <- replicateM 5 $ state $ randomR (10,x-10)
     ys' <- replicateM 5 $ state $ randomR (h+20,y)
     let crits = zipWith (\p r -> sPS p r randC1) ps rs
-        lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
         barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
     proom <- southPillarsRoom x y h
-    addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources)))
+    addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
 
 slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room)
 slowDoorRoomRunPast = do

src/Dodge/Room/Procedural.hs

@@ -254,7 +254,7 @@ centerVaultRoom w h d = do
     col = dim $ dim $ bright red
     theDoor = 
         [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
-            $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
+            $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 (-21) 0) (V2 0 0) 2)
-            $          sPS   (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2   21  0) (V2 0 0) 2)
+            $          sPS   (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2   21  0) (V2 0 0) 2)
         ]
     cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn