Unify more doors

src/Dodge/LevelGen/Data.hs

@@ -17,13 +17,11 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutProp Prop
     | PutFlIt Item
     | PutPressPlate PressPlate
-   -- | PutAutoDoor Point2 Point2
     | PutBlock [Int] Color [Point2]
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
-    | PutSingleDoor Color (World -> Bool) Point2 Point2 Float
+    | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
-    | PutBtDoor Color Point2 Float Point2 Point2 Float
     | RandPS (State StdGen PSType)
     | PutForeground Shape
     | PutNothing

src/Dodge/LevelGen/TriggerDoor.hs

@@ -1,15 +1,15 @@
 --{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.TriggerDoor
     ( putDoor
-    , placeSingleDoor
-    , addButtonDoor
+    , placeSlideDoor
+    --, addButtonDoor
     ) where
 import Dodge.Data
-import Dodge.Base
-import Dodge.Zone
+--import Dodge.Base
+--import Dodge.Zone
 import Dodge.Default.Wall
-import Dodge.LevelGen.Switch
-import Dodge.LevelGen.Pathing
+--import Dodge.LevelGen.Switch
+--import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.MoveDoor
 import Dodge.LevelGen.DoorPane
 import Picture
@@ -20,32 +20,10 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Data.SoundOrigin
 
 import Data.List
-import Data.Maybe
+--import Data.Maybe
 import Control.Lens
-import Data.Graph.Inductive hiding ((&))
+--import Data.Graph.Inductive hiding ((&))
 import qualified Data.IntSet as IS
-
--- probably don't have to rebuild the entire graph, oh well
-addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
-addButtonDoor c btp btr a b speed w 
-    = (,) 0
-    . over buttons (IM.insert bid bt) 
-    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
-    $ set pathGraph newGraph
-    $ set pathGraphP newGraphPairs
-    $ snd (placeSingleDoor False c cond a b speed w)
-  where 
-    bid = IM.newKey $ _buttons w
-    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
-    bt = (makeButton c eff) {_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]
-    eff w' = over pathGraphP (removedPairs ++) 
-             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
-    f (x,y) = (x,y,dist x y)
-
 putDoor 
     :: Color 
     -> (World -> Bool)      -- ^ Opening condition
@@ -122,10 +100,10 @@ doorMechanism drid speed wlidOpCps dr w
         & walls . ix wlid %~ moveDoorToward speed p
         & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))
 
-placeSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
+-- TODO cut pathing if not pathable, reset when opened
+placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
     -> (Int, World)
-placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w 
-    & doors %~ addDoor)
+placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors w
     addDoor = IM.insert drid $ Door
@@ -148,3 +126,25 @@ placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w
     shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
     shiftLeft  = (+.+ (a -.- b))
     wlids = take 4 [IM.newKey $ _walls w ..]
+-- old code that may help with pathing
+--import Dodge.LevelGen.Pathing
+--import Data.Graph.Inductive hiding ((&))
+--addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
+--addButtonDoor c btp btr a b speed w 
+--    = (,) 0
+--    . over buttons (IM.insert bid bt) 
+--    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+--    $ set pathGraph newGraph
+--    $ set pathGraphP newGraphPairs
+--    $ snd (placeSlideDoor False c cond a b speed w)
+--  where 
+--    bid = IM.newKey $ _buttons w
+--    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
+--    bt = (makeButton c eff) {_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]
+--    eff w' = over pathGraphP (removedPairs ++) 
+--             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+--    f (x,y) = (x,y,dist x y)