Unify more doors

src/Dodge/Floor.hs

@@ -35,6 +35,11 @@ initialRoomTree = do
         t = treeFromTrunk 
             [[StartRoom]
             ,[Corridor]
+            ,[Corridor]
+            ,[SpecificRoom slowDoorRoom ]
+            ,[Corridor]
+            ,[Corridor]
+            ,[Corridor]
             ,[SpecificRoom roomCCrits]
             ,[Corridor]
             ,[AirlockAno]

src/Dodge/LevelGen.hs

@@ -54,16 +54,11 @@ placeSpotID ps w = case _psType ps of
     RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
       where 
         (evaluatedType, g) = runState rgen (_randGen w)
-    PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w
+    PutDoor col f pss -> putDoor col f (map (bimap doShift doShift) pss) w
-      where 
+    PutSlideDoor pathing col f a b speed 
-        mapBoth fn (x,y) = (fn x, fn y) 
+        -> placeSlideDoor pathing col f (doShift a) (doShift b) speed w
-    PutSingleDoor col f a b speed 
-        -> placeSingleDoor False col f (doShift a) (doShift b) speed w
-    --PutAutoDoor a b -> (,) 0 $ placeAutoDoor (doShift a) (doShift b) w
     PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
-    PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) 
-                            (doShift a) (doShift b) speed w
     PutLineBlock wl width depth a b
         -> placeLineBlock wl width depth (doShift a) (doShift b) w
     PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)

src/Dodge/LevelGen/Data.hs

@@ -17,13 +17,11 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutProp Prop
     | PutFlIt Item
     | PutPressPlate PressPlate
-   -- | PutAutoDoor Point2 Point2
     | PutBlock [Int] Color [Point2]
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
-    | PutSingleDoor Color (World -> Bool) Point2 Point2 Float
+    | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
-    | PutBtDoor Color Point2 Float Point2 Point2 Float
     | RandPS (State StdGen PSType)
     | PutForeground Shape
     | PutNothing

src/Dodge/LevelGen/TriggerDoor.hs

@@ -1,15 +1,15 @@
 --{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.TriggerDoor
     ( putDoor
-    , placeSingleDoor
+    , placeSlideDoor
-    , addButtonDoor
+    --, addButtonDoor
     ) where
 import Dodge.Data
-import Dodge.Base
+--import Dodge.Base
-import Dodge.Zone
+--import Dodge.Zone
 import Dodge.Default.Wall
-import Dodge.LevelGen.Switch
+--import Dodge.LevelGen.Switch
-import Dodge.LevelGen.Pathing
+--import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.MoveDoor
 import Dodge.LevelGen.DoorPane
 import Picture
@@ -20,32 +20,10 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Data.SoundOrigin
 
 import Data.List
-import Data.Maybe
+--import Data.Maybe
 import Control.Lens
-import Data.Graph.Inductive hiding ((&))
+--import Data.Graph.Inductive hiding ((&))
 import qualified Data.IntSet as IS
-
--- probably don't have to rebuild the entire graph, oh well
-addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
-addButtonDoor c btp btr a b speed w 
-    = (,) 0
-    . over buttons (IM.insert bid bt) 
-    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
-    $ set pathGraph newGraph
-    $ set pathGraphP newGraphPairs
-    $ snd (placeSingleDoor False c cond a b speed w)
-  where 
-    bid = IM.newKey $ _buttons w
-    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
-    bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
-    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
-                                             $ _pathGraphP w
-    newGraph = pairsToGraph dist newGraphPairs
-    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-    eff w' = over pathGraphP (removedPairs ++) 
-             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
-    f (x,y) = (x,y,dist x y)
-
 putDoor 
     :: Color 
     -> (World -> Bool)      -- ^ Opening condition
@@ -122,10 +100,10 @@ doorMechanism drid speed wlidOpCps dr w
         & walls . ix wlid %~ moveDoorToward speed p
         & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))
 
-placeSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
+-- TODO cut pathing if not pathable, reset when opened
+placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
     -> (Int, World)
-placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w 
+placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ addDoor)
-    & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors w
     addDoor = IM.insert drid $ Door
@@ -148,3 +126,25 @@ placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w
     shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
     shiftLeft  = (+.+ (a -.- b))
     wlids = take 4 [IM.newKey $ _walls w ..]
+-- old code that may help with pathing
+--import Dodge.LevelGen.Pathing
+--import Data.Graph.Inductive hiding ((&))
+--addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
+--addButtonDoor c btp btr a b speed w 
+--    = (,) 0
+--    . over buttons (IM.insert bid bt) 
+--    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+--    $ set pathGraph newGraph
+--    $ set pathGraphP newGraphPairs
+--    $ snd (placeSlideDoor False c cond a b speed w)
+--  where 
+--    bid = IM.newKey $ _buttons w
+--    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
+--    bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
+--    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
+--                                             $ _pathGraphP w
+--    newGraph = pairsToGraph dist newGraphPairs
+--    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+--    eff w' = over pathGraphP (removedPairs ++) 
+--             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+--    f (x,y) = (x,y,dist x y)

src/Dodge/Placements.hs

@@ -1,5 +1,6 @@
 module Dodge.Placements
-    ( putDoubleDoorThen
+    ( putDoubleDoor
+    , putDoubleDoorThen
     , putAutoDoor
     )
     where
@@ -11,13 +12,18 @@ import Dodge.LevelGen.Data
 import Dodge.Creature.Property
 
 import qualified Data.IntMap.Strict as IM
-putDoubleDoorThen :: Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
+
-putDoubleDoorThen col cond a b speed mayp = ps0j (PutSingleDoor col cond a half speed)
+putDoubleDoor :: Bool -> Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
-    $ Placement (PS (V2 0 0) 0 (PutSingleDoor col cond b half speed)) $ const mayp
+putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
+
+putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
+    -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
+putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
+    $ Placement (PS (V2 0 0) 0 (PutSlideDoor pathing col cond b half speed)) $ const mayp
   where
     half = 0.5 *.* (a +.+ b)
 
 putAutoDoor :: Point2 -> Point2 -> Placement
-putAutoDoor a b = putDoubleDoorThen (dim yellow) cond a b 3 Nothing
+putAutoDoor a b = putDoubleDoorThen True (dim yellow) cond a b 3 Nothing
   where
     cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures

src/Dodge/Room/Airlock.hs

@@ -19,8 +19,7 @@ import System.Random
 import Control.Monad.State
 {- | A passage with a switch that opens forward access while closing backwards access. -}
 airlock :: RandomGen g => State g Room
---airlock = takeOne [airlock0,airlock90,airlockCrystal]
+airlock = takeOne [airlock0,airlock90,airlockCrystal]
-airlock = takeOne [airlock0]
 {- | Straight airlock -}
 airlock0 :: Room
 airlock0 = defaultRoom
@@ -29,10 +28,8 @@ airlock0 = defaultRoom
     , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
     , _rmPS    = 
         [Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id)
-            $ \btid -> Just $ putDoubleDoorThen col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
+            $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
-                $ Just $ putDoubleDoorThen col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
+                $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
-          --  $ \btid -> jspsJ (V2 0 0) 0 (PutDoubleDoor col (not . cond' btid) (V2 1 20) (V2 39 20) 2)
-          --  $ sPS (V2 0 0) 0 $ PutDoubleDoor col (cond' btid) (V2 1 80) (V2 39 80) 2
         ,mountedLightI 70 (V2 (-2) 30) (V2 (-2) 70)
         ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
         ]

src/Dodge/Room/LongDoor.hs

@@ -16,6 +16,7 @@ import Dodge.RandomHelp
 import Dodge.Creature.Inanimate
 import Dodge.Creature
 import Dodge.LightSources.Lamp
+import Dodge.Placements
 import Picture
 import Geometry
 
@@ -40,8 +41,8 @@ twinSlowDoorRoom w h x = defaultRoom
     , _rmPath   = []
     , _rmPS     = 
         [ Placement (PS (V2 0 (h-5)) pi $ PutButton $ makeButton col id)
-            $ \btid -> jsps0J (PutSingleDoor col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
+            $ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
-            $ ps0 (PutSingleDoor col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
+            $ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
             $ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
             $ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
         ]
@@ -104,15 +105,22 @@ slowDoorRoom = do
      pillars <- takeOne [pillarsa, pillarsb, pillarsc]
      let cond x'  = (sndV2 . fst) x' > h + 40
          cond2 x' = (sndV2 . fst) x' < h - 40
-     but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2
+     but <- takeOne [butDoor x h butPos butRot
                     ]
      fmap connectRoom 
         (filterLinks cond =<< 
             changeLinkTo cond2 
-                (set rmPS ([sPS (V2 0 0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) 
+                (set rmPS ([but] ++ crits ++ pillars ++ barrels ++ lsources) 
                 $ roomRectAutoLinks x y
                 )
         )
+  where
+    butDoor x h bpos brot 
+        = ps0 (PutButton $ (makeButton col id) {_btPos = bpos, _btRot = brot})
+        $  \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
+    col = dim $ light red
+    cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
+     --but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2
 
 randC1 :: PSType
 randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit

src/Dodge/Room/Placement.hs

@@ -177,8 +177,8 @@ putBlockN a x b y = [ blockLine (V2 a b) (V2 a y)
 
 switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
 switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id)
-    $ \btid -> jsps0J (PutSingleDoor col (cond btid) dra drc 2)
+    $ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
-    $          sps0   (PutSingleDoor col (cond btid) drb drc 2)
+    $          sps0   (PutSlideDoor False col (cond btid) drb drc 2)
   where
     drc = 0.5 *.* (dra +.+ drb)
     cond btid w' = _btState (_buttons w' IM.! btid) == BtOn

src/Dodge/Room/Procedural.hs

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