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/LevelGen/AutoDoor.hs
+1 -1
View File
@@ -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
src/Dodge/LevelGen/Data.hs
+4 -4
View File
@@ -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
src/Dodge/LevelGen/DoorPane.hs
+34 -25
View File
@@ -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)
src/Dodge/LevelGen/MoveDoor.hs
+5 -2
View File
@@ -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 #-}
src/Dodge/LevelGen/TriggerDoor.hs
+13 -12
View File
@@ -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..]