278 lines
9.6 KiB
Haskell
278 lines
9.6 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{- | Basic collision detection for a moving point -}
|
|
module Dodge.Base.Collide
|
|
( hasLOS
|
|
, hasButtonLOS
|
|
, reflectPointWalls
|
|
, ssfold
|
|
, collidePointUpToIndirectMinDist
|
|
, canSeeIndirect
|
|
, isWalkable
|
|
, canSee
|
|
, hasLOSIndirect
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.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 = not . pointHitsWalls p1 p2 . wallsAlongLine p1 p2
|
|
|
|
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE hasButtonLOS #-}
|
|
hasButtonLOS p1 p2 = not . pointHitsWalls p1 p2
|
|
. IM.filter (not . _wlTouchThrough)
|
|
. wallsAlongLine p1 p2
|
|
|
|
--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 . (^? wlPathable)) 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 wlIsOpaque
|
|
-- . L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine)
|
|
-- ) L.minimum
|
|
-- wls
|
|
-- where
|
|
-- p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
|
|
|
|
wlIsOpaque :: Wall -> Bool
|
|
wlIsOpaque wl = _wlOpacity wl == Opaque
|
|
|
|
--collidePointUpToIndirect
|
|
-- :: Point2 -- ^start point
|
|
-- -> Point2 -- ^end point
|
|
-- -> IM.IntMap Wall
|
|
-- -> Point2
|
|
--{-# INLINE collidePointUpToIndirect #-}
|
|
--collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter wlIsOpaque
|
|
-- where
|
|
-- f wl x = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
|
|
|
|
collidePointUpToIndirectMinDist
|
|
:: Point2 -- ^start point
|
|
-> Point2 -- ^end point
|
|
-> Float -- ^minimal possible distance
|
|
-> IM.IntMap Wall
|
|
-> Point2
|
|
{-# INLINE collidePointUpToIndirectMinDist #-}
|
|
collidePointUpToIndirectMinDist p1 p2 md = ssfold prop f p2 . IM.filter wlIsOpaque
|
|
where
|
|
f x wl = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
|
|
prop p3 = dist p1 p3 < md
|
|
|
|
-- from haskell-cafe
|
|
-- short circuit a fold when a given property is satisfied
|
|
-- the fold builds a function that is then called on a0
|
|
ssfold :: Foldable t => (a -> Bool) -> (a -> b -> a) -> a -> t b -> a
|
|
{-# INLINABLE ssfold #-}
|
|
ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0
|
|
|
|
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
|
{-# INLINE collidePointIndirect #-}
|
|
collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter wlIsOpaque
|
|
where
|
|
f wl p = fromMaybe p $ uncurry (intersectSegSeg p1 p) $ _wlLine wl
|
|
test p | p == p2 = Nothing
|
|
| otherwise = Just p
|
|
|
|
collidePointIndirect' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
|
{-# INLINE collidePointIndirect' #-}
|
|
collidePointIndirect' p1 p2
|
|
= L.fold
|
|
. L.prefilter wlIsOpaque
|
|
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
|
|
$ L.minimumOn (dist p1)
|
|
|
|
--{- | 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 (_wlFireThrough wl) || wlIsOpaque wl) 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 theTest ws
|
|
-- where
|
|
-- theTest wl = not (_wlFireThrough wl) || wlIsOpaque wl
|
|
|
|
-- the reason for using the dashed version is the hope that this will short
|
|
-- circuit
|
|
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 (not . _wlFireThrough ) $ 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
|