Move toward moving lights on doors

src/Dodge/Data.hs

@@ -739,9 +739,9 @@ data Door = Door
     , _drStatus  :: DoorStatus
     , _drTrigger :: World -> Bool
     , _drMech    :: Door -> World -> World
-    , _drPos :: Point2
+    , _drPos :: (Point2,Point2)
-    , _drOpenPos :: Point2
+    , _drOpenPos :: (Point2,Point2)
-    , _drClosePos :: Point2
+    , _drClosePos :: (Point2,Point2)
     }
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)

src/Dodge/Placement/Instance/Door.hs

@@ -15,12 +15,16 @@ import Dodge.LevelGen.Switch
 import qualified Data.IntMap.Strict as IM
 
 putDoubleDoor :: Bool -> Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
-putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
+putDoubleDoor pathing col cond a b speed 
+    = putDoubleDoorThen pathing col cond a b speed (const $ const Nothing)
 
 putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
-    -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
+    -> Point2 -> Point2 -> Float 
-putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDr pathing col cond a half speed)
+    -> (Placement -> Placement -> Maybe Placement)
-    $ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing $ const mayp
+    -> Placement
+putDoubleDoorThen pathing col cond a b speed cont = pt0 (PutSlideDr pathing col cond a half speed)
+    $ \pl1 -> Just $ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing 
+    $ \pl2 -> cont pl1 pl2
   where
     half = 0.5 *.* (a +.+ b)
 

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -33,12 +33,10 @@ 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
+        , _drPos = head pss
-        , _drOpenPos = openp
+        , _drOpenPos = head pss
-        , _drClosePos = closep
+        , _drClosePos = last pss
         }
-    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
@@ -56,6 +54,8 @@ addDoorWall col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defau
 -- 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
+-- perhaps only store intermediate door pos pairs, calculate all wall positions
+-- on the fly
 doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
 doorMechanismStepwise nsteps drid wlids pss dr w 
     | toOpen = case _drStatus dr of
@@ -78,19 +78,20 @@ 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)
+        & doors . ix drid . drPos %~ mvPs speed (_drOpenPos dr)
     | not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
-        & doors . ix drid . drPos %~ mvP speed (_drClosePos dr)
+        & doors . ix drid . drPos %~ mvPs speed (_drClosePos dr)
     | otherwise = w
   where
     moveUpdate = playSound . setStatus
-    playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
+    playSound = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
+    dpos = snd $ _drPos dr
+    dop = snd $ _drOpenPos dr
+    dcp = snd $ _drClosePos dr
     setStatus
-        | dist (_drPos dr) (_drOpenPos dr) < 1 = doors . ix drid . drStatus .~ DoorOpen
+        | dist dpos dop < 1 = doors . ix drid . drStatus .~ DoorOpen
-        | dist (_drPos dr) (_drClosePos dr) < 1 = doors . ix drid . drStatus .~ DoorClosed
+        | dist dpos dcp < 1 = doors . ix drid . drStatus .~ DoorClosed
         | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
-    (wlid',opos,cpos) = head wlidOpCps
-    wlpos   = _wlLine $ _walls w IM.! wlid'
     toOpen  = _drTrigger dr w
     dstatus = _drStatus dr
     doOpen  w' (wlid,opp, _) = moveWallIDToward wlid speed opp w'
@@ -109,9 +110,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
+        , _drPos = (a,b)
-        , _drOpenPos = shiftLeft b
+        , _drOpenPos = (shiftLeft a,shiftLeft b)
-        , _drClosePos = b
+        , _drClosePos = (a,b)
         }
     addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs
     pairs = rectanglePairs 9 a b

src/Dodge/Room/Airlock.hs

@@ -29,7 +29,7 @@ airlock0 = defaultRoom
     , _rmPmnts    = 
         [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
             $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
-                $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
+                $ \_ _ -> Just $ putDoubleDoor False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2
         ,spanLightI (V2 (-2) 30) (V2 (-2) 70)
         ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
         ]

src/Dodge/Room/LongDoor.hs

@@ -117,7 +117,8 @@ addButtonSlowDoor x h rm = do
     belowH y = (sndV2 . fst) y < h - 40
     aboveH y = (sndV2 . fst) y > h + 40
     butDoor _ _ = putLitButOnPos col butPosCond
-        $  \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
+        $  \btid -> Just $ putDoubleDoorThen False col (cond' btid) (V2 0 h) (V2 x h) 2
+        $ \dr1 dr2 -> Nothing
     butPosCond (UnusedLink (V2 x' y') a' _) _ | y' < 0.5 * h 
                 = Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink))
     butPosCond _ _ = Nothing

src/Dodge/Wall/Move.hs

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