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

Add variable door speed, still buggy

Browse Source
This commit is contained in:
justin
2021-09-10 13:41:46 +01:00
parent 87a9745d37
commit c695767fb0
11 changed files with 99 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+18 -16
View File
@@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-unused-imports #-}
{- | {- |
The tree of rooms that make up a level. -} The tree of rooms that make up a level. -}
module Dodge.Floor module Dodge.Floor
@@ -49,27 +50,28 @@ initialRoomTree = do
let t' = padCorridors struct let t' = padCorridors struct
t = treeFromTrunk t = treeFromTrunk
[[StartRoom] [[StartRoom]
,[Corridor] -- ,[Corridor]
,[Corridor] -- ,[Corridor]
,[SpecificRoom roomCCrits] -- ,[SpecificRoom roomCCrits]
,[Corridor] -- ,[Corridor]
,[Corridor]
,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
& rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
]++)
]
-- ,[Corridor] -- ,[Corridor]
-- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 -- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
-- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) -- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
-- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
-- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
-- ]++)
-- ]
-- --,[Corridor]
-- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
-- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
-- -- ]
-- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
-- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
-- ] -- ]
,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
& rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
]
,[Corridor] ,[Corridor]
,[Corridor] ,[Corridor]
,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30] --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30]
,[SpecificRoom $ pure . Right <$> pure (twinSlowDoorRoom 30 80 200 40)]
,[Corridor] ,[Corridor]
,[DoorAno] ,[DoorAno]
,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit 50] ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit 50]
src/Dodge/LevelGen.hs
+10 -6
View File
@@ -80,15 +80,19 @@ placeSpot ps w = case _psType ps of
PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
where where
mapBoth fn (x,y) = (fn x, fn y) mapBoth fn (x,y) = (fn x, fn y)
PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutDoubleDoor col f a b speed
PutSingleDoor col f a b -> putSingleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w -> putDoubleDoor 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
PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) 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 (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
PutBlock{} -> error "messed up block placement somehow" PutBlock{} -> error "messed up block placement somehow"
PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) PutBtDoor c bp f a b speed
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) 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 a b
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w -> 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 PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
src/Dodge/LevelGen/AutoDoor.hs
+1 -1
View File
@@ -41,6 +41,6 @@ mkAutoDoor
-> Point2 -- ^ Right point (though the two points should be symmetric) -> Point2 -- ^ Right point (though the two points should be symmetric)
-> [Int] -- ^ Wall ids -> [Int] -- ^ Wall ids
-> [Wall] -> [Wall]
mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr 3
where where
cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures
src/Dodge/LevelGen/Data.hs
+4 -4
View File
@@ -33,11 +33,11 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutBlock [Int] Color [Point2] | PutBlock [Int] Color [Point2]
| PutLineBlock Wall Float Float Point2 Point2 | PutLineBlock Wall Float Float Point2 Point2
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutDoubleDoor Color (World -> Bool) Point2 Point2 | PutDoubleDoor Color (World -> Bool) Point2 Point2 Float
| PutSingleDoor Color (World -> Bool) Point2 Point2 | PutSingleDoor Color (World -> Bool) Point2 Point2 Float
| PutDoor Color (World -> Bool) [(Point2,Point2)] | PutDoor Color (World -> Bool) [(Point2,Point2)]
| PutBtDoor Color Point2 Float Point2 Point2 | PutBtDoor Color Point2 Float Point2 Point2 Float
| PutSwitchDoor Color Point2 Float Point2 Point2 | PutSwitchDoor Color Point2 Float Point2 Point2 Float
| RandPS (State StdGen PSType) | RandPS (State StdGen PSType)
| PutForeground [Polyhedra] | PutForeground [Polyhedra]
| PutNothing | PutNothing
src/Dodge/LevelGen/DoorPane.hs
+34 -25
View File
@@ -9,17 +9,20 @@ import Picture
import qualified DoubleStack as DS import qualified DoubleStack as DS
import Geometry.Vector import Geometry.Vector
import Data.Bifunctor
-- | A door pane that moves linearly between open and closed positions using a -- | A door pane that moves linearly between open and closed positions using a
-- boolean trigger. -- boolean trigger.
linearPane linearPane
:: Color :: Color
-> Bool -- ^ Pathable flag -> Bool -- ^ Pathable flag
-> (World -> Bool) -- ^ Opening condition -> (World -> Bool) -- ^ Opening condition
-> Float -- ^ speed
-> Int -- ^ Wall id -> Int -- ^ Wall id
-> (Point2,Point2) -- ^ Closed position -> (Point2,Point2) -- ^ Closed position
-> (Point2,Point2) -- ^ Open position -> (Point2,Point2) -- ^ Open position
-> Wall -> Wall
linearPane c isPathable cond n closedPos openPos = Door linearPane c isPathable cond speed n closedPos openPos = Door
{ _wlLine = closedPos { _wlLine = closedPos
, _wlID = n , _wlID = n
, _doorMech = dm , _doorMech = dm
@@ -31,34 +34,40 @@ linearPane c isPathable cond n closedPos openPos = Door
} }
where where
dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond
openDoor = moveDoorToward openPos openDoor = moveDoorToward speed openPos
closeDoor = moveDoorToward closedPos closeDoor = moveDoorToward speed closedPos
mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] rectanglePairs :: Float -> Point2 -> Point2 -> [(Point2,Point2)]
mkSingleDoor c isPathable cond pl hw is rectanglePairs wdth a b =
= addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond) [ (aup, ad)
is , (ad, bd)
leftDoor , (bd, bu)
(map shiftLeft leftDoor) , (bu, aup)
where
leftDoor =
[ (pld +.+ perp,hwd)
, (hwd, hwu)
, (hwu, plu +.+ perp)
, (plu +.+ perp,pld +.+ perp)
] ]
shiftLeft = h (+.+ (pl -.- hw)) where
h func (x,y) = (func x,func y) aup = a +.+ norm
norm = 9 *.* normalizeV ( vNormal (hw -.- pl)) ad = a -.- norm
perp = 5 *.* normalizeV (pl -.- hw) bu = b +.+ norm
plu = pl +.+ norm bd = b -.- norm
pld = pl -.- norm norm = wdth *.* normalizeV ( vNormal (b -.- a))
hwu = hw +.+ norm
mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
mkSingleDoor c isPathable cond hingep hw speed is
= addSoundToDoor (head is) pld hwd
$ zipWith3 (linearPane c isPathable cond speed)
is
theDoor
(map (bimap shiftLeft shiftLeft) theDoor)
where
theDoor = rectanglePairs 9 hingep hw
shiftLeft = (+.+ (hingep -.- hw))
norm = 9 *.* normalizeV ( vNormal (hw -.- hingep))
pld = hingep -.- norm
hwd = hw -.- norm hwd = hw -.- norm
mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
mkDoubleDoor c isPathable cond pl pr is mkDoubleDoor c isPathable cond pl pr speed is
= addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond) = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond speed)
is is
(leftDoor ++ rightDoor) (leftDoor ++ rightDoor)
(map shiftLeft leftDoor ++ map shiftRight rightDoor) (map shiftLeft leftDoor ++ map shiftRight rightDoor)
src/Dodge/LevelGen/MoveDoor.hs
+5 -2
View File
@@ -24,9 +24,12 @@ mvPs :: (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2)
{-# INLINE mvPs #-} {-# INLINE mvPs #-}
mvPs (!ex,!ey) (!sx,!sy) = (mvP ex sx,mvP ey sy) mvPs (!ex,!ey) (!sx,!sy) = (mvP ex sx,mvP ey sy)
moveDoorToward :: (Point2,Point2) -> Wall -> Wall moveDoorToward :: Float -> (Point2,Point2) -> Wall -> Wall
{-# INLINE moveDoorToward #-} {-# INLINE moveDoorToward #-}
moveDoorToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey) --moveDoorToward speed (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
moveDoorToward speed (ex,ey) wls = wls & wlLine %~ bimap (f ex) (f ey)
where
f !p = mvPointTowardAtSpeed speed p
zoneps :: (Point2, Point2) -> [(Int,Int)] zoneps :: (Point2, Point2) -> [(Int,Int)]
{-# INLINE zoneps #-} {-# INLINE zoneps #-}
src/Dodge/LevelGen/TriggerDoor.hs
+13 -12
View File
@@ -24,12 +24,13 @@ import Control.Lens
import Data.Graph.Inductive hiding ((&)) import Data.Graph.Inductive hiding ((&))
-- probably don't have to rebuild the entire graph, oh well -- probably don't have to rebuild the entire graph, oh well
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) addButtonDoor c btp btr a b speed w
= over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph $ set pathGraph newGraph
$ set pathGraph' newGraphPairs $ set pathGraph' newGraphPairs
$ putDoubleDoor c cond a b w $ putDoubleDoor c cond a b speed w
where where
bid = IM.newKey $ _buttons w bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid) cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
@@ -42,12 +43,12 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y) f (x,y) = (x,y,dist x y)
-- this has been repeated at least three times: TO BE UNIFIED, REFACTORED -- this has been repeated at least three times: TO BE UNIFIED, REFACTORED
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph $ set pathGraph newGraph
$ set pathGraph' newGraphPairs $ set pathGraph' newGraphPairs
$ putDoubleDoor c cond a b w $ putDoubleDoor c cond a b speed w
where where
bid = IM.newKey $ _buttons w bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid) cond w' = BtOn == _btState (_buttons w' IM.! bid)
@@ -75,17 +76,17 @@ putDoor c cond pss = over walls triggerDoor
where where
is = [IM.newKey wls..] is = [IM.newKey wls..]
putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
putDoubleDoor c cond a b = over walls triggerDoubleDoor putDoubleDoor c cond a b speed = over walls triggerDoubleDoor
where where
triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b is triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b speed is
where where
is = [IM.newKey wls..] is = [IM.newKey wls..]
putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
putSingleDoor c cond a b = over walls putTheDoor putSingleDoor c cond a b speed = over walls putTheDoor
where where
putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b is putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b speed is
where where
is = [IM.newKey wls..] is = [IM.newKey wls..]
src/Dodge/Room/Airlock.hs
+4 -4
View File
@@ -23,8 +23,8 @@ airlockOneWay n = defaultRoom
{ _rmPolys = [rectNSWE 90 0 0 40] { _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [] , _rmPath = []
, _rmPS = [sPS (V2 0 15) 0 $ PutDoubleDoor col (not . cond) (V2 0 0) (V2 0 40) , _rmPS = [sPS (V2 0 15) 0 $ PutDoubleDoor col (not . cond) (V2 0 0) (V2 0 40) 2
,sPS (V2 0 75) 0 $ PutDoubleDoor col cond (V2 0 0) (V2 0 40) ,sPS (V2 0 75) 0 $ PutDoubleDoor col cond (V2 0 0) (V2 0 40) 2
,sPS (V2 35 45) (pi/2) $ PutButton $ makeButton col (over worldState ,sPS (V2 35 45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True)) (M.insert (DoorNumOpen n) True))
] ]
@@ -60,8 +60,8 @@ airlock0 n = defaultRoom
,(V2 20 45,V2 20 5) ,(V2 20 45,V2 20 5)
] ]
, _rmPS = , _rmPS =
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0) [sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0) 2
,sPS (V2 0 80) 0 $ PutDoubleDoor col cond (V2 1 0) (V2 39 0) ,sPS (V2 0 80) 0 $ PutDoubleDoor col cond (V2 1 0) (V2 39 0) 2
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col ,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True)) (over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False)) (over worldState (M.insert (DoorNumOpen n) False))
src/Dodge/Room/LongDoor.hs
+5 -4
View File
@@ -42,10 +42,11 @@ twinSlowDoorRoom drID w h x = defaultRoom
[ sPS (V2 0 (h/2)) 0 putLamp [ sPS (V2 0 (h/2)) 0 putLamp
, sPS (V2 25 5) 0 putLamp , sPS (V2 25 5) 0 putLamp
, sPS (V2 (negate 25) 5) 0 putLamp , sPS (V2 (negate 25) 5) 0 putLamp
, sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) , 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) , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1
, sPS (V2 0 (h-5)) pi $ PutButton $ makeButton col , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen drID) True)) (over worldState (M.insert (DoorNumOpen drID) True))
(over worldState (M.insert (DoorNumOpen drID) False))
] ]
, _rmBound = ps , _rmBound = ps
, _rmName = "twinSlowDoorRoom" , _rmName = "twinSlowDoorRoom"
@@ -98,7 +99,7 @@ slowDoorRoom = do
pillars <- takeOne [pillarsa, pillarsb, pillarsc] pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x' = (sndV2 . fst) x' > h + 40 let cond x' = (sndV2 . fst) x' > h + 40
cond2 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) 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) -- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
] ]
fmap connectRoom fmap connectRoom
src/Dodge/Room/Procedural.hs
+1 -1
View File
@@ -245,7 +245,7 @@ centerVaultRoom n w h d = do
where where
col = dim $ dim $ bright red col = dim $ dim $ bright red
theDoor i = theDoor i =
[ sPS (V2 0 (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) 0) (V2 19 0) [ sPS (V2 0 (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) 0) (V2 19 0) 2
, sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col , sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen i) True)) (over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False)) (over worldState (M.insert (DoorNumOpen i) False))
src/Geometry/Vector.hs
+1
View File
@@ -41,6 +41,7 @@ a *.* V2 x2 y2 =
normalizeV :: Point2 -> Point2 normalizeV :: Point2 -> Point2
{-# INLINE normalizeV #-} {-# INLINE normalizeV #-}
normalizeV p = (1 / magV p) *.* p normalizeV p = (1 / magV p) *.* p
{- | Angle between two vectors. Always positive. -} {- | Angle between two vectors. Always positive. -}
angleVV :: Point2 -> Point2 -> Float angleVV :: Point2 -> Point2 -> Float
{-# INLINE angleVV #-} {-# INLINE angleVV #-}