Refactor doors

src/Dodge/LevelGen/AutoDoor.hs

@@ -10,6 +10,7 @@ import Dodge.Base
 import Dodge.Creature.Property
 --import Dodge.LevelGen.MoveDoor
 import Dodge.LevelGen.DoorPane
+import Dodge.LevelGen.TriggerDoor
 --import Geometry
 import Picture
 import Geometry.Data
@@ -26,7 +27,16 @@ addAutoDoor
     -> Point2   -- ^ Right point (though the two points should be symmetric)
     -> World 
     -> World
-addAutoDoor a b = over walls (autoDoorAt a b)
+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

src/Dodge/LevelGen/Data.hs

@@ -39,7 +39,6 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutSingleDoor Color (World -> Bool) Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | PutBtDoor Color Point2 Float Point2 Point2 Float
-    | PutSwitchDoor Color Point2 Float Point2 Point2 Float
     | RandPS (State StdGen PSType)
     | PutForeground Shape
     | PutNothing

src/Dodge/LevelGen/DoorPane.hs

@@ -2,6 +2,7 @@ module Dodge.LevelGen.DoorPane
     ( linearPane
     , mkDoubleDoor
     , mkSingleDoor
+    , rectanglePairs
     ) where
 import Dodge.Data
 import Dodge.LevelGen.MoveDoor

src/Dodge/LevelGen/MoveDoor.hs

@@ -4,6 +4,7 @@ module Dodge.LevelGen.MoveDoor
     , zoneps
     , moveDoorToward
     , addSoundToDoor
+    , changeZonedWall
     ) where
 import Dodge.Data
 import Dodge.Data.SoundOrigin
@@ -28,10 +29,7 @@ mvPs !speed (!ex,!ey) (!sx,!sy) = (mvP speed ex sx,mvP speed ey sy)
 
 moveDoorToward :: Float -> (Point2,Point2) -> Wall -> Wall
 {-# INLINE moveDoorToward #-}
-moveDoorToward speed (ex,ey) wls = wls & wlLine %~ mvPs speed (ex,ey)
---moveDoorToward !speed !(!ex,!ey) wls = wls & wlLine %~ bimap (f ex) (f ey)
---  where
---    f !p = mvPointTowardAtSpeed speed p
+moveDoorToward speed (ex,ey) = wlLine %~ mvPs speed (ex,ey)
 
 zoneps :: (Point2, Point2) -> [(Int,Int)]
 {-# INLINE zoneps #-}

src/Dodge/LevelGen/TriggerDoor.hs

@@ -4,7 +4,6 @@ module Dodge.LevelGen.TriggerDoor
     , putDoubleDoor
     , putSingleDoor
     , addButtonDoor
-    , addSwitchDoor
     ) where
 import Dodge.Data
 import Dodge.Base
@@ -17,6 +16,9 @@ import Picture
 import Geometry
 import qualified DoubleStack as DS
 import qualified IntMapHelp as IM
+import Dodge.SoundLogic
+import Dodge.SoundLogic.LoadSound
+import Dodge.Data.SoundOrigin
 
 import Data.List
 import Data.Maybe
@@ -30,7 +32,7 @@ addButtonDoor c btp btr a b speed w
     $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
     $ set pathGraph newGraph
     $ set pathGraphP newGraphPairs
-    $ putDoubleDoor c cond a b speed w
+    $ putDoubleDoor False c cond a b speed w
   where 
     bid = IM.newKey $ _buttons w
     cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
@@ -42,26 +44,6 @@ addButtonDoor c btp btr a b speed w
     eff w' = over pathGraphP (removedPairs ++) 
              . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
     f (x,y) = (x,y,dist x y)
--- this has been repeated at least three times: TO BE UNIFIED, REFACTORED
-addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World
-addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt) 
-    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
-    $ set pathGraph newGraph
-    $ set pathGraphP newGraphPairs
-    $ putDoubleDoor c cond a b speed w
-  where 
-    bid = IM.newKey $ _buttons w
-    cond w' = BtOn == _btState (_buttons w' IM.! bid)
-    bt = (makeSwitch c red openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
-    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
-                                             $ _pathGraphP w
-    newGraph = pairsToGraph dist newGraphPairs
-    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-    openDoor w' = over pathGraphP (removedPairs ++) 
-                  . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
-    f (x,y) = (x,y,dist x y)
-    closeDoor w' = over pathGraphP (\\ removedPairs)
-                  . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
 
 putDoor 
     :: Color 
@@ -76,19 +58,68 @@ putDoor c cond pss = over walls triggerDoor
       where
         is = [IM.newKey wls..]
 
-putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
-putDoubleDoor c cond a b speed = over walls triggerDoubleDoor
+putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
+putDoubleDoor isPathable col cond a b speed 
+    = putSingleDoor isPathable col cond a c speed 
+    . putSingleDoor isPathable col cond b c 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..]
 
-putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
-putSingleDoor c cond a b speed = over walls putTheDoor
+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
+    | otherwise = w
   where
-    putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b speed is
-      where
-        is = [IM.newKey wls..]
+    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
+    (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
+    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))
+
+putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
+putSingleDoor isPathable col cond a b speed w = addWalls w 
+    & doors %~ addDoor
+  where
+    drid = IM.newKey $ _doors w
+    addDoor = IM.insert drid $ Door'
+        { _drID = drid
+        , _drWallIDs = wlids
+        , _drStatus = DoorClosed
+        , _drTrigger = cond
+        , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
+        }
+    addWalls w' = foldl' addWall w' $ zip wlids pairs
+    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall
+        { _wlLine = wlps
+        , _wlID = wlid
+        , _wlColor = col
+        , _wlSeen = False
+        , _wlIsSeeThrough = False
+        , _wlPathable = isPathable
+        }
+    pairs = rectanglePairs 9 a b
+    shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
+    shiftLeft  = (+.+ (a -.- b))
+    wlids = take 4 [IM.newKey $ _walls w ..]
 
 mkTriggerDoor 
     :: Color