Refactor wall zoning, remove streaming

This commit is contained in:
2022-07-23 12:29:29 +01:00
parent 39f4555697
commit 39778f46fb
30 changed files with 396 additions and 163 deletions
+55 -12
View File
@@ -11,11 +11,13 @@ module Dodge.WorldEvent.ThingsHit
, wlsHitRadial
)
where
import Dodge.Zoning.Wall
import Dodge.Zoning.Creature
import Dodge.Data
import Dodge.Base
import Dodge.Zone
import Geometry
import qualified ListHelp as List
import Control.Lens
import Data.Maybe
@@ -31,10 +33,19 @@ thingsHit
:: Point2 -- ^ Line start point
-> Point2 -- ^ Line end point
-> World
-> StreamOf (Point2, Either Creature Wall)
thingsHit sp ep w = void $ S.mergeOn (dist sp . fst)
(S.map (second Left) (S.each $ crsHit sp ep w))
(S.map (second Right) (wlsHit sp ep w))
-> [(Point2, Either Creature Wall)]
thingsHit sp ep w = List.mergeOn (dist sp . fst)
(map (second Left) (crsHit sp ep w))
(map (second Right) (wlsHit sp ep w))
--{- List those objects that appear on a line. -}
--thingsHit
-- :: Point2 -- ^ Line start point
-- -> Point2 -- ^ Line end point
-- -> World
-- -> StreamOf (Point2, Either Creature Wall)
--thingsHit sp ep w = void $ S.mergeOn (dist sp . fst)
-- (S.map (second Left) (S.each $ crsHit sp ep w))
-- (S.map (second Right) (wlsHit sp ep w))
crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)]
crsHit sp ep w
@@ -48,13 +59,20 @@ crsHit sp ep w
thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool)
-> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
thingHitFilt fcr fwl sp ep = runIdentity . S.head_ . S.filter (f . snd) . thingsHit sp ep
thingHitFilt fcr fwl sp ep = listToMaybe . filter (f . snd) . thingsHit sp ep
where
f (Left cr) = fcr cr
f (Right wl) = fwl wl
--thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool)
-- -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
--thingHitFilt fcr fwl sp ep = runIdentity . S.head_ . S.filter (f . snd) . thingsHit sp ep
-- where
-- f (Left cr) = fcr cr
-- f (Right wl) = fwl wl
thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
thingHit sp ep = runIdentity . S.head_ . thingsHit sp ep
thingHit sp ep = listToMaybe . thingsHit sp ep
{- List objects that appear on a line.
Can filter out a creature. -}
@@ -63,26 +81,51 @@ thingsHitExceptCr
-> Point2 -- ^ Line start point
-> Point2 -- ^ Line end point
-> World
-> StreamOf (Point2, Either Creature Wall)
-> [(Point2, Either Creature Wall)]
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
where
crNotCid (_,Left cr) = _crID cr /= cid
crNotCid _ = True
--{- List objects that appear on a line.
--Can filter out a creature. -}
--thingsHitExceptCr
-- :: Maybe Int -- ^ A possible creature ID
-- -> Point2 -- ^ Line start point
-- -> Point2 -- ^ Line end point
-- -> World
-- -> StreamOf (Point2, Either Creature Wall)
--thingsHitExceptCr Nothing sp ep = thingsHit sp ep
--thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep
-- where
-- crNotCid (_,Left cr) = _crID cr /= cid
-- crNotCid _ = True
wlsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Wall)
wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)]
wlsHit sp ep
| sp == ep = const mempty
| otherwise = sortStreamOn (dist sp . fst)
| otherwise = sortOn (dist sp . fst)
. overlapSegWalls sp ep
. wlsNearSeg sp ep
--wlsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Wall)
--wlsHit sp ep
-- | sp == ep = const mempty
-- | otherwise = sortStreamOn (dist sp . fst)
-- . overlapSegWalls sp ep
-- . wlsNearSeg sp ep
wlsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Wall)
wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r
wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
wlsHitRadial p r = mapMaybe f . wlsNearCirc p r
where
f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl)
where
v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl
--wlsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Wall)
--wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r
-- where
-- f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl)
-- where
-- v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl
crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
crsHitRadial p r = mapMaybe f . crsNearCirc p r