Working inter-room placements

src/Dodge/Floor.hs

@@ -10,11 +10,13 @@ import Dodge.Room.Procedural
 import Dodge.Room.RoadBlock
 import Dodge.Room.Data
 import Dodge.Room
+import Dodge.Room.Door
 import Dodge.Room.Branch
 import Dodge.Room.Boss
 import Dodge.Room.LongDoor
 import Dodge.Room.NoNeedWeapon
 import Dodge.Room.Link
+import Dodge.Placements.Button
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
 import Dodge.Layout.Tree.Annotate
@@ -24,6 +26,7 @@ import Dodge.LevelGen.Data
 import Dodge.Item.Weapon.Launcher
 import MonadHelp
 import Data.Tree
+import Color
 
 import Control.Lens
 import Control.Monad.State
@@ -35,6 +38,10 @@ import Data.Maybe
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[StartRoom]
+    ,[SetLabel 0 $ return $ roomRectAutoLinks 100 100 
+        & rmExtendedPmnt .~ Just (externalButton red (PS (V2 50 50) 0))
+     ]
+    ,[UseLabel 0 $ return switchDoorRoom]
     ,[SpecificRoom $ return $ connectRoom lasTunnel ]
     ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
     ,[Corridor]

src/Dodge/Layout.hs

@@ -1,11 +1,12 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Layout 
     ( generateLevelFromRoomList
-    , doPartialPlacements
-    , doExtendedPlacements
+--    , doPartialPlacements
+--    , doExtendedPlacements
     ) where
 import Dodge.Data
 import Dodge.LevelGen
+import Dodge.LevelGen.Data
 import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.Pathing
 import Dodge.Wall.Zone
@@ -34,6 +35,8 @@ generateLevelFromRoomList :: [Room] -> World -> World
 generateLevelFromRoomList gr w 
     = initWallZoning 
     . setupWorldBounds
+    . doPartialPlacements rs
+    . doExtendedPlacements rs
     . flip (foldl' doRoomPlacements) rs
     $ w { _walls        = wallsFromRooms rs
         , _floorTiles   = floorsFromRooms rs
@@ -47,25 +50,26 @@ generateLevelFromRoomList gr w
     rs = zipWith addTile zs gr
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
 
-doPartialPlacements :: [Room] -> (IM.IntMap Int,World) -> World
+doPartialPlacements :: [Room] -> (IM.IntMap [Placement],World) -> World
 doPartialPlacements rms (im,w) = foldr (doPartialPlacement im) w rms
 
-doPartialPlacement :: IM.IntMap Int -> Room -> World -> World
+doPartialPlacement :: IM.IntMap [Placement] -> Room -> World -> World
 doPartialPlacement im rm w = case _rmPartialPmnt rm of
     Nothing -> w
     Just fi -> case _rmTakeFrom rm of
         Nothing -> w
         Just i  -> fst $ fst $ placeSpot (w,rm) (fi (im IM.! i))
 
-doExtendedPlacements :: [Room] -> World -> (IM.IntMap Int, World)
+doExtendedPlacements :: [Room] -> World -> (IM.IntMap [Placement], World)
 doExtendedPlacements rms w = foldr doExtendedPlacement (IM.empty,w) rms
 
-doExtendedPlacement :: Room -> (IM.IntMap Int, World) -> (IM.IntMap Int, World)
+doExtendedPlacement :: Room -> (IM.IntMap [Placement], World) -> (IM.IntMap [Placement], World)
 doExtendedPlacement rm (im,w) = case _rmExtendedPmnt rm of
     Nothing -> (im,w)
-    Just _ -> case _rmLabel rm of
+    Just plmnt -> case _rmLabel rm of
         Nothing -> (im,w)
-        Just i  -> undefined
+        Just i  -> let ((neww,_),plmnts) = placeSpot (w,rm) plmnt
+            in (IM.insert i plmnts im, neww)
 
 doRoomPlacements :: World -> Room -> World
 doRoomPlacements w rm = fst $ foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm

src/Dodge/LevelGen/Data.hs

@@ -52,6 +52,9 @@ spNoID ps pst = Placement ps pst Nothing (const Nothing)
 pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
 pContID ps pt = Placement ps pt Nothing . intPlPlPl
 
+plCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
+plCont ps pt = Placement ps pt Nothing
+
 sPS :: Point2 -> Float -> PSType -> Placement
 sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
 

src/Dodge/Placements/Button.hs

@@ -12,6 +12,14 @@ import Dodge.Placements.Spot
 
 import Control.Lens
 
+externalButton :: Color -> PlacementSpot -> Placement
+externalButton col ps = pContID ps (PutTrigger (const False))
+    $ \trigid -> Just $ pContID ps (PutButton (makeSwitch col col (oneff trigid) (offeff trigid))) 
+                    (const Nothing)
+  where
+    oneff  tid = triggers . ix tid .~ const True
+    offeff tid = triggers . ix tid .~ const False
+
 putLitButtonID :: Color -> Point2 -> Float -> (Int -> Maybe Placement) -> Placement
 putLitButtonID col p a subpl = mountLightAID (Just col) ls p'' (addZ 40 p')
     $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a})
@@ -31,3 +39,4 @@ putLitButtonID' col f subpl
     changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
     ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
     thePS = PSLnk f id Nothing
+

src/Dodge/Room/Data.hs

@@ -25,7 +25,7 @@ data Room = Room
     , _rmPos    :: [RoomPos]
     , _rmPath   :: [(Point2, Point2)]
     , _rmPmnts  :: [Placement]
-    , _rmPartialPmnt    :: Maybe (Int -> Placement)
+    , _rmPartialPmnt    :: Maybe ([Placement] -> Placement)
     , _rmExtendedPmnt   :: Maybe Placement
     , _rmBound  :: [ [Point2] ]
     , _rmFloor  :: [Tile]

src/Dodge/Room/Door.hs

@@ -2,12 +2,16 @@
 module Dodge.Room.Door
     where
 import Geometry
+import Dodge.Data
 import Dodge.Room.Data
 import Dodge.Default.Room
 import Dodge.Placements
---import Color
+import Color
 
---import qualified Data.IntMap.Strict as IM
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+import Dodge.LevelGen.Data
+import Control.Lens
 
 door :: Room
 door = defaultRoom
@@ -23,12 +27,12 @@ door = defaultRoom
         ,(V2 20  5,pi)
         ]
 
-
-switchDoor :: Room
-switchDoor = defaultRoom
+switchDoorRoom :: Room
+switchDoorRoom = defaultRoom
     { _rmPolys = [rectNSWE 40 0 0 40]
     , _rmLinks = lnks
     , _rmPath  = [(V2 20 35,V2 20 5)]
+    , _rmPartialPmnt = Just f
 -- door extends into side walls (for shadows as rendered 12/03)
 -- note no bounds
     }
@@ -36,4 +40,7 @@ switchDoor = defaultRoom
     lnks = [(V2 20 35,0)
         ,(V2 20  5,pi)
         ]
+    f (pmnt:_) = putDoubleDoor False red (cond pmnt) (V2 0 20) (V2 40 20) 2
+    f _ = error "tried to put a door using an empty placement list"
+    cond pmnt w = w & _triggers w IM.! fromJust (_plMID pmnt)