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

Zoning/streaming refactor

Browse Source
This commit is contained in:
justin
2022-06-26 00:26:53 +01:00
parent 3c7ea4d73b
commit e2d09d57e9
11 changed files with 67 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+20 -27
View File
@@ -27,8 +27,8 @@ module Dodge.Base.Collide
, collidePointWalls'
-- , collidePointWallsL
, collidePointWallsFilt
, overlapCircWallsReturnWall
, overlapCircWallsReturnWall'
, overlapCircWalls
, overlapCircWallsClosest
, collideCircCrsPoint
, collideCircCreatures
, collidePointCreatures
@@ -49,6 +49,7 @@ import FoldableHelp
--import Data.List
import Data.Maybe
import Data.Function (on)
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.Monad
@@ -234,30 +235,10 @@ wallsOnLineHit p1 p2 = IM.mapMaybe f
f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
wallsOnCirc p r = IM.filter f
where
f wl = uncurry circOnSeg (_wlLine wl) p r
wallsOnCirc p r = IM.filter (uncurry (circOnSeg p r) . _wlLine)
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
overlapCircWallsReturnWall p rad
= L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
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
wallsOnCirc' p r = filter $ uncurry (circOnSeg p r) . _wlLine
-- | Looks for any collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
@@ -332,6 +313,18 @@ collideCircWallsList p1 p2 rad
,b +.+ rad *.* normalizeV (b -.-a)
]
overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity ()
-> Stream (Of (Point2,Wall)) Identity ()
overlapCircWalls p r = S.mapMaybe dointersect
where
dointersect wl = f (_wlLine wl) <&> (,wl)
f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b
overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
overlapCircWallsClosest p r = runIdentity
. L.purely S.fold_ (L.minimumBy (compare `on` (dist p . fst)))
. overlapCircWalls p r
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
@@ -414,7 +407,7 @@ 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 = runIdentity . S.any_ (uncurry (circOnSeg' p rad) . _wlLine)
circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
. wallsNearPoint p
-- = any (\(x,y) -> circOnSeg x y p rad)
-- . fmap _wlLine
@@ -427,12 +420,12 @@ crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
{- | Produce an unordered list of creatures on a line. -}
crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnLine p1 p2
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
= IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr))
. _creatures
{- | Produce an unordered list of creatures on a wide line. -}
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnThickLine thickness p1 p2
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
= IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness))
. _creatures
{- | Find 'Maybe' the closest creature to a point, within a circle.
-}
src/Dodge/Beam.hs
+1 -2
View File
@@ -10,7 +10,7 @@ import Geometry
import LensHelp
import Picture
import RandomHelp
import Dodge.Zone
--import Dodge.Zone
import Dodge.Base.Collide
import Shape
@@ -114,7 +114,6 @@ defaultArcStep itparams w (ArcStep p dir _) = do
. filter (\cr -> dist center (_crPos cr) < csize)
. IM.elems
$ _creatures w
wlsnearpoint = wallsNearPoint' p w
mwl = listToMaybe
. sortOn (dist p . fst)
. mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w)
src/Dodge/Item/Weapon/BatteryGuns.hs
+2 -2
View File
@@ -479,12 +479,12 @@ updateTractor pj w
tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
tractFlIt q p1 outpos it
| circOnSeg p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
| segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
| otherwise = it
tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
tractCr q p1 outpos cr
| circOnSeg p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
| segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
| otherwise = cr
tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2
src/Dodge/Render/MenuScreen.hs
+1 -1
View File
@@ -58,7 +58,7 @@ drawOptions u title ops off footer = pictures $
, drawFooterText cfig red footer
] ++
zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s)
(ops'')
ops''
[hh-100,hh-150 ..]
-- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] |
-- y <- map (+75) [0,50..hh*2]]
src/Dodge/Update/Camera.hs
+11 -5
View File
@@ -142,10 +142,18 @@ ifConfigWallRotate cfig w
| otherwise = w
rotateToOverlappingWall :: World -> World
rotateToOverlappingWall w = maybe w dowallrotate
$ overlapCircWallsReturnWall' p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w)
rotateToOverlappingWall w = maybe
id
(doWallRotate . snd)
(overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w))
w
where
cr = you w
p = _crPos (you w)
doWallRotate :: Wall -> World -> World
doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
where
dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
rotateUsing a
| b - b' > 0.01 = w & cameraRot +~ 0.01
| b - b' < negate 0.01 = w & cameraRot -~ 0.01
@@ -154,8 +162,6 @@ rotateToOverlappingWall w = maybe w dowallrotate
--b = a * (2 / pi)
b = a * (4 / pi)
b' = fromIntegral (round b :: Int)
cr = you w
p = _crPos cr
rotateCameraBy :: Float -> World -> World
rotateCameraBy x w = w
src/Dodge/WallCreatureCollisions.hs
+2 -2
View File
@@ -16,7 +16,7 @@ import Data.Monoid
import Data.Maybe
import Data.Function
import Control.Lens
import qualified Data.IntMap.Strict as IM
--import qualified Data.IntMap.Strict as IM
import qualified Streaming.Prelude as S
@@ -84,7 +84,7 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
-- note the inclusion of endpoints in circOnSeg
crOnWall :: Creature -> World -> Bool
crOnWall cr = runIdentity
. S.any_ (uncurry (circOnSeg' p r) . _wlLine)
. S.any_ (uncurry (circOnSeg p r) . _wlLine)
. S.filter (not . _wlWalkable)
. wallsNearPoint p
where
src/Dodge/WorldEvent/Explosion.hs
+1 -1
View File
@@ -10,7 +10,7 @@ module Dodge.WorldEvent.Explosion
import Dodge.Data
import Dodge.LightSource
--import Dodge.Default
import Dodge.Zone
--import Dodge.Zone
import Dodge.Base.Collide
import Dodge.WorldEvent.SpawnParticle
--import Dodge.WorldEvent.Flash
src/Dodge/WorldEvent/Shockwave.hs
+12 -6
View File
@@ -12,8 +12,9 @@ import Geometry
import Picture
import LensHelp
import Data.Foldable
--import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Streaming.Prelude as S
-- currently very effective against walls
makeShockwaveAt
:: [Int] -- ^ IDs of invulnerable creatures.
@@ -52,7 +53,7 @@ mvShockwave
:: [Int] -- ^ IDs of invulnerable creatures.
-> World -> Particle -> (World, Maybe Particle)
mvShockwave is w pt
| _ptTimer pt <= 0 = ( w , Nothing)
| _ptTimer pt <= 0 = ( w , Nothing)
| otherwise = (doDams w , Just $ pt & ptTimer -~ 1)
where
r = _ptRad pt
@@ -62,10 +63,15 @@ mvShockwave is w pt
t = _ptTimer pt
tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
rad = r - (3/4) * r * tFraction
doDams = over creatures (IM.map damCr)
. flip (foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)))
hitBlocks
hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w
doDams w' = over creatures (IM.map damCr)
. runIdentity
$ S.fold_
(flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))
w'
id
hitBlocks
hitBlocks = S.map snd . overlapCircWalls p rad $ wallsAlongCirc' p rad w
-- this is not expansive enough
damCr cr
| _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr
| otherwise = cr & crState . csDamage .:~
src/Dodge/WorldEvent/SpawnParticle.hs
+2 -2
View File
@@ -96,7 +96,7 @@ moveFlame rotd w pt
, _ptCrIgnore = Nothing
, _ptVel = speed *.* vel }
dodamage = damageInArea closeCrs closeWls pt
closeWls wl = uncurry circOnSeg (_wlLine wl) ep 5
closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5
closeCrs cr = dist ep (_crPos cr)
< _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
+ 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
@@ -197,7 +197,7 @@ damageInRadius :: Float -> Particle -> World -> World
damageInRadius size pt = damageInArea isClose closeWls pt
where
p = _ptPos pt
closeWls wl = uncurry circOnSeg (_wlLine wl) p size
closeWls wl = uncurry segOnCirc (_wlLine wl) p size
isClose cr = dist p (_crPos cr) < _crRad cr + size
damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> World
src/Dodge/Zone.hs
+8
View File
@@ -7,6 +7,7 @@ module Dodge.Zone
, zoneSize
, zoneOfPoint
, wallsAlongCirc
, wallsAlongCirc'
, wallsOnScreen
, lookLookups
, zoneAroundPoint
@@ -92,6 +93,8 @@ zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
--zoneOfLineIntMap = ddaExt zoneSize
zoneOfLineIntMap = ddaSq zoneSize
zoneOfCirc p = S.map (uncurry V2) . S.each . zoneOfCircle p
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
@@ -188,6 +191,11 @@ wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y)
Just val -> val
_ -> IM.empty
wallsAlongCirc' :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
wallsAlongCirc' p r w = S.concat $ S.mapMaybe f $ zoneOfCirc p r
where
f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
wallsNearPoint' :: Point2 -> World -> [Wall]
wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
src/Geometry.hs
+7 -7
View File
@@ -84,19 +84,19 @@ circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenorma
-- | 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
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
-- | Test whether a segment intersects a circle by intersecting a normal and testing
-- the distance to the endpoints of the segment.
circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnSeg #-}
circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad
segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE segOnCirc #-}
segOnCirc !p1 !p2 !c !rad = magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where