Add explicit door position field

src/Dodge/Data.hs

@@ -123,7 +123,7 @@ data World = World
     , _inventoryMode        :: InventoryMode
     , _distortions          :: [Distortion]
     , _worldBounds          :: Bounds
-    , _gameRooms            :: [GameRoom] -- consider using and IntMap
+    , _gameRooms            :: [GameRoom] -- consider using an IntMap
     , _maybeWorld           :: Maybe' World
     , _rewindWorlds         :: [World]
     , _timeFlow             :: TimeFlowStatus
@@ -739,6 +739,9 @@ data Door = Door
     , _drStatus  :: DoorStatus
     , _drTrigger :: World -> Bool
     , _drMech    :: Door -> World -> World
+    , _drPos :: Point2
+    , _drOpenPos :: Point2
+    , _drClosePos :: Point2
     }
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)

src/Dodge/Default/Room.hs

@@ -25,7 +25,7 @@ defaultRoom = Room
     , _rmTakeFrom   = Nothing
     , _rmStartWires = IM.empty
     , _rmEndWires   = IM.empty
-    , _rmConnectsTo = S.singleton OutLink
+    , _rmConnectsTo = S.member OutLink
     , _rmMID        = Nothing
     , _rmMParent    = Nothing
     , _rmChildren   = []

src/Dodge/LevelGen/Data.hs

@@ -89,7 +89,7 @@ data Room = Room
     , _rmTakeFrom   :: Maybe Int
     , _rmStartWires :: IM.IntMap RoomWire
     , _rmEndWires   :: IM.IntMap RoomWire
-    , _rmConnectsTo :: S.Set RoomLinkType
+    , _rmConnectsTo :: (S.Set RoomLinkType -> Bool)
     , _rmMID        :: Maybe Int
     , _rmMParent    :: Maybe Int
     , _rmChildren   :: [Int]

src/Dodge/LockAndKey.hs

@@ -14,11 +14,11 @@ import Control.Monad.State
 
 lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g CombineType ) ]
 lockRoomKeyItems = 
-    [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
+--    [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
-    ,(const slowDoorRoomRunPast, return MINIGUN)
+    [(const slowDoorRoomRunPast, return MINIGUN)
-    ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD])
+--    ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD])
-    ,(const glassLessonRunPast, takeOne [LASGUN])
+--    ,(const glassLessonRunPast, takeOne [LASGUN])
-    ,(const $ lasTunnelRunPast 400, return FLATSHIELD)
+--    ,(const $ lasTunnelRunPast 400, return FLATSHIELD)
     ]
 
 itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]

src/Dodge/Placement/Instance/Door.hs

@@ -1,4 +1,9 @@
-module Dodge.Placement.Instance.Door where
+module Dodge.Placement.Instance.Door 
+    ( putDoubleDoor
+    , putAutoDoor
+    , putDoubleDoorThen
+    , switchDoor -- not used 9/3/22
+    ) where
 import Dodge.Data
 import Dodge.Base
 import Color
@@ -19,8 +24,6 @@ putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDr pathing col
   where
     half = 0.5 *.* (a +.+ b)
 
-    
-
 putAutoDoor :: Point2 -> Point2 -> Placement
 putAutoDoor a b = PlacementUsingPos (addZ 0 a)
     $ \az -> PlacementUsingPos (addZ 0 b)

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -33,7 +33,12 @@ plDoor col cond pss gw = (drid, gw & gWorld  .~ (addWalls w & doors %~ addDoor))
         , _drStatus = DoorInt 0
         , _drTrigger = cond
         , _drMech   = doorMechanismStepwise nsteps drid wlids pss
+        , _drPos = openp
+        , _drOpenPos = openp
+        , _drClosePos = closep
         }
+    openp = 0.5 *.* uncurry (+.+) (head pss)
+    closep = 0.5 *.* uncurry (+.+) (last pss)
     nsteps = length pss - 1
     wlids = take 4 [IM.newKey $ _walls w ..]
     wlps' = uncurry (rectanglePairs 9) $ head pss
@@ -49,6 +54,7 @@ addDoorWall col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defau
     , _wlPathable = pathableStatus
     }
 -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
+-- TODO update _drPos
 -- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
 doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
 doorMechanismStepwise nsteps drid wlids pss dr w 
@@ -72,14 +78,16 @@ doorMechanismStepwise nsteps drid wlids pss dr w
 doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door -> World -> World
 doorMechanism drid speed wlidOpCps dr w 
     | toOpen     && dstatus /= DoorOpen   = moveUpdate $ foldl' doOpen  w wlidOpCps
+        & doors . ix drid . drPos %~ mvP speed (_drOpenPos dr)
     | not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
+        & doors . ix drid . drPos %~ mvP speed (_drClosePos dr)
     | otherwise = w
   where
     moveUpdate = playSound . setStatus
     playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
     setStatus
-        | dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
+        | dist (_drPos dr) (_drOpenPos dr) < 1 = doors . ix drid . drStatus .~ DoorOpen
-        | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
+        | dist (_drPos dr) (_drClosePos dr) < 1 = doors . ix drid . drStatus .~ DoorClosed
         | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
     (wlid',opos,cpos) = head wlidOpCps
     wlpos   = _wlLine $ _walls w IM.! wlid'
@@ -101,6 +109,9 @@ plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w
         , _drStatus = DoorClosed
         , _drTrigger = cond
         , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
+        , _drPos = b
+        , _drOpenPos = shiftLeft b
+        , _drClosePos = b
         }
     addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs
     pairs = rectanglePairs 9 a b

src/Dodge/Room/GlassLesson.hs

@@ -24,22 +24,20 @@ glassLesson = do
     i <- takeOne [1,2,3]
     corridors <- replicateM i $ PassDown <$> shuffleLinks corridor
     return $ Node (PassDown botRoom) 
-        [ singleUseNone $ door & rmConnectsTo .~ S.singleton (LabLink 0)
+        [ singleUseNone $ door & rmConnectsTo .~ fromWest North 1
         , uppers
-        , treeFromPost (PassDown (door & rmConnectsTo .~ S.singleton (OnEdge East)) 
+        , treeFromPost (PassDown (door & rmConnectsTo .~ S.member (OnEdge East)) 
             : corridors) $ UseAll door]
   where 
-    uppers = Node (PassDown $ door & rmConnectsTo .~ S.singleton (LabLink 1)) 
+    fromWest edge i s = S.member (OnEdge edge) s && S.member (FromWest i) s
-        [singleUseNone $ setInLinksPD (onBottomEdgeLeft . fst) topRoom]
+    uppers = Node (PassDown $ door & rmConnectsTo .~ fromWest North 0)
-    botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1 
+        [singleUseNone topRoom]
-        & rmLinks %~ (setInLinksByType (OnEdge West)
+    botRoom = roomRect 200 200 1 1 
-            . addLabelLink 0 (onTopEdgeRight . _rlPos)
+        & rmPmnts .~ botplmnts 
-            . addLabelLink 1 (onTopEdgeLeft  . _rlPos)
+        & rmLinks %~ setInLinksByType (OnEdge West)
-            )
+    topRoom = roomRect 200 200 1 1
-    onTopEdgeRight (V2 x y) = x > 50 && y > 95
+        & rmPmnts .~ topplmnts
-    onTopEdgeLeft (V2 x y) = x < 50 && y > 95
+        & rmLinks %~ setInLinks (fromWest South 0 . _rlType)
-    onBottomEdgeLeft (V2 x y) = x < 50 && y < 5
-    topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1
     botplmnts = 
         [sPS    (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
         ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
@@ -59,4 +57,4 @@ glassLesson = do
 glassLessonRunPast :: RandomGen g => State g (SubCompTree Room)
 glassLessonRunPast = f <$> glassLesson
   where
-    f (Node r rs) = Node r $ return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton (OnEdge West)) : rs
+    f (Node r rs) = Node r $ return (UseLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs

src/Dodge/Room/LasTurret.hs

@@ -123,5 +123,5 @@ lasTunnelRunPast y = do
     r2 <- takeOne [door,corridor]
     return $ Node (PassDown r)
         [ singleUseAll r1
-        , return (UseLabel 0 $ r2 & rmConnectsTo .~ S.singleton InLink)
+        , return (UseLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
         ]

src/Dodge/Room/LongDoor.hs

@@ -148,5 +148,5 @@ slowDoorRoomRunPast = do
     r <- slowDoorRoom
     return $ treeFromTrunk [PassDown door] $ Node (PassDown r)
         [ singleUseAll door
-        , return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
+        , return (UseLabel 0 $ door & rmConnectsTo .~ S.member InLink)
         ]

src/Dodge/Room/LongRoom.hs

@@ -54,7 +54,7 @@ longRoomRunPast = do
         (Node (PassDown r)
             [ singleUseAll door
             --, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
-            , treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.singleton InLink, PassDown corridor] 
+            , treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink, PassDown corridor] 
                 (UseLabel 0 door)
             ]
         )

src/Dodge/Room/RezBox.hs

@@ -62,7 +62,7 @@ rezBoxesWp = do
         (Node (PassDown centralRoom) (rezrooms ++ [onwardpassage]))
   where
     adddoor rm = treeFromPost [PassDown $ connectsToNorth door ] (PassDown rm)
-    connectsToNorth = rmConnectsTo .~ S.singleton (OnEdge North)
+    connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
 maybeBlockedPassage :: RandomGen g => State g (SubCompTree Room)
 maybeBlockedPassage = fmap singleUseAll $ join $ takeOne [return corridor, blockedCorridorCloseBlocks]
 rezBoxesWpCrit :: RandomGen g => State g (SubCompTree Room)
@@ -75,7 +75,7 @@ rezBoxesWpCrit = do
         aroom = rezInvBox thecol
     let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []}
     onwardpassage <-
-        applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West)) <$> maybeBlockedPassage
+        applyToCompRoot (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage
     let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
     i <- state $ randomR (0,n-3)
     j <- state $ randomR (i,n-2)
@@ -88,7 +88,7 @@ rezBoxesWpCrit = do
         ]
         (Node (PassDown centralRoom) (rezrooms ++ [onwardpassage]))
   where
-    adddoor rm = treeFromPost [PassDown $ door & rmConnectsTo .~ S.singleton (OnEdge North)] (PassDown rm)
+    adddoor rm = treeFromPost [PassDown $ door & rmConnectsTo .~ S.member (OnEdge North)] (PassDown rm)
 
 crAdd :: Room -> Room
 crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
@@ -99,7 +99,7 @@ rezBoxes = do
     h <- state $ randomR (40,40)
     thecol <- rezColor
     let bottomEdgeTest = S.member (OnEdge South) . _rlType 
-        dbox = treeFromPost [PassDown $ door & rmConnectsTo .~ S.singleton (OnEdge South)] 
+        dbox = treeFromPost [PassDown $ door & rmConnectsTo .~ S.member (OnEdge South)] 
             (PassDown $ rezInvBox thecol)
     centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
             & rmLinks %~ setInLinks bottomEdgeTest

src/Dodge/Room/RunPast.hs

@@ -68,5 +68,5 @@ runPastRoom i = do
         critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) : 
             replicate (n-2) (treeFromPost [PassDown switchdoor] (PassDown linkcor))
     return $ Node (PassDown cenroom) $ 
-        map (applyToCompRoot $ rmConnectsTo .~ S.singleton (OnEdge theedge)) (controom : critrooms) 
+        map (applyToCompRoot $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms) 
             ++ [return $ PassDown aswitchroom]

src/Dodge/Tree/Shift.hs

@@ -14,7 +14,7 @@ import Padding
 import LensHelp hiding (Empty, (<|) , (|>))
 --import Control.Lens hiding (Empty, (<|) , (|>))
 
-import qualified Data.Set as S
+--import qualified Data.Set as S
 import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
@@ -43,7 +43,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
   where
     child = fst childi
     outlinks = zipCount
-        . Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType) 
+        . Prelude.filter (_rmConnectsTo child . _rlType) 
         $ _rmLinks parent
     tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
     tryParentLinks ((j,outlnk):ls) = tryChildLinks . zipCount . rmInLinks $ fst childi

src/Dodge/Wall/Move.hs

@@ -3,6 +3,7 @@ module Dodge.Wall.Move
     ( moveWallID
     , moveWall
     , moveWallIDToward
+    , mvP
     ) where
 import Dodge.Data
 import Dodge.Base