More streaming refactoring
This commit is contained in:
+44
-151
@@ -3,9 +3,10 @@
|
||||
module Dodge.Base.Collide
|
||||
( hasLOS
|
||||
, collidePointWallsWall
|
||||
, collidePointWallsFilterStream
|
||||
, reflectPointWallsDamp
|
||||
, hasButtonLOS
|
||||
, reflectPointWalls
|
||||
, reflectPointWallsDamp
|
||||
, ssfold
|
||||
, collidePointUpToIndirectMinDist
|
||||
, canSeeIndirect
|
||||
@@ -35,6 +36,7 @@ module Dodge.Base.Collide
|
||||
, nearestCrInRad
|
||||
, nearestCrInTri
|
||||
, nearestCrInFront
|
||||
, allVisibleWalls
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Zone
|
||||
@@ -50,6 +52,7 @@ import qualified FoldlHelp as L
|
||||
import Data.Monoid
|
||||
import Streaming
|
||||
import qualified Streaming.Prelude as S
|
||||
--import qualified Data.Map.Lazy as M -- note the use of Lazy, the idea being interoperation with Streaming
|
||||
|
||||
hasLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOS #-}
|
||||
@@ -72,13 +75,14 @@ hasButtonLOS p1 p2 = not
|
||||
-- = safeMinimumOn (dist p1 . fst)
|
||||
-- . mapMaybe
|
||||
-- (\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y)
|
||||
|
||||
reflectPointWallsDamp :: Float -> Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
reflectPointWallsDamp x p1 p2 = fmap (f p1 p2) . collidePointWallsWall p1 p2
|
||||
where
|
||||
f a b (p,wl) = ( p +.+ errorNormalizeV 139 (vNormal (uncurry (-.-) $ _wlLine wl))
|
||||
, reflVelWallDamp x wl (b-.-a)
|
||||
reflectPointWallsDamp :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
||||
reflectPointWallsDamp t x sp ep w = do
|
||||
wl <- mwl
|
||||
return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
||||
, reflVelWallDamp x wl (ep -.- sp)
|
||||
)
|
||||
where
|
||||
(p, mwl) = collidePointWallsFilterStream t sp ep w
|
||||
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and wall.
|
||||
@@ -120,38 +124,46 @@ reflectPointWalls p1 p2
|
||||
-- . _wlLine
|
||||
-- ) ws
|
||||
-- | Test if a point collides with walls
|
||||
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
pointHitsWalls p1 p2
|
||||
= any $ isJust . uncurry (intersectSegSeg p1 p2) . _wlLine
|
||||
|
||||
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
||||
-- whether this is actually faster
|
||||
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool
|
||||
collidePointTestFilter t sp ep = runIdentity
|
||||
. S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
. S.filter t
|
||||
|
||||
--furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
|
||||
--furthestPointWalkable p1 p2 ws
|
||||
-- = fromMaybe p2
|
||||
-- . safeMinimumOn (dist p1)
|
||||
-- $ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws
|
||||
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
|
||||
collidePointWallsFilterStream t sp ep = runIdentity
|
||||
. S.fold_ findPoint (ep, Nothing) id
|
||||
. S.filter t
|
||||
. wallsAlongLineStream sp ep
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
--collideDirectionIndirect
|
||||
-- :: Float -- ^max distance to look
|
||||
-- -> Point2 -- ^start point
|
||||
-- -> Point2 -- ^point in direction
|
||||
-- -> IM.IntMap Wall
|
||||
-- -> Float
|
||||
--{-# INLINE collideDirectionIndirect #-}
|
||||
--collideDirectionIndirect d p1 p2 wls
|
||||
-- = fromMaybe d
|
||||
-- $
|
||||
-- ( L.fold
|
||||
-- . L.prefilter wlIsOpaque
|
||||
-- . L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine)
|
||||
-- ) L.minimum
|
||||
-- wls
|
||||
-- where
|
||||
-- p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
|
||||
--visibleWallWalls' :: Point2 -> Point2 -> World -> M.Map Float Wall
|
||||
--visibleWallWalls' sp ep = L.purely S.fold L.map . visibleWallWalls sp ep
|
||||
|
||||
--orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ())
|
||||
orderStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity ()
|
||||
orderStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g
|
||||
where
|
||||
g x = (f x,x)
|
||||
|
||||
visibleWallWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
|
||||
visibleWallWalls sp ep =
|
||||
join
|
||||
. fmap (S.take 1)
|
||||
. S.span (not . wlIsOpaque . snd)
|
||||
. orderStreamOn (dist sp . fst)
|
||||
. S.mapMaybe f
|
||||
. wallsAlongLineStream sp ep
|
||||
where
|
||||
f wl = uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
|
||||
allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity ()
|
||||
allVisibleWalls w = concats $ S.subst (flip (visibleWallWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
||||
where
|
||||
vPos = _cameraViewFrom w
|
||||
|
||||
wlIsOpaque :: Wall -> Bool
|
||||
wlIsOpaque wl = case _wlOpacity wl of
|
||||
@@ -192,40 +204,6 @@ ssfold :: Foldable t => (a -> Bool) -> (a -> b -> a) -> a -> t b -> a
|
||||
{-# INLINABLE ssfold #-}
|
||||
ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0
|
||||
|
||||
--collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
--{-# INLINE collidePointIndirect #-}
|
||||
--collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter wlIsOpaque
|
||||
-- where
|
||||
-- f wl p = fromMaybe p $ uncurry (intersectSegSeg p1 p) $ _wlLine wl
|
||||
-- test p | p == p2 = Nothing
|
||||
-- | otherwise = Just p
|
||||
|
||||
collidePointIndirect' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
{-# INLINE collidePointIndirect' #-}
|
||||
collidePointIndirect' p1 p2
|
||||
= L.fold
|
||||
. L.prefilter wlIsOpaque
|
||||
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
|
||||
$ L.minimumOn (dist p1)
|
||||
|
||||
--{- | Checks to see whether someone can fire bullets effectively between two points.
|
||||
-- - Not sure if this needs vision as well, need to make this uniform. -}
|
||||
--collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
--collidePointFire p1 p2 ws
|
||||
-- = safeMinimumOn (dist p1)
|
||||
-- . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine )
|
||||
-- $ IM.filter (\wl -> not (_wlFireThrough wl) || wlIsOpaque wl) ws
|
||||
--{- | Checks to see whether someone can fire bullets effectively between two points.
|
||||
-- - Not sure if this needs vision as well, need to make this uniform. -}
|
||||
--collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
--collidePointFireVision p1 p2 ws
|
||||
-- = any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
|
||||
-- $ IM.filter theTest ws
|
||||
-- where
|
||||
-- theTest wl = not (_wlFireThrough wl) || wlIsOpaque wl
|
||||
|
||||
-- the reason for using the dashed version is the hope that this will short
|
||||
-- circuit
|
||||
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
||||
hasLOSIndirect p1 p2 = not
|
||||
. collidePointTestFilter wlIsOpaque p1 p2
|
||||
@@ -242,95 +220,12 @@ canSee i j w = hasLOS p1 p2 w
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
p2 = _crPos (_creatures w IM.! j)
|
||||
|
||||
--canSeePoint :: Int -> Point2 -> World -> Bool
|
||||
--canSeePoint i p w = hasLOS p1 p w
|
||||
-- where
|
||||
-- p1 = _crPos (_creatures w IM.! i)
|
||||
|
||||
--pathToPointFireable :: Int -> Point2 -> World -> Bool
|
||||
--pathToPointFireable i p w
|
||||
-- = not
|
||||
-- . pointHitsWalls (_crPos $ _creatures w IM.! i) p
|
||||
-- $ IM.filter (not . _wlFireThrough ) $ wallsAlongLine p1 p w
|
||||
-- where
|
||||
-- p1 = _crPos (_creatures w IM.! i)
|
||||
|
||||
--canSeePointAll :: Int -> Point2 -> World -> Bool
|
||||
--canSeePointAll i targPos w
|
||||
-- = all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
-- where
|
||||
-- cr = _creatures w IM.! i
|
||||
-- radius = _crRad cr
|
||||
|
||||
--canSeeAny :: Int -> Int -> World -> Bool
|
||||
--canSeeAny fromID toID w
|
||||
-- = any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
-- where
|
||||
-- cr = _creatures w IM.! toID
|
||||
-- cpos = _crPos cr
|
||||
-- radius = _crRad cr
|
||||
|
||||
--canSeeAll :: Int -> Int -> World -> Bool
|
||||
--canSeeAll fromID toID w
|
||||
-- = all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
-- where
|
||||
-- cr = _creatures w IM.! toID
|
||||
-- cpos = _crPos cr
|
||||
-- radius = _crRad cr
|
||||
|
||||
--canWalk :: Int -> Int -> World -> Bool
|
||||
--canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
|
||||
-- where
|
||||
-- ipos = _crPos (_creatures w IM.! i)
|
||||
-- jpos = _crPos (_creatures w IM.! j)
|
||||
|
||||
canSeeIndirect :: Int -> Int -> World -> Bool
|
||||
canSeeIndirect i j w = hasLOSIndirect ipos jpos w
|
||||
where
|
||||
ipos = _crPos (_creatures w IM.! i)
|
||||
jpos = _crPos (_creatures w IM.! j)
|
||||
|
||||
--canSeeFire :: Point2 -> Point2 -> World -> Bool
|
||||
--canSeeFire p p' w = not $ collidePointFireVision p p' $ wallsAlongLine p p' w
|
||||
|
||||
--canSeeFireVision :: Int -> Int -> World -> Bool
|
||||
--canSeeFireVision i j w = canSeeFire ipos jpos w
|
||||
-- where
|
||||
-- ipos = _crPos (_creatures w IM.! i)
|
||||
-- jpos = _crPos (_creatures w IM.! j)
|
||||
--{- | Test whether both of the outside lines between two creatures are blocked -}
|
||||
--canSeeFireVisionAny :: Int -> Int -> World -> Bool
|
||||
--canSeeFireVisionAny i j w
|
||||
-- = not
|
||||
-- $ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj)
|
||||
-- (wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
|
||||
-- && collidePointFireVision (ipos -.- ni) (jpos -.- nj)
|
||||
-- (wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
|
||||
-- where
|
||||
-- icr = _creatures w IM.! i
|
||||
-- jcr = _creatures w IM.! j
|
||||
-- ipos = _crPos icr
|
||||
-- jpos = _crPos jcr
|
||||
-- n = normalizeV $ vNormal $ ipos -.- jpos
|
||||
-- ni = _crRad icr *.* n
|
||||
-- nj = _crRad jcr *.* n
|
||||
--{- | Test whether either of the outside lines between two creatures are blocked -}
|
||||
--canSeeFireVisionAll :: Int -> Int -> World -> Bool
|
||||
--canSeeFireVisionAll i j w
|
||||
-- = not
|
||||
-- $ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj)
|
||||
-- (wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
|
||||
-- || collidePointFireVision (ipos -.- ni) (jpos -.- nj)
|
||||
-- (wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
|
||||
-- where
|
||||
-- icr = _creatures w IM.! i
|
||||
-- jcr = _creatures w IM.! j
|
||||
-- ipos = _crPos icr
|
||||
-- jpos = _crPos jcr
|
||||
-- n = normalizeV $ vNormal $ ipos -.- jpos
|
||||
-- ni = _crRad icr *.* n
|
||||
-- nj = _crRad jcr *.* n
|
||||
|
||||
wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
|
||||
wallsOnLineHit p1 p2 = IM.mapMaybe f
|
||||
where
|
||||
@@ -341,8 +236,6 @@ wallsOnCirc p r = IM.filter f
|
||||
where
|
||||
f wl = uncurry circOnSeg (_wlLine wl) p r
|
||||
|
||||
--wallNormal :: Wall -> Point2
|
||||
--wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine
|
||||
-- | Looks for overlap of a circle with walls.
|
||||
-- If found, gives wall
|
||||
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
|
||||
|
||||
Reference in New Issue
Block a user