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

More streaming refactoring

Browse Source
This commit is contained in:
justin
2022-06-25 22:31:49 +01:00
parent 4eaa31bf32
commit 3c7ea4d73b
12 changed files with 88 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+40 -4
View File
@@ -16,8 +16,10 @@ module Dodge.Base.Collide
, wlIsOpaque
, wlIsSeeThrough
, wallsOnCirc
, wallsOnCirc'
, wallsOnLineHit
, collideCircWalls
, collideCircWallsList
-- , collideCircWalls'
, circOnSomeWall
, collidePointWalls
@@ -26,6 +28,7 @@ module Dodge.Base.Collide
-- , collidePointWallsL
, collidePointWallsFilt
, overlapCircWallsReturnWall
, overlapCircWallsReturnWall'
, collideCircCrsPoint
, collideCircCreatures
, collidePointCreatures
@@ -235,6 +238,11 @@ wallsOnCirc p r = IM.filter f
where
f wl = uncurry circOnSeg (_wlLine wl) p r
wallsOnCirc' :: Point2 -> Float -> [Wall] -> [Wall]
wallsOnCirc' p r = filter f
where
f wl = uncurry circOnSeg (_wlLine wl) p r
-- | Looks for overlap of a circle with walls.
-- If found, gives wall
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
@@ -243,6 +251,14 @@ overlapCircWallsReturnWall p rad
where
f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
-- | Looks for overlap of a circle with walls.
-- If found, gives wall
overlapCircWallsReturnWall' :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe Wall
overlapCircWallsReturnWall' p rad
= runIdentity . L.purely S.fold_ (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
where
f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
-- | Looks for any collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
-- note that in this version the circle can overlap the wall
@@ -296,6 +312,25 @@ collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t
-- )
-- where
-- g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWallsList :: Point2 -> Point2 -> Float -> [Wall] -> Maybe (Point2,Point2)
collideCircWallsList p1 p2 rad
= safeMinimumOn (dist p1 . fst)
. mapMaybe
(( \(x:y:_) -> fmap
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ normalizeV (vNormal (x -.- y)))
)
(intersectSegSeg p1 p2 x y)
)
. shiftByRad . _wlLine
)
where
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
]
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
@@ -379,11 +414,12 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
{- | Test if a circle collides with any wall.
- Note no check on whether the wall is walkable. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad
= any (\(x,y) -> circOnSeg x y p rad)
. fmap _wlLine
. IM.elems
circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg' p rad) . _wlLine)
. wallsNearPoint p
-- = any (\(x,y) -> circOnSeg x y p rad)
-- . fmap _wlLine
-- . IM.elems
-- . wallsNearPoint p
{- | Adds the distance to the creature radius, tests whether the center is in
the circle of this size centered at the point -}
crsNearPoint :: Float -> Point2 -> World -> Bool
src/Dodge/Beam.hs
+3 -2
View File
@@ -114,10 +114,11 @@ defaultArcStep itparams w (ArcStep p dir _) = do
. filter (\cr -> dist center (_crPos cr) < csize)
. IM.elems
$ _creatures w
wlsnearpoint = wallsNearPoint p w
wlsnearpoint = wallsNearPoint' p w
mwl = listToMaybe
. sortOn (dist p . fst)
. mapMaybe (\ q -> collidePointWallsWall p (center +.+ q) wlsnearpoint)
. mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w)
-- collidePointWallsWall and wlsnearpoint
$ polyCirc 6 csize
f (q,wl) = ArcStep q dir (Just $ Right wl)
g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (Just $ Left cr)
src/Dodge/Item/Weapon/Grenade.hs
+2 -2
View File
@@ -52,7 +52,7 @@ moveGrenade pj w
| _pjTimer pj <= 0 = w
& props %~ IM.delete pID
& _pjPayload pj (_prPos (_props w IM.! pID))
| otherwise = case collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w of
| otherwise = case collideCircWallsList oldPos newPos 4 $ wallsNearPoint' newPos w of
Nothing -> w & props . ix pID %~ normalUpdate
Just (p,v) -> w
& soundStart (Tap 0) p tapQuietS Nothing
@@ -182,7 +182,7 @@ moveRemoteBomb itid time pID w
-- this is hacky, should use a version of collidePointWalls' that collides
-- circles and walls
invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
hitWl = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
hitWl = collideCircWallsList oldPos newPos 4 $ wallsNearPoint' newPos w
finalPos = maybe newPos (invShift . fst) hitWl
setV v = set (props . ix pID . pjVel) v
updateV = maybe id (setV . snd) hitWl
src/Dodge/Item/Weapon/Launcher.hs
+1 -1
View File
@@ -336,7 +336,7 @@ anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
anythingHitCirc rad sp ep w = isJust $ hitCr <|> hitWl
where
hitCr = fst <$> collideCircCrsPoint sp ep rad (_creatures w)
hitWl = fst <$> collideCircWalls sp ep rad (wallsNearPoint ep w)
hitWl = fst <$> collideCircWallsList sp ep rad (wallsNearPoint' ep w)
-- this should probably be wallsOnLine or something
explodeRemoteRocket
src/Dodge/Update.hs
+2 -1
View File
@@ -348,7 +348,8 @@ updateCloud w c
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
newPos2 = stripZ newPos
-- the following only tests for the first collision with a wall
hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
--hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
hitWl = reflectPointWallsDamp (const True) 1 oldPos2 newPos2 w
finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl
-- allowing clouds at/above height 75 causes graphical glitches 22.05.23
finalVel = addZ nvz $ maybe newVel2 snd hitWl
src/Dodge/Update/Camera.hs
+1 -1
View File
@@ -143,7 +143,7 @@ ifConfigWallRotate cfig w
rotateToOverlappingWall :: World -> World
rotateToOverlappingWall w = maybe w dowallrotate
$ overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
$ overlapCircWallsReturnWall' p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w)
where
dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
rotateUsing a
src/Dodge/WallCreatureCollisions.hs
+7 -5
View File
@@ -18,6 +18,8 @@ import Data.Function
import Control.Lens
import qualified Data.IntMap.Strict as IM
import qualified Streaming.Prelude as S
colCrsWalls :: Configuration -> World -> World
colCrsWalls cfig w = w & creatures %~ fmap (noclipCheck cfig w)
@@ -42,9 +44,9 @@ colCrWall w c
rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ _wlLine <$> wls
ls = _wlLine <$> wls
ls' = filter (uncurry $ isLHS p1) ls
wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w
wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wallsNearPoint p2 w
--wallPoints = map fst ls
-- the amount to push creatures out from walls, extra to their radius
@@ -81,9 +83,9 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
-- note the inclusion of endpoints in circOnSeg
crOnWall :: Creature -> World -> Bool
crOnWall cr = any (\(a,b) -> circOnSeg a b p r)
. fmap _wlLine
. IM.filter (not . _wlWalkable)
crOnWall cr = runIdentity
. S.any_ (uncurry (circOnSeg' p r) . _wlLine)
. S.filter (not . _wlWalkable)
. wallsNearPoint p
where
p = _crPos cr
src/Dodge/WorldEvent/Explosion.hs
+3 -2
View File
@@ -91,5 +91,6 @@ makeExplosionAt p w = w
newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
addFlames w' = foldl' (flip ($)) w' newFs
--pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls
pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls
wls = wallsNearPoint p w
--pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls
pushAgainstWalls q = maybe q fst $ reflectPointWallsDamp (const True) 1 p q w
-- wls = wallsNearPoint p w
src/Dodge/WorldEvent/Shockwave.hs
+4 -3
View File
@@ -12,6 +12,7 @@ import Geometry
import Picture
import LensHelp
import Data.Foldable
import qualified Data.IntMap.Strict as IM
-- currently very effective against walls
makeShockwaveAt
@@ -62,9 +63,9 @@ mvShockwave is w pt
tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
rad = r - (3/4) * r * tFraction
doDams = over creatures (IM.map damCr)
. flip (IM.foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)))
. flip (foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)))
hitBlocks
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w
damCr cr
| _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr
| otherwise = cr & crState . csDamage .:~
@@ -104,7 +105,7 @@ moveInverseShockwave w pt
t = _ptTimer pt
rad = r - 0.1 * r * fromIntegral (10 - t)
dams = over creatures (IM.map damCr) . flip (foldr (damageBlocksBy 1)) hitBlocks
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w
damCr cr
| dist (_crPos cr) p >= rad + _crRad cr = cr
| otherwise = cr & crState . csDamage .:~
src/Dodge/WorldEvent/SpawnParticle.hs
+1 -1
View File
@@ -206,7 +206,7 @@ damageInArea crt wlt pt w = damwls damcrs
where
p = _ptPos pt
damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w
damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ filter wlt $ wallsNearPoint' p w
hiteff = _ptHitEff pt pt
-- | At writing the radius is half the size of the effect area
src/Dodge/Zone.hs
+14 -6
View File
@@ -2,6 +2,7 @@ module Dodge.Zone
( crZoneOfPoint
, zoneOfLineIntMap
, wallsNearPoint
, wallsNearPoint'
, wallsAlongLine
, zoneSize
, zoneOfPoint
@@ -187,13 +188,20 @@ wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y)
Just val -> val
_ -> IM.empty
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where
wallsNearPoint' :: Point2 -> World -> [Wall]
wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
wallsNearPoint :: Point2 -> World -> Stream (Of Wall) Identity ()
wallsNearPoint p w = S.concat $ S.mapMaybe f $ S.each [V2 a b | a <- [x-1,x,x+1], b <- [y-1,y,y+1]]
where
(x,y) = zoneOfPoint p
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
-- IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- where
-- (x,y) = zoneOfPoint p
-- f i m = case IM.lookup i m of
-- Just val -> val
-- _ -> IM.empty
flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a
flattenIMIMIM = IM.unions . fmap IM.unions
src/Geometry.hs
+10
View File
@@ -81,6 +81,16 @@ circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-- | Test whether a circle is on a segment by intersecting a normal and testing
-- the distance to the endpoints of the segment.
-- Perhaps a better order of arguments.
circOnSeg' :: Point2 -> Float -> Point2 -> Point2 -> Bool
{-# INLINE circOnSeg' #-}
circOnSeg' !c !rad !p1 !p2 = magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-- | Test whether a circle is on a segment by intersecting a normal and testing
-- the distance to the endpoints of the segment.