Commit before placement refactor

src/Dodge/LevelGen/TriggerDoor.hs

@@ -14,7 +14,6 @@ import Dodge.LevelGen.MoveDoor
 import Dodge.LevelGen.DoorPane
 import Picture
 import Geometry
-import qualified DoubleStack as DS
 import qualified IntMapHelp as IM
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
@@ -45,19 +44,6 @@ 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
@@ -78,8 +64,8 @@ putDoor col cond pss w = addWalls w
         }
     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
+    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
@@ -95,18 +81,21 @@ doorMechanismStepwise nsteps drid wlids pss dr w
     | toOpen = case _drStatus dr of
         DoorInt x | x == nsteps -> w
         DoorInt x      -> setWalls (x+1)
+        _ -> w
     | otherwise = case _drStatus dr of
         DoorInt 0 -> w
         DoorInt x -> setWalls (x-1)
+        _ -> w
   where
     playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
     toOpen = _drTrigger dr w
-    setWalls n = (playSound $ foldl' setWall w (zip wlids newps))
+    cpss = uncurry (rectanglePairs 9) (head pss)
+    setWalls n = (playSound $ foldl' setWall w (zip3 wlids newps cpss))
         & doors . ix drid . drStatus .~ DoorInt n
       where
         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)) 
+    setWall w' (wlid,ps,cps) = w' & walls . ix wlid . wlLine .~ ps
+        & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps cps)) 
 -- it is not at all clear that the zoning selects the correct walls
 
 
@@ -120,26 +109,25 @@ putDoubleDoor isPathable col cond a b speed
 -- 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
-    | not toOpen && not (dstatus == DoorClosed) = playSound . setStatus $ foldl' doClose w wlidOpCps
+    | toOpen     && dstatus /= DoorOpen   = moveUpdate $ foldl' doOpen  w wlidOpCps
+    | not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
     | otherwise = w
   where
+    moveUpdate = playSound . setStatus
     playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
     setStatus
-        | isOpen    = doors . ix drid . drStatus .~ DoorOpen
-        | isClosed  = doors . ix drid . drStatus .~ DoorClosed
-        | otherwise = doors . ix drid . drStatus .~ DoorHalfway
+        | dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
+        | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
+        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
     (wlid',opos,cpos) = head wlidOpCps
     wlpos    = _wlLine $ _walls w IM.! wlid'
-    isOpen   = dist (fst wlpos) (fst opos) < 1
-    isClosed = dist (fst wlpos) (fst cpos) < 1
-    toOpen = _drTrigger dr w
+    toOpen  = _drTrigger dr w
     dstatus = _drStatus dr
-    doOpen w'  (wlid,openpos,cp) = w' 
-        & walls . ix wlid %~ moveDoorToward speed openpos
-        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed openpos) wlid) w'' (zoneps cp))
-    doClose w' (wlid,_,cp) = w' & walls . ix wlid %~ moveDoorToward speed cp
-        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed cp) wlid) w'' (zoneps cp))
+    doOpen  w' (wlid,openpos,cp) = mvDoorWithZone w' wlid openpos cp
+    doClose w' (wlid,_,cp)       = mvDoorWithZone w' wlid cp      cp
+    mvDoorWithZone w' wlid p zp = w'
+        & walls . ix wlid %~ moveDoorToward speed p
+        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))
 
 putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
 putSingleDoor isPathable col cond a b speed w = addWalls w 
@@ -167,49 +155,3 @@ putSingleDoor isPathable col cond a b speed w = addWalls w
     shiftLeft  = (+.+ (a -.- b))
     wlids = take 4 [IM.newKey $ _walls w ..]
 
-mkTriggerDoor 
-    :: Color 
-    -> (World -> Bool)      -- ^ Opening condition
-    -> [(Point2,Point2)]    -- ^ List of wall position pairs, closed to open
-    -> [Int]                -- ^ Wall ids
-    -> [Wall]
-{-# INLINE mkTriggerDoor #-}
-mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
-    transpose $ map toPanePoints ppairs
-
-toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
-{-# INLINE toPanePoints #-}
-toPanePoints (x,y) = 
-    [ (y +.+ perp, y -.- perp)
-    , (y -.- perp, x -.- perp)
-    , (x -.- perp, x +.+ perp)
-    , (x +.+ perp, y +.+ perp)
-    ]
-  where
-    perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
-{- |
-Zoning might be an issue here.
-It is necessary in the current version, but I am not sure of its behaviour. -}
-triggerDoorPane
-    :: Color 
-    -> (World -> Bool)      -- ^ Opening condition
-    -> Int                  -- ^ Wall id
-    -> [(Point2,Point2)]    -- ^ List of positions: closed to open
-    -> Wall
-triggerDoorPane c cond n poss = Door
-    { _wlLine = head poss
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = c
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = False
-    , _drPositions = DS.fromListL poss
-    }
-  where 
-    dm = doorMechan n allZoneps openDoor closeDoor cond 
-    openDoor  = updatePos . (drPositions %~ DS.pushL)
-    closeDoor = updatePos . (drPositions %~ DS.pushR)
-    updatePos :: Wall -> Wall
-    updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
-    allZoneps = nub $ concatMap zoneps poss