Redo collision changes
This commit is contained in:
+64
-181
@@ -11,33 +11,22 @@
|
||||
- -}
|
||||
module Dodge.Base.Collide
|
||||
( collidePoint
|
||||
, collideSegCrs
|
||||
, collidePointWallsFilterStream
|
||||
, collidePointTestFilter
|
||||
, overlapSegWalls
|
||||
, overlapSegCrs
|
||||
, overlap1SegCrs
|
||||
, bounceBall
|
||||
, bouncePoint
|
||||
, sortStreamOn
|
||||
, minStreamOn
|
||||
-- , wallsOnCirc
|
||||
-- , wallsOnCirc'
|
||||
, wallsOnLineHit
|
||||
, collideCircWallsStream
|
||||
, collideCircWalls
|
||||
, circOnSomeWall
|
||||
, collidePointWallsNorm
|
||||
, collidePointWalls'
|
||||
, circOnAnyCr
|
||||
, overlapCircWalls
|
||||
, overlapCircWallsClosest
|
||||
, collideCircCrsPoint
|
||||
, collideCircCreatures
|
||||
, collidePointCreatures
|
||||
, collidePointAnyWallsReflect
|
||||
, crsNearPoint
|
||||
, crsOnLine
|
||||
, crsOnThickLine
|
||||
, nearestCrInRad
|
||||
, nearestCrInTri
|
||||
, nearestCrInFront
|
||||
, allVisibleWalls
|
||||
|
||||
, hasLOS
|
||||
@@ -51,103 +40,111 @@ import Dodge.Data
|
||||
import Dodge.Zone
|
||||
import Dodge.Base.Wall
|
||||
import Geometry
|
||||
import FoldableHelp
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
--import qualified FoldlHelp as L
|
||||
import Data.Monoid
|
||||
import StreamingHelp
|
||||
import qualified Streaming.Prelude as S
|
||||
|
||||
collidePoint :: Point2 -> Point2
|
||||
-> Stream (Of Wall) Identity ()
|
||||
-> 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
|
||||
-> StreamOf Creature
|
||||
-> StreamOf (Point2, Creature)
|
||||
{-# INLINE overlap1SegCrs #-}
|
||||
overlap1SegCrs sp ep = S.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
|
||||
-> Stream (Of Wall) Identity ()
|
||||
-> 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 -> Stream (Of Wall) Identity () -> Bool
|
||||
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 -> Stream (Of Wall) Identity ()
|
||||
-> Stream (Of (Point2,Wall)) Identity ()
|
||||
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 -> Stream (Of (Point2,Wall)) Identity ()
|
||||
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 -> Stream (Of (Point2,Wall)) Identity ()
|
||||
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
|
||||
|
||||
|
||||
wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
|
||||
wallsOnLineHit p1 p2 = IM.mapMaybe f
|
||||
where
|
||||
f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
|
||||
|
||||
-- | Looks for any collision of a circle with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
-- note that in this version the circle can overlap the wall
|
||||
collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collidePointAnyWallsReflect p1 p2
|
||||
= getFirst
|
||||
. foldMap (First . findPoint . _wlLine)
|
||||
where
|
||||
findPoint (x,y) = case intersectSegSeg p1 p2 x y of
|
||||
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
Nothing -> Nothing
|
||||
|
||||
collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2
|
||||
{-# INLINE collidePointWalls' #-}
|
||||
collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
|
||||
where
|
||||
findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
|
||||
|
||||
overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity ()
|
||||
-> Stream (Of (Point2,Wall)) Identity ()
|
||||
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 *.* vNormal (normalizeV (a -.- b))) a b
|
||||
|
||||
-- note that this does not push the circle away from the wall at all
|
||||
collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity ()
|
||||
-- | note that this does not push the circle away from the wall at all
|
||||
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
|
||||
-> (Point2, Maybe Wall)
|
||||
collideCircWallsStream sp ep rad = runIdentity
|
||||
. S.fold_ findPoint (ep, Nothing) id
|
||||
{-# 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
|
||||
@@ -157,142 +154,24 @@ collideCircWallsStream sp ep rad = runIdentity
|
||||
,b +.+ rad *.* normalizeV (b -.-a)
|
||||
)
|
||||
where
|
||||
f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
|
||||
|
||||
overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
|
||||
overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
|
||||
{-# INLINE overlapCircWallsClosest #-}
|
||||
overlapCircWallsClosest p r = minStreamOn (dist p . fst)
|
||||
. overlapCircWalls p r
|
||||
|
||||
-- | Looks for first collision of a circle with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collideCircWalls p1 p2 rad
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
. IM.mapMaybe
|
||||
(( \(x:y:_) -> fmap
|
||||
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
. (+.+ normalizeV (vNormal (x -.- y)))
|
||||
)
|
||||
(intersectSegSeg p1 p2 x y)
|
||||
)
|
||||
. shiftByRad . _wlLine
|
||||
)
|
||||
where
|
||||
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||
[a +.+ rad *.* normalizeV (a -.-b)
|
||||
,b +.+ rad *.* normalizeV (b -.-a)
|
||||
]
|
||||
-- this shifts the wall out, and for outer corners extends the wall
|
||||
-- not sure what this does for inner corners, hopefully won't cause a problem
|
||||
-- the alternative would be to separately bounce off corner points...
|
||||
-- unfortunately, doesn't allow for collisions when the circle spawns on the
|
||||
-- wall
|
||||
|
||||
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and normal of wall.
|
||||
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collidePointWallsNorm p1 p2 ws
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
|
||||
. _wlLine) ws
|
||||
-- | Returns the first creature, if any, that a point intersects with.
|
||||
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
|
||||
collidePointCreatures p1 p2 = fmap fst
|
||||
. safeMinimumOn snd
|
||||
. IM.toList
|
||||
. IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
|
||||
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
|
||||
--fixed amount, thus collides a moving circle with creaures.
|
||||
collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
|
||||
collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
|
||||
|
||||
-- | Returns the first creature id, if any, that a point intersects with, gives point
|
||||
--in creature on line.
|
||||
collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
|
||||
collidePointCrsPoint p1 p2 = fmap f
|
||||
. safeMinimumOn (dist p1 . snd)
|
||||
. IM.toList
|
||||
. IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
|
||||
where
|
||||
f (cID,p) = (p,cID)
|
||||
{- | Finds the first creature hit on a line.
|
||||
Maybe evaluates the creature id and hit point. -}
|
||||
collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int)
|
||||
collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
|
||||
|
||||
---- | Makes a creature not hittable.
|
||||
--collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
|
||||
--collidePointCrsWithoutPoint cid p1 p2 w
|
||||
-- = fmap f
|
||||
-- . safeMinimumOn (snd . snd)
|
||||
-- . IM.toList
|
||||
-- . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
|
||||
-- . IM.delete cid
|
||||
-- $ _creatures w
|
||||
-- where
|
||||
-- f (cID,(p,_)) = (p,cID)
|
||||
{- | 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
|
||||
-- = any (\(x,y) -> circOnSeg x y p rad)
|
||||
-- . fmap _wlLine
|
||||
-- . IM.elems
|
||||
-- . wallsNearPoint p
|
||||
|
||||
{- | Produce an unordered list of creatures on a line. -}
|
||||
crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
|
||||
crsOnLine p1 p2
|
||||
= IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr))
|
||||
. _creatures
|
||||
{- | Produce an unordered list of creatures on a wide line. -}
|
||||
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
|
||||
crsOnThickLine thickness p1 p2
|
||||
= IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness))
|
||||
. _creatures
|
||||
{- | Find 'Maybe' the closest creature to a point, within a circle.
|
||||
-}
|
||||
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
|
||||
nearestCrInRad p r
|
||||
= safeMinimumOn (dist p . _crPos)
|
||||
. IM.filter (\cr -> dist p (_crPos cr) < r)
|
||||
. _creatures
|
||||
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. -}
|
||||
nearestCrInTri
|
||||
:: Point2
|
||||
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
||||
-> Float -- ^ Distance.
|
||||
-> World -> Maybe Creature
|
||||
nearestCrInTri p dir x
|
||||
= safeMinimumOn (dist p . _crPos)
|
||||
. IM.filter (\cr -> pointInPolygon (_crPos cr) tri)
|
||||
. _creatures
|
||||
where
|
||||
tri =
|
||||
[p
|
||||
,p +.+ rotateV (dir-pi/4) (V2 x 0)
|
||||
,p +.+ rotateV (dir+pi/4) (V2 x 0)
|
||||
]
|
||||
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
|
||||
a given distance.
|
||||
The shapes within which creatures are searched are a triangle then rectangle. -}
|
||||
nearestCrInFront
|
||||
:: Point2
|
||||
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
||||
-> Float -- ^ Distance.
|
||||
-> World -> Maybe Creature
|
||||
nearestCrInFront p dir x
|
||||
= safeMinimumOn (dist p . _crPos)
|
||||
. IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
|
||||
. _creatures
|
||||
where
|
||||
rec = [p, pR, pR1, pL1, pL ]
|
||||
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
|
||||
pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0)
|
||||
pR1 = pR +.+ rotateV dir (V2 (x/2) 0)
|
||||
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
|
||||
circOnAnyCr :: Point2 -> Float -> World -> Bool
|
||||
{-# INLINE circOnAnyCr #-}
|
||||
circOnAnyCr p r = runIdentity . S.any_ (\cr -> dist p (_crPos cr) < r + _crRad cr)
|
||||
. crsNearPoint p
|
||||
|
||||
{- | More general collision tests follow -}
|
||||
|
||||
@@ -309,22 +188,26 @@ hasButtonLOS p1 p2 = not
|
||||
. 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)
|
||||
|
||||
@@ -28,6 +28,7 @@ import qualified IntMapHelp as IM
|
||||
import ShapePicture
|
||||
import Shape
|
||||
|
||||
import qualified Streaming.Prelude as S
|
||||
--import qualified Data.Set as S
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified SDL
|
||||
@@ -332,9 +333,9 @@ moveRemoteShell cid itid pj w
|
||||
doExplosion = explodeRemoteRocket itid i $ stopSoundFrom (ShellSound i) w
|
||||
|
||||
anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
|
||||
anythingHitCirc rad sp ep w = isJust hitCr || isJust (sequence hitWl)
|
||||
anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
|
||||
where
|
||||
hitCr = collideCircCrsPoint sp ep rad (_creatures w)
|
||||
hitCr = runIdentity $ S.any_ (const True) $ overlap1SegCrs sp ep $ crsNearSeg sp ep w
|
||||
hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
|
||||
-- this should probably be wallsOnLine or something
|
||||
|
||||
|
||||
Reference in New Issue
Block a user