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

Implement moving wall push and crush

Browse Source
This commit is contained in:
jgk
2021-03-29 16:22:25 +02:00
parent a4afe05478
commit b709aad2a6
4 changed files with 62 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1
View File
@@ -128,6 +128,7 @@ data TempLightSource = TLS
data Creature = Creature
{ _crPos :: Point2
, _crOldPos :: Point2
, _crVel :: Point2
, _crDir :: Float
, _crID :: Int
, _crPict :: Creature -> Picture
src/Dodge/Default.hs
+11 -10
View File
@@ -50,19 +50,20 @@ defaultDoor = Door { _wlLine = [(0,0),(50,0)]
}
defaultCreature :: Creature
defaultCreature = Creature
{ _crPos = (0,0)
{ _crPos = (0,0)
, _crOldPos = (0,0)
, _crDir = 0
, _crID = 1
, _crPict = const $ onLayer CrLayer $ circleSolid 10
, _crVel = (0,0)
, _crDir = 0
, _crID = 1
, _crPict = const $ onLayer CrLayer $ circleSolid 10
, _crUpdate = \ w f cr -> (f , Just cr)
, _crRad = 10
, _crMass = 10
, _crHP = 100
, _crMaxHP = 150
, _crInv = IM.empty
, _crRad = 10
, _crMass = 10
, _crHP = 100
, _crMaxHP = 150
, _crInv = IM.empty
, _crInvSel = 0
, _crState = defaultState
, _crState = defaultState
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
, _crIsAnimate = True
}
src/Dodge/Update.hs
+5 -2
View File
@@ -45,7 +45,7 @@ update w
. wallEvents
. set worldEvents id
$ _worldEvents w1 w1
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
-- w
-- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
-- = insertIMInZone x y wlid wl
@@ -76,7 +76,10 @@ updateParticles' w = set particles' (catMaybes ps) w'
updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
where
((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' (setOldPos cr)) (id,_randGen w)
$ _creatures w
setOldPos cr = cr & crOldPos .~ _crPos cr
wallEvents :: World -> World
src/Dodge/WallCreatureCollisions.hs
+45 -27
View File
@@ -14,23 +14,18 @@ colCrsWalls :: World -> World
colCrsWalls w = over creatures (fmap (colCrWall w)) w
colCrWall :: World -> Creature -> Creature
colCrWall w c = pushOutFromWall w c
pushOutFromWall :: World -> Creature -> Creature
pushOutFromWall w c
| p1 == p2 = c
| otherwise = over crPos (
collideCorners rad p1 wallPoints
.
collideWalls rad p1 ls
. checkPushThroughs rad p1 ls
)
c
where rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
wallPoints = nub $ concat ls
colCrWall w c
| p1 == p2 = pushOrCrush ls c
| otherwise = c & crPos %~
collideCorners rad p1 wallPoints
. collideWalls rad p1 ls
. checkPushThroughs rad p1 ls
where
rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
wallPoints = nub $ concat ls
-- colCrPushThrough :: World -> Creature -> Creature
-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
@@ -43,23 +38,40 @@ pushOutFromWall w c
-- the amount to push creatures out from walls, extra to their radius
wallBuffer = 3
-- the following tests whether a moving circle crosses a list of walls, and
-- places the circle accordingly.
-- It supposes that the circle will only interact with at most two walls.
-- the reverse prevents the collision from happening again with the first wall,
-- when two walls are collided with
-- the following tests whether or not a point is on a wall, and if so pushes it
-- out from the wall
-- If the resultant push out is itself on another wall, the original point is
-- returned
collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
collideWalls rad cp1 walls cp2
= case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of
= case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
Nothing -> cp2
Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of
Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
Nothing -> cp3
Just cp4 -> cp4
Just cp4 -> cp1
-- pushes a point out from a list of walls
-- if multiple new points occur, chooses the one closest to the orignal pointjk
pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
pushOutFromWalls rad walls p =
fromMaybe p
. listToMaybe
. sortBy (compare `on` dist p)
$ mapMaybe (pushOutFromWall rad p)
walls
pushOrCrush :: [[Point2]] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
[] -> cr
[p] -> cr & crPos .~ p
_ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :)
where
cpos = _crPos cr
-- assumes that the wall is orientated
-- assumes wall points are different
collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
collideWall rad cp1 cp2 (wp1:wp2:_)
pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2)
pushOutFromWall rad cp2 (wp1:wp2:_)
| isOnWall = Just newP -- +.+ (1 *.* norm))
| otherwise = Nothing
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
@@ -70,6 +82,12 @@ collideWall rad cp1 cp2 (wp1:wp2:_)
isJust Nothing = False
isJust _ = True
pushOutFromCorners :: World -> Creature -> Creature
pushOutFromCorners w cr = cr & crPos .~ newPos
where
newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
ls = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps