231 lines
7.6 KiB
Haskell
231 lines
7.6 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
|
|
, collideSegCrs
|
|
, collidePointWallsFilterStream
|
|
, collidePointTestFilter
|
|
, overlapSegWalls
|
|
, overlapSegCrs
|
|
, overlap1SegCrs
|
|
, bounceBall
|
|
, bouncePoint
|
|
, sortStreamOn
|
|
, minStreamOn
|
|
, collideCircWallsStream
|
|
, circOnSomeWall
|
|
, circOnAnyCr
|
|
, overlapCircWalls
|
|
, overlapCircWallsClosest
|
|
, crsNearPoint
|
|
, allVisibleWalls
|
|
|
|
, hasLOS
|
|
, hasLOSIndirect
|
|
, hasButtonLOS
|
|
, canSee
|
|
, canSeeIndirect
|
|
, isWalkable
|
|
|
|
, anythingHitCirc
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Zone
|
|
import Dodge.Zoning
|
|
import Dodge.Base.Wall
|
|
import Geometry
|
|
|
|
import Data.Maybe
|
|
import qualified IntMapHelp as IM
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import StreamingHelp
|
|
import qualified Streaming.Prelude as S
|
|
import qualified Data.IntSet as IS
|
|
|
|
collidePoint :: Point2 -> Point2
|
|
-> StreamOf Wall
|
|
-> (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
|
|
|
|
overlap1SegCrs :: Point2 -> Point2
|
|
-> [Creature]
|
|
-> [(Point2, Creature)]
|
|
{-# INLINE overlap1SegCrs #-}
|
|
overlap1SegCrs sp ep = mapMaybe
|
|
(\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep ))
|
|
|
|
overlapSegCrs :: Point2 -> Point2
|
|
-> StreamOf Creature
|
|
-> StreamOf ([Point2], Creature)
|
|
{-# INLINE overlapSegCrs #-}
|
|
overlapSegCrs sp ep = S.mapMaybe
|
|
(\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep )
|
|
where
|
|
f _ [] = Nothing
|
|
f cr ps = Just (ps,cr)
|
|
|
|
collideSegCrs :: Point2 -> Point2
|
|
-> StreamOf Creature
|
|
-> (Point2, Maybe Creature)
|
|
{-# INLINE collideSegCrs #-}
|
|
collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
|
|
where
|
|
findPoint (p,mcr) cr
|
|
= maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
|
|
|
|
doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
|
|
{-# INLINE doBounce #-}
|
|
doBounce x sp ep (p, mwl) = mwl <&> \wl ->
|
|
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
|
, reflVelWallDamp x wl (ep -.- sp)
|
|
)
|
|
|
|
bounceBall :: Float -> Point2 -> Point2 -> Float
|
|
-> StreamOf Wall
|
|
-> Maybe (Point2,Point2)
|
|
{-# INLINE bounceBall #-}
|
|
bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
|
|
|
|
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
|
{-# INLINE bouncePoint #-}
|
|
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 -> StreamOf Wall -> Bool
|
|
{-# INLINE collidePointTestFilter #-}
|
|
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)
|
|
{-# INLINE collidePointWallsFilterStream #-}
|
|
collidePointWallsFilterStream t sp ep = collidePoint sp ep
|
|
. S.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)
|
|
|
|
visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
|
|
{-# INLINE visibleWalls #-}
|
|
visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap
|
|
( S.span (not . wlIsOpaque . snd)
|
|
. sortStreamOn (dist sp . fst)
|
|
. overlapSegWalls sp ep
|
|
. wlsNearSeg sp ep )
|
|
|
|
allVisibleWalls :: World -> StreamOf (Point2,Wall)
|
|
{-# INLINE allVisibleWalls #-}
|
|
allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
|
where
|
|
vPos = _cameraViewFrom w
|
|
|
|
overlapCircWalls :: Point2 -> Float -> StreamOf Wall
|
|
-> StreamOf (Point2,Wall)
|
|
{-# INLINE overlapCircWalls #-}
|
|
overlapCircWalls p r = S.mapMaybe dointersect
|
|
where
|
|
dointersect wl = f (_wlLine wl) <&> (,wl)
|
|
f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
|
|
|
-- | note that this does not push the circle away from the wall at all
|
|
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
|
|
-> (Point2, Maybe Wall)
|
|
{-# INLINE collideCircWallsStream #-}
|
|
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 -> 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 = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
|
|
. wlsNearPoint p
|
|
|
|
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 (_crPos cr) < r + _crRad cr) (w ^? 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 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
|
|
|
|
isWalkable :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE isWalkable #-}
|
|
isWalkable p1 p2 = not
|
|
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
|
|
. wlsNearSeg p1 p2
|
|
|
|
canSee :: Int -> Int -> World -> Bool
|
|
{-# INLINE canSee #-}
|
|
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
|
|
{-# INLINE canSeeIndirect #-}
|
|
canSeeIndirect i j w = hasLOSIndirect ipos jpos w
|
|
where
|
|
ipos = _crPos (_creatures w IM.! i)
|
|
jpos = _crPos (_creatures w IM.! j)
|
|
|
|
anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
|
|
anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
|
|
where
|
|
hitCr = IS.foldr f False $ crsNearSeg sp ep w
|
|
f cid bl = maybe False (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
|
|
(w ^? creatures . ix cid)
|
|
|| bl
|
|
|
|
hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
|
|
-- this should probably be wallsOnLine or something
|