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

Improve doors

Browse Source
This commit is contained in:
justin
2026-03-24 00:35:15 +00:00
parent 7917192b77
commit 832bebb597
10 changed files with 190 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Door.hs
+4 -1
View File
@@ -40,7 +40,10 @@ data Door = Door
, _drMounts :: [MountedObject]
}
data DoorUpdate = DoorDoNothing | DoorLerp {_drLerpSpeed :: Float}
data DoorUpdate
= DoorDoNothing
| DoorLerp {_drLerpSpeed :: Float}
| DoorLerpWithTimer {_drLerpTimer :: Int, _drLerpSpeed :: Float}
makeLenses ''Door
src/Dodge/Default/Door.hs
+2 -2
View File
@@ -1,4 +1,4 @@
module Dodge.Default.Door ( defaultDoor) where
module Dodge.Default.Door (defaultDoor) where
import Dodge.Data.Door
@@ -7,7 +7,7 @@ defaultDoor =
Door
{ _drID = 0
, _drTrigger = WdBlConst False
, _drUpdate = DoorLerp 1
, _drUpdate = DoorLerp 2
, _drZeroPos = (0, 0)
, _drOnePos = (0, 0)
, _drLerp = 0
src/Dodge/Door.hs
+39 -3
View File
@@ -20,9 +20,10 @@ import Picture.Data
import Shape.Data
updateDoor :: Door -> World -> (S.Set Int2, World)
updateDoor dr w
| DoorLerp x <- dr ^. drUpdate = doorLerp x dr w
| otherwise =
updateDoor dr w = case dr ^. drUpdate of
DoorLerp x -> doorLerp x dr w
DoorLerpWithTimer n x -> doorLerpWithTimer n x dr w
DoorDoNothing ->
( mempty
, foldl' (doDoorMount (doDoorLerp dr (dr ^. drLerp))) w (dr ^. drMounts)
)
@@ -68,3 +69,38 @@ doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do
soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1)
| otherwise = id
doorLerpWithTimer :: Int -> Float -> Door -> World -> (S.Set Int2, World)
doorLerpWithTimer n speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w & uptimer) $ do
x <- newlerp
let ps = wlposs x
ps' = wlposs (dr ^. drLerp)
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) (ps <> ps')
-- it seems possible that this will miss some paths: we don't add zones for the
-- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
return
( is
, domounts x $
f x
& playSound x
& cWorld . lWorld . doors . ix drid . drLerp .~ x
& uptimer
)
where
domounts x w' = foldl' (doDoorMount (doDoorLerp dr x)) w' (dr ^. drMounts)
f = ifoldl' (flip . moveWallID) w . wlposs
wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
clerp = dr ^. drLerp
newlerp
| toOpen && clerp < 1 = Just . min 1 $ clerp + speed
| clerp > 0 && not toOpen = Just . max 0 $ clerp - speed
| otherwise = Nothing
uptimer = cWorld . lWorld . doors . ix drid . drUpdate . drLerpTimer %~ updatetimer
updatetimer
| doWdBl (_drTrigger dr) w = const 20
| otherwise = max 0 . subtract 1
toOpen = doWdBl (_drTrigger dr) w || n > 0
drid = _drID dr
playSound x
| _drPushedBy dr == PushesItself =
soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1)
| otherwise = id
src/Dodge/Placement/Instance/Door.hs
+16 -38
View File
@@ -14,75 +14,53 @@ import Dodge.LevelGen.PlacementHelper
import Geometry
import Linear
putDoubleDoor :: Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement
putDoubleDoor wl cond a b speed =
putDoubleDoorThen wl cond 1 a b speed (const $ const Nothing)
putDoubleDoor :: Wall -> Point2 -> Point2 -> Door -> Placement
putDoubleDoor wl a b dr =
putDoubleDoorThen wl 1 a b dr (const $ const Nothing)
putDoubleDoorThen ::
Wall ->
WdBl ->
Float ->
Point2 ->
Point2 ->
Float ->
Door ->
(Placement -> Placement -> Maybe Placement) ->
Placement
putDoubleDoorThen wl cond soff a b speed cont =
doorBetween wl cond soff a half speed $
\pl1 -> Just $
doorBetween wl cond soff b half speed $
\pl2 -> cont pl1 pl2
putDoubleDoorThen wl soff a b dr cont =
doorBetween wl soff a half dr $
\pl1 -> Just $ doorBetween wl soff b half dr $ \pl2 -> cont pl1 pl2
where
half = 0.5 *^ (a + b)
doorBetween ::
Wall ->
WdBl ->
Float ->
Point2 ->
Point2 ->
Float ->
Door ->
(Placement -> Maybe Placement) ->
Placement
doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of
-- [x, y] -> ptCont (putSlideDr adoor wl soff x y) g
doorBetween wl soff pa pb dr g = case divideLine 40 pa pb of
(x : y : zs) ->
divideDoorPane
Nothing
wl
cond
(soff - dist y pb)
speed
(zip (x : y : zs) (y : zs))
g
divideDoorPane Nothing wl (soff - dist y pb) dr (zip (x : y : zs) (y : zs)) g
_ -> error "tried to create doorBetween with too few points"
-- where
-- adoor =
-- defaultDoor
-- & drTrigger .~ cond
-- & drUpdate .~ DoorLerp speed
divideDoorPane ::
Maybe Int ->
Wall ->
WdBl ->
Float ->
Float ->
Door ->
[(Point2, Point2)] ->
(Placement -> Maybe Placement) ->
Placement
divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
divideDoorPane mid wl soff dr ppairs g = case ppairs of
[p] -> ptCont (adoor p) g
(p : ps) -> ptCont (adoor p) $
\pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
\pl -> Just $ divideDoorPane (_plMID pl) wl soff dr ps g
_ -> undefined
where
adoor (x, y) = putSlideDr thedoor wl soff x y
thedoor =
defaultDoor
& drUpdate . drLerpSpeed .~ speed
& drTrigger .~ cond
& drPushedBy .~ maybe PushesItself PushedBy mid
thedoor = dr & drPushedBy .~ maybe PushesItself PushedBy mid
putAutoDoor :: Point2 -> Point2 -> Placement
putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
@@ -93,7 +71,7 @@ putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
in Just $
putDoubleDoor
defaultAutoWall
(WdBlCrFilterNearPoint 40 (0.5 *^ (x + y)) CrOpenAutoDoor)
a
b
3
(defaultDoor & drTrigger .~(WdBlCrFilterNearPoint 40 (0.5 *^ (x + y)) CrOpenAutoDoor)
& drUpdate .~ DoorLerpWithTimer 0 3)
src/Dodge/Room/Airlock.hs
+9 -6
View File
@@ -44,8 +44,8 @@ decontamRoom i =
& rmPmnts
.~ [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) xSwitch $
\btid -> Just $
putDoubleDoorThen defaultDoorWall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
\_ _ -> Just $ putDoubleDoor defaultDoorWall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
putDoubleDoorThen defaultDoorWall 1 (V2 0 20) (V2 40 20) (dr1 btid) $
\_ _ -> Just $ putDoubleDoor defaultDoorWall (V2 0 80) (V2 40 80) (dr2 btid)
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
, spanLightI (V2 (-20) 30) (V2 (-20) 70)
, analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0) & plExternalID ?~ i
@@ -55,15 +55,16 @@ decontamRoom i =
& rmInPmnt .~ [(0, return . f)]
& rmBound .~ [rectNSWE 75 15 0 40, switchcut]
where
dr1 btid = defaultDoor & drTrigger .~ (WdBlNegate $ WdBlBtOn btid)
dr2 btid = defaultDoor & drTrigger .~ (WdBlBtOn btid)
f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
pmnt <- gw ^? genPmnt . ix i
return $
putDoubleDoor
defaultDoorWall
(cond pmnt)
(V2 (-10) 35)
(V2 (-10) 65)
2
(defaultDoor & drTrigger .~ cond pmnt)
cond pmnt = WdTrig $ pmnt ^?! plMID . _Just
mcpos = V2 70 50
cutps = [rectNSWE 100 0 0 40, switchcut]
@@ -84,8 +85,8 @@ airlock0 =
, _rmPmnts =
[ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) xSwitch $
\btid -> Just $
putDoubleDoorThen defaultDoorWall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
\_ _ -> Just $ putDoubleDoor defaultDoorWall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
putDoubleDoorThen defaultDoorWall 1 (V2 0 20) (V2 40 20) (dr1 btid) $
\_ _ -> Just $ putDoubleDoor defaultDoorWall (V2 0 80) (V2 40 80) (dr2 btid)
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
, spanLightI (V2 (-2) 30) (V2 (-2) 70)
, sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
@@ -93,6 +94,8 @@ airlock0 =
, _rmBound = [rectNSWE 75 15 0 40, switchcut]
}
where
dr1 btid = defaultDoor & drTrigger .~ (WdBlNegate $ WdBlBtOn btid)
dr2 btid = defaultDoor & drTrigger .~ (WdBlBtOn btid)
switchcut = rectNSWE 65 35 (-40) 20
lnks =
[ (V2 20 95, 0)
src/Dodge/Room/Door.hs
+3 -1
View File
@@ -1,6 +1,7 @@
{- Rooms that connect other rooms, blocking sight. -}
module Dodge.Room.Door where
import Dodge.Default.Door
import Dodge.Default.Wall
import Data.Maybe
import Dodge.Data.GenWorld
@@ -42,5 +43,6 @@ triggerDoorRoom i =
where
f gw = return $ fromMaybe (error "tried to put a door using an empty placement list") $ do
pmnt <- gw ^? genPmnt . ix i
return $ putDoubleDoor defaultDoorWall (cond pmnt) (V2 0 20) (V2 40 20) 2
return $ putDoubleDoor defaultDoorWall (V2 0 20) (V2 40 20)
(defaultDoor & drTrigger .~ (cond pmnt))
cond pmnt = WdTrig $ fromJust (_plMID pmnt)
src/Dodge/Room/LongDoor.hs
+3 -4
View File
@@ -64,7 +64,6 @@ twinSlowDoorRoom w h x =
where
--thewall = switchWallCol red
thewall = defaultDoorWall
wlSpeed = 0.5
lampheight = 41
ps =
[ rectNSWE h 0 (- w) w
@@ -72,7 +71,7 @@ twinSlowDoorRoom w h x =
]
thedoor btid =
defaultDoor
& drUpdate . drLerpSpeed .~ wlSpeed
& drUpdate . drLerpSpeed .~ 0.5
& drTrigger .~ WdBlBtOn btid
col = dim $ dim $ bright red
@@ -116,11 +115,11 @@ addButtonSlowDoor x h =
$ \btplmnt -> Just
. putDoubleDoorThen
defaultDoorWall
(WdBlBtOn $ fromJust $ _plMID btplmnt)
30
(V2 0 h)
(V2 x h)
0.5
(defaultDoor & drTrigger .~ (WdBlBtOn $ fromJust $ _plMID btplmnt)
& drUpdate . drLerpSpeed .~ 0.5)
$ \dr1 dr2 ->
Just
. sps0
src/Dodge/Room/Procedural.hs
+1 -4
View File
@@ -310,7 +310,4 @@ centerVaultRoom w h d =
sPS (V2 0 (d -10)) 0 (putSlideDr (thedoor btid) thewall 1 (V2 21 0) (V2 0 0))
]
thewall = defaultDoorWall
thedoor btid =
defaultDoor
& drTrigger .~ WdBlBtOn btid
& drUpdate . drLerpSpeed .~ 2
thedoor btid = defaultDoor & drTrigger .~ WdBlBtOn btid
src/Dodge/TestString.hs
+1 -1
View File
@@ -33,7 +33,7 @@ import Data.Monoid
import RandomHelp
testStringInit :: Universe -> [String]
testStringInit u = [evalState (takeOne ["a","b"]) (_randGen $ _uvWorld u)]
testStringInit u = fmap show $ u ^.. uvWorld . cWorld . lWorld . doors . each . drUpdate . drLerpTimer
-- (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
-- <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
--testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)