227 lines
7.8 KiB
Haskell
227 lines
7.8 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{- | Basic collision detection for a moving point -}
|
|
module Dodge.Base.Collide
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base.Zone
|
|
import Geometry
|
|
import FoldableHelp
|
|
|
|
--import Data.List
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Control.Lens
|
|
import qualified FoldlHelp as L
|
|
|
|
hasLOS :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE hasLOS #-}
|
|
hasLOS p1 p2 w = not $ pointHitsWalls p1 p2 $ wallsAlongLine p1 p2 w
|
|
|
|
hitPointLines
|
|
:: Point2
|
|
-> Point2
|
|
-> [(Point2,Point2)]
|
|
-> Maybe (Point2,(Point2,Point2))
|
|
hitPointLines p1 p2
|
|
= safeMinimumOn (dist p1 . fst)
|
|
. mapMaybe
|
|
(\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y)
|
|
|
|
-- | 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 ws
|
|
= 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) ws
|
|
-- | 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
|
|
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
|
pointHitsWalls p1 p2
|
|
= any $ isJust . uncurry (intersectSegSeg p1 p2) . _wlLine
|
|
-- | Test if there something blocking a walk
|
|
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
|
collidePointWalkable p1 p2 ws
|
|
= any (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
|
|
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
|
|
|
|
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
|
|
furthestPointWalkable p1 p2 ws
|
|
= fromMaybe p2
|
|
. safeMinimumOn (dist p1)
|
|
$ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws
|
|
|
|
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 (not . _wlIsSeeThrough)
|
|
. L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine)
|
|
) L.minimum
|
|
wls
|
|
where
|
|
p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
|
|
|
|
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
|
{-# INLINE collidePointIndirect #-}
|
|
collidePointIndirect p1 p2
|
|
= L.fold
|
|
. L.prefilter (not . _wlIsSeeThrough)
|
|
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
|
|
$ L.minimumOn (dist p1)
|
|
--collidePointIndirect p1 p2
|
|
-- = safeMinimumOn (dist p1)
|
|
-- . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine)
|
|
-- . IM.filter (not . _wlIsSeeThrough)
|
|
|
|
{- | 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 (_wlIsSeeThrough wl && isJust (wl ^? blHP))) 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 notBlockWindow ws
|
|
where
|
|
notBlockWindow wl = case wl ^? blHP of
|
|
Just _ -> not $ _wlIsSeeThrough wl
|
|
Nothing -> True
|
|
|
|
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
|
hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w of
|
|
Just _ -> False
|
|
Nothing -> True
|
|
|
|
isWalkable :: Point2 -> Point2 -> World -> Bool
|
|
isWalkable p1 p2 w = not
|
|
$ collidePointWalkable p1 p2
|
|
$ wallsAlongLine p1 p2 w
|
|
|
|
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)
|
|
|
|
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 (isNothing . (^? blHP) ) $ 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 = isNothing . collidePointIndirect ipos jpos $ wallsAlongLine 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
|