Start to add mountable objects

src/Dodge/Block.hs

@@ -61,12 +61,21 @@ destroyDoor dr w = w
     & doors %~ IM.delete (_drID dr)
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
     & stopPushing (_drPushes dr)
+    & destroyMounts (_drMounts dr)
   where
     wlids = _drWallIDs dr
     awl = _walls w IM.! IS.findMin wlids
     pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
     ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
 
+destroyMounts :: [MountedObject] -> World -> World
+destroyMounts mos w = foldr destroyMount w mos
+
+destroyMount :: MountedObject -> World -> World
+destroyMount mo = case mo of
+    MountedLS lsid -> lightSources . at lsid .~ Nothing
+    MountedProp prid -> props . at prid .~ Nothing
+
 stopPushing :: Maybe Int -> World -> World
 stopPushing mdrid w = fromMaybe w $ do
     drid <- mdrid

src/Dodge/Data.hs

@@ -1022,15 +1022,21 @@ data Door = Door
     , _drHP     :: Int
     , _drDeath  :: Door -> World -> World
     , _drSpeed  :: Float
-    , _drSupport :: Support
+    , _drPushedBy :: PushSource
     , _drPushes :: Maybe Int
+    , _drMounts :: [MountedObject]
     }
+data MountedObject
+    = MountedLS Int
+    | MountedProp Int
+  deriving (Eq,Ord,Show)
+
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)
 
-data Support = SupportsItself
+data PushSource = PushesItself
-    | SupportedBy Int
+    | PushedBy Int
-    | Unsupported
+    | NotPushed
 
 data ActionPlan
     = Inanimate

src/Dodge/Default/Door.hs

@@ -14,7 +14,8 @@ defaultDoor = Door
     , _drHP     = 10000
     , _drDeath  = const id
     , _drSpeed  = 1
-    , _drSupport = SupportsItself
+    , _drPushedBy = PushesItself
     , _drPushes  = Nothing
+    , _drMounts = mempty
     }
 

src/Dodge/LevelGen.hs

@@ -35,8 +35,8 @@ postGenerationProcessing :: World -> World
 postGenerationProcessing w = foldl' assignPushDoors w (_doors w)
 
 assignPushDoors :: World -> Door -> World
-assignPushDoors w dr = case dr ^?! drSupport of
+assignPushDoors w dr = case dr ^?! drPushedBy of
-    SupportedBy i -> w & doors . ix i . drPushes .~ Just (_drID dr)
+    PushedBy i -> w & doors . ix i . drPushes ?~ _drID dr
     _ -> w
 
 layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly])

src/Dodge/Placement/Instance/Door.hs

@@ -45,13 +45,13 @@ doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of
 divideDoorPane :: Maybe Int -> Bool -> Color -> (World -> Bool) -> Float -> Float 
     -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
 divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of
-    [p] -> ptCont (adoor p) $ g
+    [p] -> ptCont (adoor p) g
     (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) pathing col cond soff speed ps g
     _ -> undefined
   where
     adoor (x,y) = PutSlideDr pathing col thedoor soff x y
     thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
-        & drSupport .~ maybe SupportsItself SupportedBy mid
+        & drPushedBy .~ maybe PushesItself PushedBy mid
 
 putAutoDoor :: Point2 -> Point2 -> Placement
 putAutoDoor a b = PlacementUsingPos (addZ 0 a)

src/Dodge/Room/LongDoor.hs

@@ -106,8 +106,12 @@ addButtonSlowDoor x h rm = do
     openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3*x/2) (-x/2)
     belowH y = (sndV2 . fst) y < h - 40
     aboveH y = (sndV2 . fst) y > h + 40
-    amountedlight dr xoff = Just . moveLSThen (getdoorpos (fromJust $ _plMID dr)) 
+    amountedlight dr xoff mpl = Just . moveLSThen (getdoorpos (fromJust $ _plMID dr)) 
-                (V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90)) . const . const
+                (V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90)) 
+        $ \plls plpr -> Just $ ptCont (PutWorldUpdate (const $ setmount dr plls plpr))
+        $ const mpl
+    setmount pldr plls plpr = doors . ix (fromJust $ _plMID pldr) . drMounts .++~
+        [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
     -- TODO make the height of this light source and of other mounted lights
     -- be taken from a single consistent source
     butDoor = putLitButOnPos col