Continue major door/wall refactor

src/Dodge/Data.hs

@@ -538,7 +538,7 @@ data Door' = Door'
     , _drTrigger :: World -> Bool
     , _drMech    :: Door' -> World -> World
     }
-data DoorStatus = DoorOpen | DoorClosed | DoorHalfway
+data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)
 data Wall 
     = Wall 

src/Dodge/LevelGen/AutoDoor.hs

@@ -9,7 +9,6 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.Creature.Property
 --import Dodge.LevelGen.MoveDoor
-import Dodge.LevelGen.DoorPane
 import Dodge.LevelGen.TriggerDoor
 --import Geometry
 import Picture
@@ -17,10 +16,6 @@ import Geometry.Data
 --import qualified DoubleStack as DS
 import qualified IntMapHelp as IM
 
---import Data.List
---import Data.Maybe
-import Control.Lens
---import Control.DeepSeq (deepseq)
 
 addAutoDoor 
     :: Point2   -- ^ Left point
@@ -30,28 +25,3 @@ addAutoDoor
 addAutoDoor a b = putDoubleDoor True (dim yellow) cond a b 3
   where
     cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures
-
-addAutoDoor' 
-    :: Point2   -- ^ Left point
-    -> Point2   -- ^ Right point (though the two points should be symmetric)
-    -> World 
-    -> World
-addAutoDoor' a b = over walls (autoDoorAt a b)
-
-autoDoorAt 
-    :: Point2   -- ^ Left point
-    -> Point2   -- ^ Right point (though the two points should be symmetric)
-    -> IM.IntMap Wall 
-    -> IM.IntMap Wall
-autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
-  where 
-    is = [IM.newKey wls..]
-
-mkAutoDoor 
-    :: Point2   -- ^ Left point
-    -> Point2   -- ^ Right point (though the two points should be symmetric)
-    -> [Int]    -- ^ Wall ids
-    -> [Wall]
-mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr 3
-  where
-    cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures

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