Unify more doors

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)
-            $ ps0 (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 (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