332 lines
12 KiB
Haskell
332 lines
12 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{- | 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
|
|
( collidePoint
|
|
, collidePointWallsFilterStream
|
|
, collidePointTestFilter
|
|
, overlapSegWalls
|
|
, bounceBall
|
|
, bouncePoint
|
|
, sortStreamOn
|
|
, minStreamOn
|
|
-- , wallsOnCirc
|
|
-- , wallsOnCirc'
|
|
, wallsOnLineHit
|
|
, collideCircWallsStream
|
|
, collideCircWalls
|
|
, circOnSomeWall
|
|
, collidePointWallsNorm
|
|
, collidePointWalls'
|
|
, overlapCircWalls
|
|
, overlapCircWallsClosest
|
|
, collideCircCrsPoint
|
|
, collideCircCreatures
|
|
, collidePointCreatures
|
|
, collidePointAnyWallsReflect
|
|
, crsNearPoint
|
|
, crsOnLine
|
|
, crsOnThickLine
|
|
, nearestCrInRad
|
|
, nearestCrInTri
|
|
, nearestCrInFront
|
|
, allVisibleWalls
|
|
|
|
, hasLOS
|
|
, hasLOSIndirect
|
|
, hasButtonLOS
|
|
, canSee
|
|
, canSeeIndirect
|
|
, isWalkable
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Zone
|
|
import Dodge.Base.Wall
|
|
import Geometry
|
|
import FoldableHelp
|
|
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Control.Lens
|
|
import Control.Monad
|
|
--import qualified FoldlHelp as L
|
|
import Data.Monoid
|
|
import StreamingHelp
|
|
import qualified Streaming.Prelude as S
|
|
|
|
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
|
|
|
|
doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
|
|
doBounce x sp ep (p, mwl) = mwl <&> \wl ->
|
|
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
|
, reflVelWallDamp x wl (ep -.- sp)
|
|
)
|
|
|
|
bounceBall :: Float -> Point2 -> Point2 -> Float
|
|
-> Stream (Of Wall) Identity ()
|
|
-> Maybe (Point2,Point2)
|
|
bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
|
|
|
|
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
|
bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
|
|
|
|
-- 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
|
|
|
|
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
|
|
collidePointWallsFilterStream t sp ep = collidePoint sp ep
|
|
. S.filter t
|
|
. wallsAlongLine sp ep
|
|
|
|
overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity ()
|
|
-> Stream (Of (Point2,Wall)) Identity ()
|
|
overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
|
|
|
visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
|
|
visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap
|
|
( S.span (not . wlIsOpaque . snd)
|
|
. sortStreamOn (dist sp . fst)
|
|
. overlapSegWalls sp ep
|
|
. wallsAlongLine sp ep )
|
|
|
|
allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity ()
|
|
allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
|
where
|
|
vPos = _cameraViewFrom w
|
|
|
|
|
|
wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
|
|
wallsOnLineHit p1 p2 = IM.mapMaybe f
|
|
where
|
|
f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
|
|
|
|
-- | 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
|
|
collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
|
collidePointAnyWallsReflect p1 p2
|
|
= getFirst
|
|
. foldMap (First . findPoint . _wlLine)
|
|
where
|
|
findPoint (x,y) = case intersectSegSeg p1 p2 x y of
|
|
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
|
Nothing -> Nothing
|
|
|
|
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)
|
|
|
|
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
|
|
|
|
-- note that this does not push the circle away from the wall at all
|
|
collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity ()
|
|
-> (Point2, Maybe Wall)
|
|
collideCircWallsStream sp ep rad = runIdentity
|
|
. S.fold_ findPoint (ep, Nothing) id
|
|
where
|
|
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
|
. shiftbyrad
|
|
. _wlLine $ wl
|
|
shiftbyrad (a,b) = bimap f f
|
|
(a +.+ rad *.* normalizeV (a -.-b)
|
|
,b +.+ rad *.* normalizeV (b -.-a)
|
|
)
|
|
where
|
|
f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
|
|
|
overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
|
|
overlapCircWallsClosest p r = minStreamOn (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)
|
|
collideCircWalls p1 p2 rad
|
|
= safeMinimumOn (dist p1 . fst)
|
|
. IM.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)
|
|
]
|
|
-- this shifts the wall out, and for outer corners extends the wall
|
|
-- not sure what this does for inner corners, hopefully won't cause a problem
|
|
-- the alternative would be to separately bounce off corner points...
|
|
-- unfortunately, doesn't allow for collisions when the circle spawns on the
|
|
-- wall
|
|
|
|
|
|
-- | Looks for first collision of a point with walls.
|
|
-- If found, gives point and normal of wall.
|
|
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
|
collidePointWallsNorm p1 p2 ws
|
|
= safeMinimumOn (dist p1 . fst)
|
|
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
|
|
. _wlLine) ws
|
|
-- | Returns the first creature, if any, that a point intersects with.
|
|
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
|
|
collidePointCreatures p1 p2 = fmap fst
|
|
. safeMinimumOn snd
|
|
. IM.toList
|
|
. IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
|
|
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
|
|
--fixed amount, thus collides a moving circle with creaures.
|
|
collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
|
|
collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
|
|
|
|
-- | Returns the first creature id, if any, that a point intersects with, gives point
|
|
--in creature on line.
|
|
collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
|
|
collidePointCrsPoint p1 p2 = fmap f
|
|
. safeMinimumOn (dist p1 . snd)
|
|
. IM.toList
|
|
. IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
|
|
where
|
|
f (cID,p) = (p,cID)
|
|
{- | Finds the first creature hit on a line.
|
|
Maybe evaluates the creature id and hit point. -}
|
|
collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int)
|
|
collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
|
|
|
|
---- | Makes a creature not hittable.
|
|
--collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
|
|
--collidePointCrsWithoutPoint cid p1 p2 w
|
|
-- = fmap f
|
|
-- . safeMinimumOn (snd . snd)
|
|
-- . IM.toList
|
|
-- . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
|
|
-- . IM.delete cid
|
|
-- $ _creatures w
|
|
-- where
|
|
-- f (cID,(p,_)) = (p,cID)
|
|
{- | 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)
|
|
. wallsNearPoint p
|
|
-- = any (\(x,y) -> circOnSeg x y p rad)
|
|
-- . fmap _wlLine
|
|
-- . IM.elems
|
|
-- . wallsNearPoint p
|
|
|
|
{- | Produce an unordered list of creatures on a line. -}
|
|
crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
|
|
crsOnLine p1 p2
|
|
= 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 -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness))
|
|
. _creatures
|
|
{- | Find 'Maybe' the closest creature to a point, within a circle.
|
|
-}
|
|
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
|
|
nearestCrInRad p r
|
|
= safeMinimumOn (dist p . _crPos)
|
|
. IM.filter (\cr -> dist p (_crPos cr) < r)
|
|
. _creatures
|
|
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. -}
|
|
nearestCrInTri
|
|
:: Point2
|
|
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
|
-> Float -- ^ Distance.
|
|
-> World -> Maybe Creature
|
|
nearestCrInTri p dir x
|
|
= safeMinimumOn (dist p . _crPos)
|
|
. IM.filter (\cr -> pointInPolygon (_crPos cr) tri)
|
|
. _creatures
|
|
where
|
|
tri =
|
|
[p
|
|
,p +.+ rotateV (dir-pi/4) (V2 x 0)
|
|
,p +.+ rotateV (dir+pi/4) (V2 x 0)
|
|
]
|
|
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
|
|
a given distance.
|
|
The shapes within which creatures are searched are a triangle then rectangle. -}
|
|
nearestCrInFront
|
|
:: Point2
|
|
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
|
-> Float -- ^ Distance.
|
|
-> World -> Maybe Creature
|
|
nearestCrInFront p dir x
|
|
= safeMinimumOn (dist p . _crPos)
|
|
. IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
|
|
. _creatures
|
|
where
|
|
rec = [p, pR, pR1, pL1, pL ]
|
|
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
|
|
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)
|