justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Unify more doors

Browse Source
This commit is contained in:
justin
2021-11-02 11:04:23 +00:00
parent 7ef1da9be5
commit 9eda8c81a9
9 changed files with 72 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+5
View File
@@ -35,6 +35,11 @@ initialRoomTree = do
t = treeFromTrunk
[[StartRoom]
,[Corridor]
,[Corridor]
,[SpecificRoom slowDoorRoom ]
,[Corridor]
,[Corridor]
,[Corridor]
,[SpecificRoom roomCCrits]
,[Corridor]
,[AirlockAno]
src/Dodge/LevelGen.hs
+3 -8
View File
@@ -54,16 +54,11 @@ placeSpotID ps w = case _psType ps of
RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w
where
mapBoth fn (x,y) = (fn x, fn y)
PutSingleDoor col f a b speed
-> placeSingleDoor False col f (doShift a) (doShift b) speed w
--PutAutoDoor a b -> (,) 0 $ placeAutoDoor (doShift a) (doShift b) w
PutDoor col f pss -> putDoor col f (map (bimap doShift doShift) pss) w
PutSlideDoor pathing col f a b speed
-> placeSlideDoor pathing col f (doShift a) (doShift b) speed w
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
PutBlock{} -> error "messed up block placement somehow"
PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot)
(doShift a) (doShift b) speed w
PutLineBlock wl width depth a b
-> placeLineBlock wl width depth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
src/Dodge/LevelGen/Data.hs
+1 -3
View File
@@ -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
+33 -33
View File
@@ -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)
src/Dodge/Placements.hs
+11 -5
View File
@@ -1,5 +1,6 @@
module Dodge.Placements
( putDoubleDoorThen
( putDoubleDoor
, putDoubleDoorThen
, putAutoDoor
)
where
@@ -11,13 +12,18 @@ import Dodge.LevelGen.Data
import Dodge.Creature.Property
import qualified Data.IntMap.Strict as IM
putDoubleDoorThen :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
putDoubleDoorThen col cond a b speed mayp = ps0j (PutSingleDoor col cond a half speed)
$ Placement (PS (V2 0 0) 0 (PutSingleDoor col cond b half speed)) $ const mayp
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
-> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
$ Placement (PS (V2 0 0) 0 (PutSlideDoor pathing col cond b half speed)) $ const mayp
where
half = 0.5 *.* (a +.+ b)
putAutoDoor :: Point2 -> Point2 -> Placement
putAutoDoor a b = putDoubleDoorThen (dim yellow) cond a b 3 Nothing
putAutoDoor a b = putDoubleDoorThen True (dim yellow) cond a b 3 Nothing
where
cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures
src/Dodge/Room/Airlock.hs
+3 -6
View File
@@ -19,8 +19,7 @@ import System.Random
import Control.Monad.State
{- | A passage with a switch that opens forward access while closing backwards access. -}
airlock :: RandomGen g => State g Room
--airlock = takeOne [airlock0,airlock90,airlockCrystal]
airlock = takeOne [airlock0]
airlock = takeOne [airlock0,airlock90,airlockCrystal]
{- | Straight airlock -}
airlock0 :: Room
airlock0 = defaultRoom
@@ -29,10 +28,8 @@ airlock0 = defaultRoom
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPS =
[Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id)
$ \btid -> Just $ putDoubleDoorThen col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
$ Just $ putDoubleDoorThen col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
-- $ \btid -> jspsJ (V2 0 0) 0 (PutDoubleDoor col (not . cond' btid) (V2 1 20) (V2 39 20) 2)
-- $ sPS (V2 0 0) 0 $ PutDoubleDoor col (cond' btid) (V2 1 80) (V2 39 80) 2
$ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
$ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
,mountedLightI 70 (V2 (-2) 30) (V2 (-2) 70)
,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
]
src/Dodge/Room/LongDoor.hs
+12 -4
View File
@@ -16,6 +16,7 @@ import Dodge.RandomHelp
import Dodge.Creature.Inanimate
import Dodge.Creature
import Dodge.LightSources.Lamp
import Dodge.Placements
import Picture
import Geometry
@@ -40,8 +41,8 @@ twinSlowDoorRoom w h x = defaultRoom
, _rmPath = []
, _rmPS =
[ Placement (PS (V2 0 (h-5)) pi $ PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSingleDoor col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSingleDoor col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
$ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
$ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
$ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
]
@@ -104,15 +105,22 @@ slowDoorRoom = do
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
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
but <- takeOne [butDoor x h butPos butRot
]
fmap connectRoom
(filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([sPS (V2 0 0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
(set rmPS ([but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y
)
)
where
butDoor x h bpos brot
= ps0 (PutButton $ (makeButton col id) {_btPos = bpos, _btRot = brot})
$ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
col = dim $ light red
cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
--but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2
randC1 :: PSType
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
src/Dodge/Room/Placement.hs
+2 -2
View File
@@ -177,8 +177,8 @@ putBlockN a x b y = [ blockLine (V2 a b) (V2 a y)
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id)
$ \btid -> jsps0J (PutSingleDoor col (cond btid) dra drc 2)
$ sps0 (PutSingleDoor col (cond btid) drb drc 2)
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
where
drc = 0.5 *.* (dra +.+ drb)
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Room/Procedural.hs
+2 -2
View File
@@ -232,7 +232,7 @@ centerVaultRoom w h d = do
col = dim $ dim $ bright red
theDoor =
[ Placement (PS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 21 0) (V2 0 0) 2)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2)
]
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn