Refactor doors

src/Dodge/Data.hs

@@ -59,6 +59,7 @@ data World = World
     , _props                :: IM.IntMap Prop
     , _particles            :: ![Particle]
     , _walls                :: !(IM.IntMap Wall)
+    , _doors                :: IM.IntMap Door'
     , _wallsZone            :: Zone (IM.IntMap Wall)
     , _forceFields          :: IM.IntMap ForceField
     , _floorItems           :: IM.IntMap FloorItem
@@ -237,6 +238,7 @@ data CrMvType
         }
 data WorldState 
     = DoorNumOpen Int 
+    | DoorNumOpening Int
     | CrNumAlive Int
   deriving (Eq,Ord)
 data Button = Button 
@@ -529,7 +531,15 @@ data Prop
         , _pjTimer :: Int
         }
 data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
-
+data Door' = Door'
+    { _drID :: Int
+    , _drWallIDs :: [Int]
+    , _drStatus  :: DoorStatus
+    , _drTrigger :: World -> Bool
+    , _drMech    :: Door' -> World -> World
+    }
+data DoorStatus = DoorOpen | DoorClosed | DoorHalfway
+  deriving (Eq, Ord, Show)
 data Wall 
     = Wall 
         { _wlLine :: (Point2,Point2) 
@@ -537,6 +547,7 @@ data Wall
         , _wlColor :: Color
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
+        , _wlPathable :: Bool
         }
     | BlockAutoDoor 
         { _wlLine :: (Point2,Point2) 
@@ -761,6 +772,7 @@ makeLenses ''Action
 makeLenses ''CrGroupParams
 makeLenses ''CrMvType 
 makeLenses ''Intention
+makeLenses ''Door'
 numColor :: Int -> Color
 numColor 0  = toV4 (1,0,0,1) 
 numColor 1  = toV4 (0,1,0,1) 

src/Dodge/Default/Wall.hs

@@ -12,6 +12,7 @@ defaultWall = Wall
     , _wlColor = greyN 0.6
     , _wlSeen = False
     , _wlIsSeeThrough = False
+    , _wlPathable = False
     }
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
@@ -21,6 +22,7 @@ defaultCrystalWall = Wall
     , _wlColor = withAlpha 0.5 aquamarine
     , _wlSeen = False
     , _wlIsSeeThrough = True
+    , _wlPathable = False
     }
 {- Door that opens on approach.
 Pathable.  -}

src/Dodge/Default/World.hs

@@ -36,6 +36,7 @@ defaultWorld = World
     , _props = IM.empty
     , _particles = []
     , _walls = IM.empty
+    , _doors = IM.empty
     , _wallsZone = Zone IM.empty
     , _forceFields = IM.empty
     , _floorItems = IM.empty

src/Dodge/LevelGen.hs

@@ -83,18 +83,15 @@ placeSpot ps w = case _psType ps of
       where 
         mapBoth fn (x,y) = (fn x, fn y) 
     PutDoubleDoor col f a b speed 
-        -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
+        -> putDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
     PutSingleDoor col f a b speed 
-        -> putSingleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
+        -> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
     PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
     PutBlock{} -> error "messed up block placement somehow"
     PutBtDoor c bp f a b speed 
         -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                             (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
-    PutSwitchDoor c bp f a b speed 
-        -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) 
-                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
     PutLineBlock wl width depth a b
         -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w

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) = wlLine %~ mvPs speed (ex,ey)
---moveDoorToward !speed !(!ex,!ey) wls = wls & wlLine %~ bimap (f ex) (f ey)
---  where
---    f !p = mvPointTowardAtSpeed speed p
 
 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 :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
-putDoubleDoor c cond a b speed = over walls triggerDoubleDoor
+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
+doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World
-putSingleDoor c cond a b speed = over walls putTheDoor
+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
+    playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
-      where
+    setStatus
-        is = [IM.newKey wls..]
+        | 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 

src/Dodge/Room/LongDoor.hs

@@ -31,7 +31,7 @@ twinSlowDoorRoom
     -> Float    -- ^ Half height
     -> Float    -- ^ Inner width
     -> Room
-twinSlowDoorRoom drID w h x = defaultRoom
+twinSlowDoorRoom drid w h x = defaultRoom
     { _rmPolys  = ps
     , _rmLinks  =
         [ (V2 w (h/2) , negate $ pi/2)
@@ -46,10 +46,10 @@ twinSlowDoorRoom drID w h x = defaultRoom
         , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2   x  1) (V2   x  h) 1
         , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1
         , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red
-            (over worldState (M.insert (DoorNumOpen drID) True))
+            (worldState %~ M.insert (DoorNumOpen drid) True )
-            (over worldState (M.insert (DoorNumOpen drID) False))
+            (worldState %~ M.insert (DoorNumOpen drid) False)
---        , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
+        , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
---        , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight
+        , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight
         ]
     , _rmBound  = ps
     , _rmName   = "twinSlowDoorRoom"
@@ -60,7 +60,7 @@ twinSlowDoorRoom drID w h x = defaultRoom
         [rectNSWE h    0 (-w) w
         ,rectNSWE 20 (-h) (negate x) x
         ]
-    cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w')
+    cond w' = or $ M.lookup (DoorNumOpen drid) (_worldState w')
     col = dim $ dim $ bright red
 
 twinSlowDoorChasers 
@@ -104,7 +104,6 @@ slowDoorRoom = do
      let cond x'  = (sndV2 . fst) x' > h + 40
          cond2 x' = (sndV2 . fst) x' < h - 40
      but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2
-                  --  ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
                     ]
      fmap connectRoom 
         (filterLinks cond =<< 

src/Dodge/Room/NoNeedWeapon.hs

@@ -27,7 +27,7 @@ centerVaultExplosiveExit
     :: RandomGen g 
     => Int      -- ^ Door id
     -> State g Room
-centerVaultExplosiveExit drID = do
+centerVaultExplosiveExit drid = do
     cr <- takeOne [miniGunCrit, autoCrit]
     let extraPS = 
             [sPS (V2 0 175) 0 $ PutCrit explosiveBarrel
@@ -36,5 +36,5 @@ centerVaultExplosiveExit drID = do
             ,sPS (V2 (-4) 195) 0 $ PutCrit explosiveBarrel
             ,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
             ]
-    r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++)
+    r <- centerVaultRoom drid 200 200 50 <&> rmPS %~ (extraPS ++)
     randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2

src/Dodge/Update.hs

@@ -61,6 +61,7 @@ functionalUpdate w = case _menuLayers w of
         . ifConfigWallRotate
         . simpleCrSprings 
         . zoneCreatures 
+        . updateDoors
         . updateWalls
         . resetWorldEvents
         . dbArg _worldEvents
@@ -147,6 +148,9 @@ Apply door mechanisms.  -}
 updateWalls :: World -> World
 updateWalls w = IM.foldl' (flip $ fromMaybe id . (^? doorMech)) w (_walls w)
 
+updateDoors :: World -> World
+updateDoors w = IM.foldl' (\w' dr -> _drMech dr dr w') w (_doors w)
+
 ppEvents :: World -> World
 ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w
 

src/Shader/Poke.hs

@@ -166,7 +166,7 @@ topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
     ++ concatMap g [0..n-2]                 -- other triangles on sides
   where
     f x = [0,2*x,2*x+2]
-    f' x = [1,2*x+1,2*x+3]
+    f' x = [1,2*x+3,2*x+1]
     g x = [2*x,2*x+1,2*x+3
             ,2*x,2*x+3,2*x+2]