Add airlocks

2021-05-02 21:09:25 +02:00
parent 9cdd3a9629
commit f336d7e3f6
27 changed files with 522 additions and 219 deletions
@@ -10,6 +10,7 @@ import Dodge.SoundLogic
 import Dodge.Creature.Property
 import Geometry
 import Picture
+import qualified DoubleStack as DS

 import Data.List
 import Data.Maybe
@@ -85,6 +86,7 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
    , _wlSeen = False
    , _wlIsSeeThrough = False
    , _doorPathable = True
+    , _drPositions = DS.singleton closedPos
    }
  where 
    a = closedPos !! 0
@@ -17,7 +17,8 @@ data PSType = PutCrit Creature
    | PutAutoDoor Point2 Point2
    | PutBlock [Int] Color [Point2]
    | PutLineBlock Wall Float Float Point2 Point2
-    | PutTriggerDoor Color (World -> Bool) Point2 Point2
+    | PutDoubleDoor Color (World -> Bool) Point2 Point2
+    | PutDoor Color (World -> Bool) [(Point2,Point2)]
    | PutBtDoor Color Point2 Float Point2 Point2
    | PutSwitchDoor Color Point2 Float Point2 Point2
    | RandPS (State StdGen PSType)
@@ -6,17 +6,15 @@ import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Pathing
-
 import Picture
 import Geometry
+import qualified DoubleStack as DS

 import Data.List
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
-
 import Control.Lens
 import Control.DeepSeq (deepseq)
-
 import Data.Graph.Inductive hiding ((&))
 import Data.Graph.Inductive.NodeMap

@@ -26,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
    $ set pathGraph newGraph
    $ set pathGraph' newGraphPairs
-    $ addTriggerDoor c cond a b w
+    $ putDoubleDoor c cond a b w
  where 
    bid = newKey $ _buttons w
    cond w = BtNoLabel == _btState (_buttons w IM.! bid)
@@ -44,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
    $ set pathGraph newGraph
    $ set pathGraph' newGraphPairs
-    $ addTriggerDoor c cond a b w
+    $ putDoubleDoor c cond a b w
  where 
    bid = newKey $ _buttons w
    cond w = BtOn == _btState (_buttons w IM.! bid)
@@ -59,17 +57,48 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
    closeDoor w' = over pathGraph' (\\ removedPairs)
                  . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'

-addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
-addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)

-triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
-  where 
-    i = newKey wls
-    is = [i..]
+putDoor 
+    :: Color 
+    -> (World -> Bool) 
+    -> [(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 = [newKey wls..]

-mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
-mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
+putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
+putDoubleDoor c cond a b = over walls triggerDoubleDoor
+  where
+    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
+      where
+        is = [newKey wls..]
+
+mkTriggerDoor 
+    :: Color 
+    -> (World -> Bool)      -- ^ Opening condition
+    -> [(Point2,Point2)]    -- ^ List of wall position pairs, closed to open
+    -> [Int]                -- ^ Wall ids
+    -> [Wall]
+mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
+    transpose $ map toPanePoints ppairs
+
+toPanePoints :: (Point2,Point2) -> [[Point2]]
+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))
+
+mkTriggerDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
+mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear c cond)
    xs
    (leftDoor ++ rightDoor)
    (map shiftLeft leftDoor ++ map shiftRight rightDoor)
@@ -106,8 +135,14 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
      where 
        wp = _wlLine (_walls w IM.! head xs) !! 1

-triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
-triggerDoorPane c cond n closedPos openPos = Door
+triggerDoorPaneLinear
+    :: Color 
+    -> (World -> Bool)  -- ^ Opening condition
+    -> Int              -- ^ Wall id
+    -> [Point2]         -- ^ Closed position
+    -> [Point2]         -- ^ Open position
+    -> Wall
+triggerDoorPaneLinear c cond n closedPos openPos = Door
    { _wlLine = closedPos
    , _wlID = n
    , _doorMech = dm
@@ -115,6 +150,7 @@ triggerDoorPane c cond n closedPos openPos = Door
    , _wlSeen = False
    , _wlIsSeeThrough = False
    , _doorPathable = False
+    , _drPositions = DS.singleton closedPos
    }
  where 
    a = closedPos !! 0
@@ -135,3 +171,40 @@ triggerDoorPane c cond n closedPos openPos = Door
          = over wallsZone $ adjustIMZone openDoor x y n
    changeZonedWall' (!x,!y) 
          = over wallsZone $ adjustIMZone closeDoor x y n
+
+{- |
+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]]       -- ^ 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 w | cond w    = flip (foldr changeZonedWall) allZoneps
+                       $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
+         | otherwise = flip (foldr changeZonedWall') allZoneps
+                       $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
+    openDoor  = updatePos . (drPositions %~ DS.pushL)
+    closeDoor = updatePos . (drPositions %~ DS.pushR)
+    updatePos :: Wall -> Wall
+    updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
+    changeZonedWall (!x,!y) 
+          = over wallsZone $ adjustIMZone openDoor x y n
+    changeZonedWall' (!x,!y) 
+          = over wallsZone $ adjustIMZone closeDoor x y n
+    allZoneps = nub $ concatMap zoneps poss
+    zoneps [a,b]
+        | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+        | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b