Continue major door/wall refactor

src/Dodge/LevelGen/TriggerDoor.hs

@@ -45,6 +45,19 @@ addButtonDoor c btp btr a b speed w
              . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
     f (x,y) = (x,y,dist x y)
 
+putDoor' 
+    :: Color 
+    -> (World -> Bool)      -- ^ Opening condition
+    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
+                    -- Bumped out up and down by 9, not widened
+    -> World 
+    -> World
+putDoor' c cond pss = over walls triggerDoor
+  where
+    triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
+      where
+        is = [IM.newKey wls..]
+
 putDoor 
     :: Color 
     -> (World -> Bool)      -- ^ Opening condition
@@ -52,11 +65,50 @@ putDoor
                     -- Bumped out up and down by 9, not widened
     -> World 
     -> World
-putDoor c cond pss = over walls triggerDoor
+putDoor col cond pss w = addWalls w
+    & doors %~ addDoor
   where
-    triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
+    drid = IM.newKey $ _doors w
+    addDoor = IM.insert drid $ Door'
+        { _drID = drid
+        , _drWallIDs = wlids
+        , _drStatus = DoorInt 0
+        , _drTrigger = cond
+        , _drMech   = doorMechanismStepwise nsteps drid wlids pss
+        }
+    nsteps = length pss - 1
+    wlids = take 4 [IM.newKey $ _walls w ..]
+    wlps = uncurry (rectanglePairs 9) $ head pss
+    addWalls w' = foldl' addWall w' $ zip wlids wlps
+    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall
+        { _wlLine = wlps
+        , _wlID = wlid
+        , _wlColor = col
+        , _wlSeen = False
+        , _wlIsSeeThrough = False
+        , _wlPathable = False
+        }
+-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
+-- 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 
+    | toOpen = case _drStatus dr of
+        DoorInt x | x == nsteps -> w
+        DoorInt x      -> setWalls (x+1)
+    | otherwise = case _drStatus dr of
+        DoorInt 0 -> w
+        DoorInt x -> setWalls (x-1)
+  where
+    playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
+    toOpen = _drTrigger dr w
+    setWalls n = (playSound $ foldl' setWall w (zip wlids newps))
+        & doors . ix drid . drStatus .~ DoorInt n
       where
-        is = [IM.newKey wls..]
+        newps = uncurry (rectanglePairs 9) (pss !! n)
+    setWall w' (wlid,ps) = w & walls . ix wlid . wlLine .~ ps
+        & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps ps)) 
+-- it is not at all clear that the zoning selects the correct walls
+
 
 putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
 putDoubleDoor isPathable col cond a b speed 
@@ -65,13 +117,7 @@ putDoubleDoor isPathable col cond a b speed
   where
     c = 0.5 *.* (a +.+ b)
 
-putDoubleDoor' :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
-putDoubleDoor' c cond a b speed = over walls triggerDoubleDoor
-  where
-    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b speed is
-      where
-        is = [IM.newKey wls..]
-
+-- TODO think about wall zoning, simplify!
 doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World
 doorMechanism drid speed wlidOpCps dr w 
     | toOpen && not (dstatus == DoorOpen) = playSound . setStatus $ foldl' doOpen  w wlidOpCps