Refactoring
This commit is contained in:
@@ -0,0 +1,211 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{- | Basic collision detection for a moving point -}
|
||||
module Dodge.Base.Collide
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.Zone
|
||||
import Geometry
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
|
||||
hasLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOS #-}
|
||||
hasLOS p1 p2 w = (not $ pointHitsWalls p1 p2 nearbyWalls)
|
||||
where
|
||||
nearbyWalls = wallsAlongLine p1 p2 w
|
||||
-- | 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
|
||||
= listToMaybe
|
||||
. sortOn f
|
||||
. IM.elems
|
||||
$ IM.mapMaybe
|
||||
(( \(x:y:_) ->
|
||||
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
|
||||
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
|
||||
)
|
||||
(intersectSegSeg' p1 p2 x y)
|
||||
)
|
||||
. _wlLine) ws
|
||||
where
|
||||
f (a,_) = magV (p1 -.- a)
|
||||
-- | 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
|
||||
= listToMaybe
|
||||
. sortOn f
|
||||
. IM.elems
|
||||
$ IM.mapMaybe
|
||||
(( \(x:y:_) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
|
||||
. (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
|
||||
(intersectSegSeg' p1 p2 x y))
|
||||
. _wlLine
|
||||
) ws
|
||||
where
|
||||
f (a,_) = magV (p1 -.- a)
|
||||
-- | Test if a point collides with walls
|
||||
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
pointHitsWalls p1 p2
|
||||
= any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine
|
||||
-- | Test if there something blocking a walk
|
||||
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
collidePointWalkable p1 p2 ws
|
||||
= any (isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
|
||||
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
|
||||
|
||||
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
|
||||
furthestPointWalkable p1 p2 ws
|
||||
= fromMaybe p2
|
||||
. listToMaybe
|
||||
. sortOn (dist p1)
|
||||
. IM.elems
|
||||
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
|
||||
|
||||
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
{-# INLINE collidePointIndirect #-}
|
||||
collidePointIndirect p1 p2 ws
|
||||
= listToMaybe
|
||||
. sortOn (dist p1)
|
||||
. IM.elems
|
||||
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
|
||||
$ IM.filter (not . _wlIsSeeThrough) 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. -}
|
||||
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
collidePointFire p1 p2 ws
|
||||
= listToMaybe
|
||||
. sortOn (dist p1)
|
||||
. IM.elems
|
||||
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _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 . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _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 nearbyWalls
|
||||
where
|
||||
nearbyWalls = 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)
|
||||
nearbyWalls = wallsAlongLine p1 p2 w
|
||||
|
||||
canSeePoint :: Int -> Point2 -> World -> Bool
|
||||
canSeePoint i p w = hasLOS p1 p w
|
||||
where
|
||||
nearbyWalls = wallsAlongLine p1 p w
|
||||
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 (not . isJust . \wl -> wl ^? blHP) $ wallsAlongLine p1 p w
|
||||
where
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
|
||||
canSeePointAll :: Int -> Point2 -> World -> Bool
|
||||
canSeePointAll i targPos w
|
||||
= and
|
||||
$ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
where
|
||||
cr = _creatures w IM.! i
|
||||
cpos = _crPos cr
|
||||
radius = _crRad cr
|
||||
|
||||
canSeeAny :: Int -> Int -> World -> Bool
|
||||
canSeeAny fromID toID w
|
||||
= or
|
||||
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(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
|
||||
= and
|
||||
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(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 = not . isJust . 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
|
||||
Reference in New Issue
Block a user