Cleanup
This commit is contained in:
+72
-163
@@ -1,19 +1,22 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{- | Basic collision detection for a moving point -}
|
||||
{- | Basic collision detection for a moving point.
|
||||
- Conventions: input is typically a stream of walls.
|
||||
- Collide returns an endpoint and maybe a collided with
|
||||
- object (wall).
|
||||
- Reflect maybe gives a slightly pushed out point from a collision and a
|
||||
- relection velocity.
|
||||
- Overlap returns a stream of walls.
|
||||
- A point will typically be moving.
|
||||
- A ball refers to a moving circle, i.e. a point with a radius.
|
||||
- -}
|
||||
module Dodge.Base.Collide
|
||||
( hasLOS
|
||||
, collidePointWallsWall
|
||||
( collidePoint
|
||||
, collidePointWallsFilterStream
|
||||
, reflectPointWallsDamp
|
||||
, reflectCircWallsDamp
|
||||
, hasButtonLOS
|
||||
, reflectPointWalls
|
||||
, collidePointTestFilter
|
||||
, bounceBall
|
||||
, bouncePoint
|
||||
, ssfold
|
||||
, collidePointUpToIndirectMinDist
|
||||
, canSeeIndirect
|
||||
, isWalkable
|
||||
, canSee
|
||||
, hasLOSIndirect
|
||||
, wlIsOpaque
|
||||
, wlIsSeeThrough
|
||||
, wallsOnCirc
|
||||
@@ -21,14 +24,9 @@ module Dodge.Base.Collide
|
||||
, wallsOnLineHit
|
||||
, collideCircWallsStream
|
||||
, collideCircWalls
|
||||
, collideCircWallsList
|
||||
-- , collideCircWalls'
|
||||
, circOnSomeWall
|
||||
, collidePointWalls
|
||||
, collidePointWallsNorm
|
||||
, collidePointWalls'
|
||||
-- , collidePointWallsL
|
||||
, collidePointWallsFilt
|
||||
, overlapCircWalls
|
||||
, overlapCircWallsClosest
|
||||
, collideCircCrsPoint
|
||||
@@ -42,6 +40,13 @@ module Dodge.Base.Collide
|
||||
, nearestCrInTri
|
||||
, nearestCrInFront
|
||||
, allVisibleWalls
|
||||
|
||||
, hasLOS
|
||||
, hasLOSIndirect
|
||||
, hasButtonLOS
|
||||
, canSee
|
||||
, canSeeIndirect
|
||||
, isWalkable
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Zone
|
||||
@@ -60,22 +65,20 @@ 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
|
||||
--
|
||||
collidePoint :: Point2 -> Point2
|
||||
-> Stream (Of Wall) Identity ()
|
||||
-> (Point2, Maybe Wall)
|
||||
{-# INLINE collidePoint #-}
|
||||
collidePoint sp ep = runIdentity
|
||||
. S.fold_ findPoint (ep, Nothing) id
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
hasLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOS #-}
|
||||
hasLOS p1 p2 = not
|
||||
. collidePointTestFilter (const True) p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasButtonLOS #-}
|
||||
hasButtonLOS p1 p2 = not
|
||||
. collidePointTestFilter (not . _wlTouchThrough) p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
reflectCircWallsDamp :: Float -> Point2 -> Point2 -> Float -> Stream (Of Wall) Identity ()
|
||||
bounceBall :: Float -> Point2 -> Point2 -> Float
|
||||
-> Stream (Of Wall) Identity ()
|
||||
-> Maybe (Point2,Point2)
|
||||
reflectCircWallsDamp x sp ep r w = do
|
||||
bounceBall x sp ep r w = do
|
||||
wl <- mwl
|
||||
return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
||||
, reflVelWallDamp x wl (ep -.- sp)
|
||||
@@ -83,8 +86,8 @@ reflectCircWallsDamp x sp ep r w = do
|
||||
where
|
||||
(p, mwl) = collideCircWallsStream sp ep r w
|
||||
|
||||
reflectPointWallsDamp :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
||||
reflectPointWallsDamp t x sp ep w = do
|
||||
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
||||
bouncePoint t x sp ep w = do
|
||||
wl <- mwl
|
||||
return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
||||
, reflVelWallDamp x wl (ep -.- sp)
|
||||
@@ -92,47 +95,6 @@ reflectPointWallsDamp t x sp ep w = do
|
||||
where
|
||||
(p, mwl) = collidePointWallsFilterStream t sp ep w
|
||||
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and wall.
|
||||
-- (This can probably be improved, eg by folding over the walls and on finding a
|
||||
-- wall moving the end point to the collision point, but the returns in speed
|
||||
-- are probably minimal)
|
||||
collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall)
|
||||
collidePointWallsWall p1 p2
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
. IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) )
|
||||
|
||||
-- | looks for first collision of a point with walls
|
||||
-- if found, gives point and reflection velocity
|
||||
reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
reflectPointWalls p1 p2
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
. IM.mapMaybe
|
||||
(( \(x,y) ->
|
||||
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
|
||||
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
|
||||
)
|
||||
(intersectSegSeg p1 p2 x y)
|
||||
)
|
||||
. _wlLine)
|
||||
---- | Looks for first collision of a point with walls.
|
||||
---- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
--reflectPointWallsDamped
|
||||
-- :: Float -- ^ Damping factor, probably should be in (0,1)
|
||||
-- -> Point2
|
||||
-- -> Point2
|
||||
-- -> IM.IntMap Wall
|
||||
-- -> Maybe (Point2,Point2)
|
||||
--reflectPointWallsDamped dfact p1 p2 ws
|
||||
-- = safeMinimumOn (dist p1 . fst)
|
||||
-- $ IM.mapMaybe
|
||||
-- (( \(x,y) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
|
||||
-- . (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
|
||||
-- (intersectSegSeg p1 p2 x y))
|
||||
-- . _wlLine
|
||||
-- ) ws
|
||||
-- | Test if a point collides with walls
|
||||
|
||||
-- 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
|
||||
@@ -141,12 +103,9 @@ collidePointTestFilter t sp ep = runIdentity
|
||||
. S.filter t
|
||||
|
||||
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
|
||||
collidePointWallsFilterStream t sp ep = runIdentity
|
||||
. S.fold_ findPoint (ep, Nothing) id
|
||||
collidePointWallsFilterStream t sp ep = collidePoint sp ep
|
||||
. S.filter t
|
||||
. wallsAlongLine sp ep
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
--visibleWallWalls' :: Point2 -> Point2 -> World -> M.Map Float Wall
|
||||
--visibleWallWalls' sp ep = L.purely S.fold L.map . visibleWallWalls sp ep
|
||||
@@ -210,27 +169,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
|
||||
|
||||
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
||||
hasLOSIndirect p1 p2 = not
|
||||
. collidePointTestFilter wlIsOpaque p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
isWalkable :: Point2 -> Point2 -> World -> Bool
|
||||
isWalkable p1 p2 = not
|
||||
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
canSee :: Int -> Int -> World -> Bool
|
||||
canSee i j w = hasLOS p1 p2 w
|
||||
where
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
p2 = _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)
|
||||
|
||||
wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
|
||||
wallsOnLineHit p1 p2 = IM.mapMaybe f
|
||||
@@ -255,67 +193,12 @@ collidePointAnyWallsReflect p1 p2
|
||||
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
Nothing -> Nothing
|
||||
|
||||
-- | Looks for collision of a point with walls.
|
||||
-- If found, gives collision point
|
||||
-- If not found, returns point
|
||||
collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
|
||||
{-# INLINE collidePointWalls #-}
|
||||
collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine
|
||||
where
|
||||
findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
|
||||
collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2
|
||||
{-# INLINE collidePointWalls' #-}
|
||||
collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
|
||||
where
|
||||
findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
|
||||
|
||||
--collidePointWallsL :: Point2 -> Point2 -> L.Fold Wall Point2
|
||||
--collidePointWallsL p1 p2 = L.Fold findPoint p2 id
|
||||
-- where
|
||||
-- findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine
|
||||
|
||||
collidePointWallsFilt :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
|
||||
{-# INLINE collidePointWallsFilt #-}
|
||||
collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t
|
||||
|
||||
-- | Looks for first collision of a circle with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
-- note that the "intersection" point is the center of the circle flush against the wall
|
||||
--collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
--collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2)
|
||||
-- where
|
||||
-- findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl
|
||||
-- getp (Left p) = p
|
||||
-- getp (Right (p,_)) = p
|
||||
-- doReflection p (x,y) = case intersectSegSeg p1 p x y of
|
||||
-- Nothing -> Nothing
|
||||
-- Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
-- shiftByRad (a,b) =
|
||||
-- (g $ a +.+ rad *.* normalizeV (a -.-b)
|
||||
-- ,g $ b +.+ rad *.* normalizeV (b -.-a)
|
||||
-- )
|
||||
-- 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)
|
||||
]
|
||||
|
||||
overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity ()
|
||||
-> Stream (Of (Point2,Wall)) Identity ()
|
||||
overlapCircWalls p r = S.mapMaybe dointersect
|
||||
@@ -369,16 +252,6 @@ collideCircWalls p1 p2 rad
|
||||
-- unfortunately, doesn't allow for collisions when the circle spawns on the
|
||||
-- wall
|
||||
|
||||
-- | Looks for first collision of a point with a list of lines.
|
||||
-- If found, gives point and normal of wall.
|
||||
--collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
|
||||
--collidePointLines p1 p2 ws
|
||||
-- = safeMinimumOn f
|
||||
-- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
|
||||
-- . _wlLine') ws
|
||||
-- where
|
||||
-- f (a,_) = magV (p1 -.- a)
|
||||
--
|
||||
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and normal of wall.
|
||||
@@ -487,3 +360,39 @@ nearestCrInFront p dir x
|
||||
pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0)
|
||||
pR1 = pR +.+ rotateV dir (V2 (x/2) 0)
|
||||
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
|
||||
|
||||
{- | More general collision tests follow -}
|
||||
|
||||
hasLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOS #-}
|
||||
hasLOS p1 p2 = not
|
||||
. collidePointTestFilter (const True) p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasButtonLOS #-}
|
||||
hasButtonLOS p1 p2 = not
|
||||
. collidePointTestFilter (not . _wlTouchThrough) p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
||||
hasLOSIndirect p1 p2 = not
|
||||
. collidePointTestFilter wlIsOpaque p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
isWalkable :: Point2 -> Point2 -> World -> Bool
|
||||
isWalkable p1 p2 = not
|
||||
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
|
||||
. wallsAlongLine p1 p2
|
||||
|
||||
canSee :: Int -> Int -> World -> Bool
|
||||
canSee i j w = hasLOS p1 p2 w
|
||||
where
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
p2 = _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)
|
||||
|
||||
Reference in New Issue
Block a user