Add variable door speed, still buggy
This commit is contained in:
+21
-19
@@ -1,3 +1,4 @@
|
||||
{-# OPTIONS_GHC -Wno-unused-imports #-}
|
||||
{- |
|
||||
The tree of rooms that make up a level. -}
|
||||
module Dodge.Floor
|
||||
@@ -49,27 +50,28 @@ initialRoomTree = do
|
||||
let t' = padCorridors struct
|
||||
t = treeFromTrunk
|
||||
[[StartRoom]
|
||||
-- ,[Corridor]
|
||||
-- ,[Corridor]
|
||||
-- ,[SpecificRoom roomCCrits]
|
||||
-- ,[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]
|
||||
-- --,[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 ]++)
|
||||
-- ]
|
||||
,[Corridor]
|
||||
,[Corridor]
|
||||
,[SpecificRoom roomCCrits]
|
||||
,[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]
|
||||
--,[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 ]++)
|
||||
]
|
||||
,[Corridor]
|
||||
,[Corridor]
|
||||
,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30]
|
||||
--,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30]
|
||||
,[SpecificRoom $ pure . Right <$> pure (twinSlowDoorRoom 30 80 200 40)]
|
||||
,[Corridor]
|
||||
,[DoorAno]
|
||||
,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit 50]
|
||||
|
||||
+10
-6
@@ -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
|
||||
where
|
||||
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
|
||||
PutSingleDoor col f a b -> putSingleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PutDoubleDoor col f a b speed
|
||||
-> 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
|
||||
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 -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
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
|
||||
|
||||
@@ -41,6 +41,6 @@ mkAutoDoor
|
||||
-> Point2 -- ^ Right point (though the two points should be symmetric)
|
||||
-> [Int] -- ^ Wall ids
|
||||
-> [Wall]
|
||||
mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr
|
||||
mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr 3
|
||||
where
|
||||
cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures
|
||||
|
||||
@@ -33,11 +33,11 @@ data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
| PutBlock [Int] Color [Point2]
|
||||
| PutLineBlock Wall Float Float Point2 Point2
|
||||
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
|
||||
| PutDoubleDoor Color (World -> Bool) Point2 Point2
|
||||
| PutSingleDoor Color (World -> Bool) Point2 Point2
|
||||
| PutDoubleDoor Color (World -> Bool) Point2 Point2 Float
|
||||
| PutSingleDoor Color (World -> Bool) Point2 Point2 Float
|
||||
| PutDoor Color (World -> Bool) [(Point2,Point2)]
|
||||
| PutBtDoor Color Point2 Float Point2 Point2
|
||||
| PutSwitchDoor Color Point2 Float Point2 Point2
|
||||
| PutBtDoor Color Point2 Float Point2 Point2 Float
|
||||
| PutSwitchDoor Color Point2 Float Point2 Point2 Float
|
||||
| RandPS (State StdGen PSType)
|
||||
| PutForeground [Polyhedra]
|
||||
| PutNothing
|
||||
|
||||
@@ -9,17 +9,20 @@ import Picture
|
||||
import qualified DoubleStack as DS
|
||||
import Geometry.Vector
|
||||
|
||||
import Data.Bifunctor
|
||||
|
||||
-- | A door pane that moves linearly between open and closed positions using a
|
||||
-- boolean trigger.
|
||||
linearPane
|
||||
:: Color
|
||||
-> Bool -- ^ Pathable flag
|
||||
-> (World -> Bool) -- ^ Opening condition
|
||||
-> Float -- ^ speed
|
||||
-> Int -- ^ Wall id
|
||||
-> (Point2,Point2) -- ^ Closed position
|
||||
-> (Point2,Point2) -- ^ Open position
|
||||
-> Wall
|
||||
linearPane c isPathable cond n closedPos openPos = Door
|
||||
linearPane c isPathable cond speed n closedPos openPos = Door
|
||||
{ _wlLine = closedPos
|
||||
, _wlID = n
|
||||
, _doorMech = dm
|
||||
@@ -31,34 +34,40 @@ linearPane c isPathable cond n closedPos openPos = Door
|
||||
}
|
||||
where
|
||||
dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond
|
||||
openDoor = moveDoorToward openPos
|
||||
closeDoor = moveDoorToward closedPos
|
||||
openDoor = moveDoorToward speed openPos
|
||||
closeDoor = moveDoorToward speed closedPos
|
||||
|
||||
mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
|
||||
mkSingleDoor c isPathable cond pl hw is
|
||||
= addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond)
|
||||
is
|
||||
leftDoor
|
||||
(map shiftLeft leftDoor)
|
||||
rectanglePairs :: Float -> Point2 -> Point2 -> [(Point2,Point2)]
|
||||
rectanglePairs wdth a b =
|
||||
[ (aup, ad)
|
||||
, (ad, bd)
|
||||
, (bd, bu)
|
||||
, (bu, aup)
|
||||
]
|
||||
where
|
||||
aup = a +.+ norm
|
||||
ad = a -.- norm
|
||||
bu = b +.+ norm
|
||||
bd = b -.- norm
|
||||
norm = wdth *.* normalizeV ( vNormal (b -.- a))
|
||||
|
||||
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
|
||||
leftDoor =
|
||||
[ (pld +.+ perp,hwd)
|
||||
, (hwd, hwu)
|
||||
, (hwu, plu +.+ perp)
|
||||
, (plu +.+ perp,pld +.+ perp)
|
||||
]
|
||||
shiftLeft = h (+.+ (pl -.- hw))
|
||||
h func (x,y) = (func x,func y)
|
||||
norm = 9 *.* normalizeV ( vNormal (hw -.- pl))
|
||||
perp = 5 *.* normalizeV (pl -.- hw)
|
||||
plu = pl +.+ norm
|
||||
pld = pl -.- norm
|
||||
hwu = hw +.+ norm
|
||||
theDoor = rectanglePairs 9 hingep hw
|
||||
shiftLeft = (+.+ (hingep -.- hw))
|
||||
norm = 9 *.* normalizeV ( vNormal (hw -.- hingep))
|
||||
pld = hingep -.- norm
|
||||
hwd = hw -.- norm
|
||||
|
||||
mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
|
||||
mkDoubleDoor c isPathable cond pl pr is
|
||||
= addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond)
|
||||
mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
|
||||
mkDoubleDoor c isPathable cond pl pr speed is
|
||||
= addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond speed)
|
||||
is
|
||||
(leftDoor ++ rightDoor)
|
||||
(map shiftLeft leftDoor ++ map shiftRight rightDoor)
|
||||
|
||||
@@ -24,9 +24,12 @@ mvPs :: (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2)
|
||||
{-# INLINE mvPs #-}
|
||||
mvPs (!ex,!ey) (!sx,!sy) = (mvP ex sx,mvP ey sy)
|
||||
|
||||
moveDoorToward :: (Point2,Point2) -> Wall -> Wall
|
||||
moveDoorToward :: Float -> (Point2,Point2) -> Wall -> Wall
|
||||
{-# 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)]
|
||||
{-# INLINE zoneps #-}
|
||||
|
||||
@@ -24,12 +24,13 @@ import Control.Lens
|
||||
import Data.Graph.Inductive hiding ((&))
|
||||
|
||||
-- probably don't have to rebuild the entire graph, oh well
|
||||
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
|
||||
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World
|
||||
addButtonDoor 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 pathGraph' newGraphPairs
|
||||
$ putDoubleDoor c cond a b w
|
||||
$ putDoubleDoor c cond a b speed w
|
||||
where
|
||||
bid = IM.newKey $ _buttons w
|
||||
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'
|
||||
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 -> World -> World
|
||||
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
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 pathGraph' newGraphPairs
|
||||
$ putDoubleDoor c cond a b w
|
||||
$ putDoubleDoor c cond a b speed w
|
||||
where
|
||||
bid = IM.newKey $ _buttons w
|
||||
cond w' = BtOn == _btState (_buttons w' IM.! bid)
|
||||
@@ -75,17 +76,17 @@ putDoor c cond pss = over walls triggerDoor
|
||||
where
|
||||
is = [IM.newKey wls..]
|
||||
|
||||
putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
|
||||
putDoubleDoor c cond a b = over walls triggerDoubleDoor
|
||||
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 is
|
||||
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 -> World -> World
|
||||
putSingleDoor c cond a b = over walls putTheDoor
|
||||
putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
|
||||
putSingleDoor c cond a b speed = over walls putTheDoor
|
||||
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
|
||||
is = [IM.newKey wls..]
|
||||
|
||||
|
||||
@@ -23,8 +23,8 @@ airlockOneWay n = defaultRoom
|
||||
{ _rmPolys = [rectNSWE 90 0 0 40]
|
||||
, _rmLinks = lnks
|
||||
, _rmPath = []
|
||||
, _rmPS = [sPS (V2 0 15) 0 $ PutDoubleDoor col (not . cond) (V2 0 0) (V2 0 40)
|
||||
,sPS (V2 0 75) 0 $ PutDoubleDoor col 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) 2
|
||||
,sPS (V2 35 45) (pi/2) $ PutButton $ makeButton col (over worldState
|
||||
(M.insert (DoorNumOpen n) True))
|
||||
]
|
||||
@@ -60,8 +60,8 @@ airlock0 n = defaultRoom
|
||||
,(V2 20 45,V2 20 5)
|
||||
]
|
||||
, _rmPS =
|
||||
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0)
|
||||
,sPS (V2 0 80) 0 $ PutDoubleDoor col 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) 2
|
||||
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
|
||||
(over worldState (M.insert (DoorNumOpen n) True))
|
||||
(over worldState (M.insert (DoorNumOpen n) False))
|
||||
|
||||
@@ -42,10 +42,11 @@ twinSlowDoorRoom drID w h x = defaultRoom
|
||||
[ sPS (V2 0 (h/2)) 0 putLamp
|
||||
, sPS (V2 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)
|
||||
, sPS (V2 0 (h-5)) pi $ PutButton $ makeButton col
|
||||
, 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
|
||||
(over worldState (M.insert (DoorNumOpen drID) True))
|
||||
(over worldState (M.insert (DoorNumOpen drID) False))
|
||||
]
|
||||
, _rmBound = ps
|
||||
, _rmName = "twinSlowDoorRoom"
|
||||
@@ -98,7 +99,7 @@ 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)
|
||||
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
|
||||
|
||||
@@ -245,7 +245,7 @@ centerVaultRoom n w h d = do
|
||||
where
|
||||
col = dim $ dim $ bright red
|
||||
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
|
||||
(over worldState (M.insert (DoorNumOpen i) True))
|
||||
(over worldState (M.insert (DoorNumOpen i) False))
|
||||
|
||||
@@ -41,6 +41,7 @@ a *.* V2 x2 y2 =
|
||||
normalizeV :: Point2 -> Point2
|
||||
{-# INLINE normalizeV #-}
|
||||
normalizeV p = (1 / magV p) *.* p
|
||||
|
||||
{- | Angle between two vectors. Always positive. -}
|
||||
angleVV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE angleVV #-}
|
||||
|
||||
Reference in New Issue
Block a user