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

Refactor doors

Browse Source
This commit is contained in:
justin
2021-09-28 01:48:03 +01:00
parent 743c1c878d
commit 1990558985
13 changed files with 105 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+13 -1
View File
@@ -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
+2
View File
@@ -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
+1
View File
@@ -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
+2 -5
View File
@@ -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
+11 -1
View File
@@ -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
-1
View File
@@ -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
+1
View File
@@ -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
+2 -4
View File
@@ -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) wls = wls & wlLine %~ bimap (f ex) (f ey)
-- where
-- f !p = mvPointTowardAtSpeed speed p
moveDoorToward speed (ex,ey) = wlLine %~ mvPs speed (ex,ey)
zoneps :: (Point2, Point2) -> [(Int,Int)]
{-# INLINE zoneps #-}
src/Dodge/LevelGen/TriggerDoor.hs
+60 -29
View File
@@ -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 c cond a b speed = over walls triggerDoubleDoor
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
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
putSingleDoor c cond a b speed = over walls putTheDoor
doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World
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
where
is = [IM.newKey wls..]
playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
setStatus
| 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
+6 -7
View File
@@ -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))
(over 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 $ PutProp $ lampCover lampHeight
(worldState %~ M.insert (DoorNumOpen drid) True )
(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 $ 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
+2 -2
View File
@@ -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
+4
View File
@@ -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
+1 -1
View File
@@ -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]