355 lines
11 KiB
Haskell
355 lines
11 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,
|
|
collidePointWallsFilter,
|
|
collidePointTestFilter,
|
|
collideCircWalls,
|
|
overlapSegWalls,
|
|
overlapSegCrs,
|
|
bouncePoint,
|
|
circOnSomeWall,
|
|
circOnAnyCr,
|
|
overlapCircWalls,
|
|
overlapCircWallsClosest,
|
|
crsNearPoint,
|
|
allVisibleWalls,
|
|
hasLOS,
|
|
hasLOSIndirect,
|
|
hasButtonLOS,
|
|
canSee,
|
|
canSeeIndirect,
|
|
anythingHitCirc,
|
|
collide3WallsFloor,
|
|
collide3,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import qualified Data.IntSet as IS
|
|
import Data.List (sortOn)
|
|
import Data.Maybe
|
|
import Dodge.Base.Wall
|
|
import Dodge.Creature.Radius
|
|
import Dodge.Data.Object
|
|
import Dodge.Data.World
|
|
import Dodge.Zoning
|
|
import FoldableHelp
|
|
import Geometry
|
|
import Linear
|
|
|
|
collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall)
|
|
{-# INLINE collidePoint #-}
|
|
collidePoint sp ep = foldl' f (ep, Nothing)
|
|
where
|
|
f (p, mwl) wl =
|
|
maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
|
|
|
overlapSegCrs :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
|
|
{-# INLINE overlapSegCrs #-}
|
|
overlapSegCrs sp ep = mapMaybe f
|
|
where
|
|
f cr =
|
|
(,cr)
|
|
<$> fst (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)
|
|
|
|
doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
|
|
{-# INLINE doBounce #-}
|
|
doBounce x sp ep (p, mwl) = fmap f mwl
|
|
where
|
|
f wl =
|
|
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
|
, reflVelWallDamp x wl (ep -.- sp)
|
|
)
|
|
|
|
--bounceBall ::
|
|
-- Float ->
|
|
-- Point2 ->
|
|
-- Point2 ->
|
|
-- Float ->
|
|
-- [Wall] ->
|
|
-- Maybe (Point2, Point2)
|
|
--{-# INLINE bounceBall #-}
|
|
--bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
|
|
|
|
bouncePoint ::
|
|
(Wall -> Bool) ->
|
|
Float ->
|
|
Point2 ->
|
|
Point2 ->
|
|
World ->
|
|
Maybe (Point2, Point2)
|
|
{-# INLINE bouncePoint #-}
|
|
bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilter t sp ep
|
|
|
|
type MPO = Maybe (Point3, Object)
|
|
|
|
collide3WallsFloor :: Point3 -> Point3 -> World -> (Point3, MPO)
|
|
collide3WallsFloor sp ep w =
|
|
collide3Floors sp (w ^. cWorld . chasms) $
|
|
collide3Walls sp w (ep, Nothing)
|
|
|
|
-- could check the line is at least below z=0 at some point
|
|
collide3Chasms :: Point3 -> World -> (Point3, MPO) -> (Point3, MPO)
|
|
collide3Chasms sp w m =
|
|
foldl'
|
|
(flip (collide3Chasm sp))
|
|
m
|
|
(foldMap loopPairs $ w ^. cWorld . chasms)
|
|
|
|
collide3Chasm :: Point3 -> (Point2, Point2) -> (Point3, MPO) -> (Point3, MPO)
|
|
collide3Chasm sp ab (ep, m) =
|
|
maybe (ep, m) (,Just (n, OChasmWall)) $
|
|
intersectSegSurface sp ep p n ss
|
|
where
|
|
(p, n, ss) = chasmWallToSurface ab
|
|
|
|
chasmWallToSurface :: (Point2, Point2) -> (Point3, Point3, [(Point3, Point3)])
|
|
chasmWallToSurface (x, y) =
|
|
( g x
|
|
, g $ vNormal (x - y)
|
|
, [(g x, g (y - x)), (g y, g (x - y)), (0, V3 0 0 (-1))]
|
|
)
|
|
where
|
|
g = (`v2z` 0)
|
|
|
|
collide3 :: Point3 -> Point3 -> World -> (Point3, MPO)
|
|
collide3 sp ep w =
|
|
collide3Chasms sp w
|
|
. foldl' (flip $ collide3Creature sp) (p, m)
|
|
$ crsNearSeg (xyV3 sp) (xyV3 p) w
|
|
where
|
|
(p, m) = collide3WallsFloor sp ep w
|
|
|
|
-- Just (hitpoint,normaltosurface)
|
|
collide3Walls :: Point3 -> World -> (Point3, MPO) -> (Point3, MPO)
|
|
collide3Walls sp w e@(ep, _) = foldl' f e $ wlsNearSeg (xyV3 sp) (xyV3 ep) w
|
|
where
|
|
f x wl = collide3Wall sp wl x
|
|
|
|
collide3Floors ::
|
|
Point3 ->
|
|
[[Point2]] ->
|
|
(Point3, Maybe (Point3, Object)) ->
|
|
(Point3, Maybe (Point3, Object))
|
|
collide3Floors sp cs (ep, mn) = maybe (ep, mn) (,Just (V3 0 0 1, OFloor)) mp
|
|
where
|
|
mp = do
|
|
V3 x y z <- intersectSegPlane sp ep (V3 0 0 0) (V3 0 0 1)
|
|
let g (a, b) = isRHS a b (V2 x y)
|
|
f = any g
|
|
guard (all (f . loopPairs) cs)
|
|
return (V3 x y z)
|
|
|
|
collide3Wall :: Point3 -> Wall -> (Point3, MPO) -> (Point3, MPO)
|
|
collide3Wall sp wl (ep, mo) = maybe (ep, mo) (,Just (n, OWall wl)) $ intersectSegSurface sp ep p n ss
|
|
where
|
|
(p, n, ss) = wallToSurface wl
|
|
|
|
collide3Creature :: Point3 -> Creature -> (Point3, MPO) -> (Point3, MPO)
|
|
collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do
|
|
h <- crHeight cr
|
|
(p, n) <-
|
|
fst $
|
|
intersectCylSeg
|
|
(cr ^. crPos)
|
|
(crRad $ cr ^. crType)
|
|
h
|
|
sp
|
|
ep
|
|
return (p, Just (n, OCreature cr))
|
|
|
|
crHeight :: Creature -> Maybe Float
|
|
crHeight cr = case cr ^. crHP of
|
|
HP{} -> Just 25
|
|
CrIsCorpse{} -> Just 5
|
|
CrIsGibs -> Nothing
|
|
CrIsPitted -> Nothing
|
|
|
|
wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
|
|
wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])
|
|
where
|
|
g = (`v2z` 0)
|
|
(x, y) = _wlLine wl
|
|
|
|
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
|
-- whether this is actually faster
|
|
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
|
|
{-# INLINE collidePointTestFilter #-}
|
|
collidePointTestFilter t sp ep =
|
|
any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
|
. filter t
|
|
|
|
---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
|
---- whether this is actually faster
|
|
--collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
|
|
--{-# INLINE collidePointTestFilter #-}
|
|
--collidePointTestFilter t sp ep = runIdentity
|
|
-- . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
|
-- . S.filter t
|
|
|
|
collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
|
|
{-# INLINE collidePointWallsFilter #-}
|
|
collidePointWallsFilter t sp ep = collidePoint sp ep . filter t . wlsNearSeg sp ep
|
|
|
|
--overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
|
|
-- -> StreamOf (Point2,Wall)
|
|
--{-# INLINE overlapSegWalls #-}
|
|
--overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
|
|
|
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)]
|
|
{-# INLINE overlapSegWalls #-}
|
|
overlapSegWalls sp ep = mapMaybe
|
|
$ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
|
|
|
visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
|
|
{-# INLINE visibleWalls #-}
|
|
visibleWalls sp ep =
|
|
takeUntil (wlIsOpaque . snd)
|
|
. sortOn (dist sp . fst)
|
|
. overlapSegWalls sp ep
|
|
. wlsNearSeg sp ep
|
|
|
|
allVisibleWalls :: World -> [(Point2, Wall)]
|
|
{-# INLINE allVisibleWalls #-}
|
|
allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 15
|
|
where
|
|
vPos = w ^. wCam . camViewFrom
|
|
|
|
overlapCircWalls ::
|
|
Point2 ->
|
|
Float ->
|
|
[Wall] ->
|
|
[(Point2, Wall)]
|
|
{-# INLINE overlapCircWalls #-}
|
|
overlapCircWalls p r = mapMaybe dointersect
|
|
where
|
|
dointersect wl = f (_wlLine wl) <&> (,wl)
|
|
f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
|
|
|
circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
|
|
circHitWall sp ep r w =
|
|
any
|
|
(uncurry (intersectSegSegTest xsp xep) . _wlLine)
|
|
(wlsNearSeg xsp xep w)
|
|
|| circOnSomeWall ep r w
|
|
where
|
|
x = r *.* normalizeV (ep - sp)
|
|
xsp = sp - x
|
|
xep = ep + x
|
|
|
|
-- | note that this does not push the circle away from the wall at all
|
|
collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
|
|
{-# INLINE collideCircWalls #-}
|
|
collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
|
|
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 -> [Wall] -> Maybe (Point2, Wall)
|
|
{-# INLINE overlapCircWallsClosest #-}
|
|
overlapCircWallsClosest p r =
|
|
safeMinimumOn (dist p . fst)
|
|
. overlapCircWalls p r
|
|
|
|
--overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
|
|
--{-# INLINE overlapCircWallsClosest #-}
|
|
--overlapCircWallsClosest p r = minStreamOn (dist p . fst)
|
|
-- . overlapCircWalls p r
|
|
|
|
{- | Test if a circle collides with any wall.
|
|
- Note no check on whether the wall is walkable.
|
|
-}
|
|
circOnSomeWall :: Point2 -> Float -> World -> Bool
|
|
{-# INLINE circOnSomeWall #-}
|
|
circOnSomeWall p rad =
|
|
any (uncurry (circOnSeg p rad) . _wlLine)
|
|
. wlsNearCirc p rad
|
|
|
|
circOnAnyCr :: Point2 -> Float -> World -> Bool
|
|
{-# INLINE circOnAnyCr #-}
|
|
circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
|
|
where
|
|
f cid bl =
|
|
maybe
|
|
False
|
|
(\cr -> dist p (cr ^. crPos . _xy) < r + crRad (cr ^. crType))
|
|
(w ^? cWorld . lWorld . creatures . ix cid)
|
|
|| bl
|
|
|
|
-- | More general collision tests follow
|
|
hasLOS :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE hasLOS #-}
|
|
hasLOS p1 p2 =
|
|
not
|
|
. collidePointTestFilter (const True) p1 p2
|
|
. wlsNearSeg p1 p2
|
|
|
|
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE hasButtonLOS #-}
|
|
hasButtonLOS _ _ = const True
|
|
|
|
--hasButtonLOS p1 p2 =
|
|
-- not
|
|
-- . collidePointTestFilter (not . _wlTouchThrough) p1 p2
|
|
-- . wlsNearSeg p1 p2
|
|
|
|
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE hasLOSIndirect #-}
|
|
hasLOSIndirect p1 p2 =
|
|
not
|
|
. collidePointTestFilter wlIsOpaque p1 p2
|
|
. wlsNearSeg p1 p2
|
|
|
|
|
|
canSee :: Int -> Int -> World -> Bool
|
|
{-# INLINE canSee #-}
|
|
canSee i j w = hasLOS p1 p2 w
|
|
where
|
|
p1 = w ^?! cWorld . lWorld . creatures . ix i . crPos . _xy
|
|
p2 = w ^?! cWorld . lWorld . creatures . ix j . crPos . _xy
|
|
|
|
canSeeIndirect :: Int -> Int -> World -> Bool
|
|
{-# INLINE canSeeIndirect #-}
|
|
canSeeIndirect i j w = hasLOSIndirect ipos jpos w
|
|
where
|
|
ipos = w ^?! cWorld . lWorld . creatures . ix i . crPos . _xy
|
|
jpos = w ^?! cWorld . lWorld . creatures . ix j . crPos . _xy
|
|
|
|
anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
|
|
anythingHitCirc rad sp ep w = hitCr || circHitWall sp ep rad w
|
|
where
|
|
x = rad *.* normalizeV (ep - sp)
|
|
xsp = sp - x
|
|
xep = ep + x
|
|
hitCr = IS.foldr f False $ crixsNearSeg xsp xep w
|
|
f cid bl =
|
|
maybe
|
|
False
|
|
(\cr -> intersectCircSegTest (cr ^. crPos . _xy) (rad + crRad (cr ^. crType)) sp ep)
|
|
(w ^? cWorld . lWorld . creatures . ix cid)
|
|
|| bl
|