Cleanup, move towards explosions at different z positions
This commit is contained in:
+78
-38
@@ -18,7 +18,7 @@ module Dodge.Base.Collide (
|
||||
collideCircWalls,
|
||||
overlapSegWalls,
|
||||
overlapSegCrs,
|
||||
-- bounceBall,
|
||||
-- bounceBall,
|
||||
bouncePoint,
|
||||
circOnSomeWall,
|
||||
circOnAnyCr,
|
||||
@@ -37,14 +37,14 @@ module Dodge.Base.Collide (
|
||||
collide3,
|
||||
) where
|
||||
|
||||
import Dodge.Data.Object
|
||||
import Control.Monad
|
||||
import Dodge.Creature.Radius
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe
|
||||
import Dodge.Base.Wall
|
||||
import Dodge.Creature.Radius
|
||||
import Dodge.Data.Object
|
||||
import Dodge.Data.World
|
||||
import Dodge.Zoning
|
||||
import FoldableHelp
|
||||
@@ -85,63 +85,95 @@ bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Po
|
||||
{-# INLINE bouncePoint #-}
|
||||
bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilter t sp ep
|
||||
|
||||
type MPO = Maybe (Point3,Object)
|
||||
type MPO = Maybe (Point3, Object)
|
||||
|
||||
collide3WallsFloor :: Point3 -> Point3 -> World -> (Point3, MPO)
|
||||
collide3WallsFloor sp ep w = collide3Floors sp (w ^. cWorld . chasms)
|
||||
$ collide3Walls sp w (ep,Nothing)
|
||||
collide3WallsFloor sp ep w =
|
||||
collide3Floors sp (w ^. cWorld . chasms) $
|
||||
collide3Walls sp w (ep, Nothing)
|
||||
|
||||
collide3 :: Point3 -> Point3 -> World -> (Point3,MPO)
|
||||
collide3 sp ep w = foldl' (flip $ collide3Creature sp) (p,m)
|
||||
$ crsNearSeg (xyV3 sp) (xyV3 p) w
|
||||
-- could check the line is at least below z=0 at some point
|
||||
collide3Chasms :: Point3 -> World -> (Point3, MPO) -> (Point3, MPO)
|
||||
collide3Chasms sp w m =
|
||||
foldl'
|
||||
(flip (collide3Chasm sp))
|
||||
m
|
||||
(foldMap loopPairs $ w ^. cWorld . chasms)
|
||||
|
||||
collide3Chasm :: Point3 -> (Point2, Point2) -> (Point3, MPO) -> (Point3, MPO)
|
||||
collide3Chasm sp ab (ep, m) =
|
||||
maybe (ep, m) (,Just (n, OChasmWall)) $
|
||||
intersectSegSurface sp ep p n ss
|
||||
where
|
||||
(p,m) = collide3WallsFloor sp ep w
|
||||
(p, n, ss) = chasmWallToSurface ab
|
||||
|
||||
chasmWallToSurface :: (Point2, Point2) -> (Point3, Point3, [(Point3, Point3)])
|
||||
chasmWallToSurface (x, y) =
|
||||
( g x
|
||||
, g $ vNormal (x - y)
|
||||
, [(g x, g (y - x)), (g y, g (x - y)), (0, V3 0 0 (-1))]
|
||||
)
|
||||
where
|
||||
g = (`v2z` 0)
|
||||
|
||||
collide3 :: Point3 -> Point3 -> World -> (Point3, MPO)
|
||||
collide3 sp ep w =
|
||||
collide3Chasms sp w
|
||||
. foldl' (flip $ collide3Creature sp) (p, m)
|
||||
$ crsNearSeg (xyV3 sp) (xyV3 p) w
|
||||
where
|
||||
(p, m) = collide3WallsFloor sp ep w
|
||||
|
||||
-- Just (hitpoint,normaltosurface)
|
||||
collide3Walls :: Point3 -> World -> (Point3, MPO) -> (Point3, MPO)
|
||||
collide3Walls sp w ex@(ep,_) = foldl' f ex wls
|
||||
collide3Walls sp w ex@(ep, _) = foldl' f ex wls
|
||||
where
|
||||
f x wl = collide3Wall sp wl x
|
||||
wls = wlsNearSeg (xyV3 sp) (xyV3 ep) w
|
||||
|
||||
collide3Floors :: Point3 -> [[Point2]] -> (Point3, Maybe (Point3,Object))
|
||||
-> (Point3, Maybe (Point3,Object))
|
||||
collide3Floors sp cs (ep,mn) = maybe (ep,mn) (,Just (V3 0 0 1,OFloor)) mp
|
||||
collide3Floors ::
|
||||
Point3 ->
|
||||
[[Point2]] ->
|
||||
(Point3, Maybe (Point3, Object)) ->
|
||||
(Point3, Maybe (Point3, Object))
|
||||
collide3Floors sp cs (ep, mn) = maybe (ep, mn) (,Just (V3 0 0 1, OFloor)) mp
|
||||
where
|
||||
mp = do
|
||||
V3 x y z <- intersectSegPlane sp ep (V3 0 0 0) (V3 0 0 1)
|
||||
let g (a,b) = isRHS a b (V2 x y)
|
||||
let g (a, b) = isRHS a b (V2 x y)
|
||||
f = any g
|
||||
guard (all (f . loopPairs) cs)
|
||||
return $ (V3 x y z)
|
||||
|
||||
collide3Wall :: Point3 -> Wall -> (Point3, MPO) -> (Point3, MPO)
|
||||
collide3Wall sp wl (ep,mo) = maybe (ep,mo) (,Just (n,OWall wl)) $ intersectSegSurface sp ep p n ss
|
||||
collide3Wall sp wl (ep, mo) = maybe (ep, mo) (,Just (n, OWall wl)) $ intersectSegSurface sp ep p n ss
|
||||
where
|
||||
(p,n,ss) = wallToSurface wl
|
||||
(p, n, ss) = wallToSurface wl
|
||||
|
||||
collide3Creature :: Point3 -> Creature -> (Point3, MPO) -> (Point3, MPO)
|
||||
collide3Creature sp cr (ep,m) = fromMaybe (ep,m) $ do
|
||||
(sp',ep') <- restrictSeg 0 (V3 0 0 1) (sp,ep) >>= restrictSeg (V3 0 0 25) (V3 0 0 (-1))
|
||||
collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do
|
||||
(sp', ep') <- restrictSeg 0 (V3 0 0 1) (sp, ep) >>= restrictSeg (V3 0 0 25) (V3 0 0 (-1))
|
||||
p <- listToMaybe $ intersectCircSeg cpos (crRad $ cr ^. crType) (xyV3 sp') (xyV3 ep')
|
||||
let z = 0
|
||||
return (p `v2z` z,Just (normalize $ (p - cpos) `v2z` 0, OCreature cr))
|
||||
return (p `v2z` z, Just (normalize $ (p - cpos) `v2z` 0, OCreature cr))
|
||||
where
|
||||
cpos = cr ^. crPos
|
||||
|
||||
restrictSeg :: Point3 -> Point3 -> (Point3,Point3) -> Maybe (Point3,Point3)
|
||||
restrictSeg p n (sp,ep)
|
||||
restrictSeg :: Point3 -> Point3 -> (Point3, Point3) -> Maybe (Point3, Point3)
|
||||
restrictSeg p n (sp, ep)
|
||||
| isNHS p n sp
|
||||
, isNHS p n ep = Just (sp,ep)
|
||||
, isNHS p n ep =
|
||||
Just (sp, ep)
|
||||
| isNHS p n sp = (sp,) <$> intersectSegPlane sp ep p n
|
||||
| otherwise = (,ep) <$> intersectSegPlane sp ep p n
|
||||
-- note if both sp & ep are not NHS, this returns Nothing
|
||||
|
||||
wallToSurface :: Wall -> (Point3,Point3,[(Point3,Point3)])
|
||||
wallToSurface wl = (g x, g $ vNormal (x-y), [(g x,g (y-x)),(g y,g (x-y))])
|
||||
where
|
||||
g = (`v2z` 0)
|
||||
(x,y) = _wlLine wl
|
||||
-- note if both sp & ep are not NHS, this returns Nothing
|
||||
|
||||
wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
|
||||
wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])
|
||||
where
|
||||
g = (`v2z` 0)
|
||||
(x, y) = _wlLine wl
|
||||
|
||||
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
||||
-- whether this is actually faster
|
||||
@@ -198,9 +230,11 @@ overlapCircWalls p r = mapMaybe dointersect
|
||||
f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
||||
|
||||
circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
|
||||
circHitWall sp ep r w = any (uncurry (intersectSegSegTest xsp xep) . _wlLine)
|
||||
circHitWall sp ep r w =
|
||||
any
|
||||
(uncurry (intersectSegSegTest xsp xep) . _wlLine)
|
||||
(wlsNearSeg xsp xep w)
|
||||
|| circOnSomeWall ep r w
|
||||
|| circOnSomeWall ep r w
|
||||
where
|
||||
x = r *.* normalizeV (ep - sp)
|
||||
xsp = sp - x
|
||||
@@ -213,12 +247,17 @@ collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
|
||||
where
|
||||
findPoint (p, mwl) wl =
|
||||
maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
||||
. shiftbyrad . _wlLine $ wl
|
||||
-- shiftbyrad (a, b) =
|
||||
-- ( a +.+ rad *.* normalizeV (a -.- b)
|
||||
-- , b +.+ rad *.* normalizeV (b -.- a)
|
||||
-- )
|
||||
shiftbyrad (a, b) = bimap f f
|
||||
. shiftbyrad
|
||||
. _wlLine
|
||||
$ wl
|
||||
-- shiftbyrad (a, b) =
|
||||
-- ( a +.+ rad *.* normalizeV (a -.- b)
|
||||
-- , b +.+ rad *.* normalizeV (b -.- a)
|
||||
-- )
|
||||
shiftbyrad (a, b) =
|
||||
bimap
|
||||
f
|
||||
f
|
||||
( a +.+ rad *.* normalizeV (a -.- b)
|
||||
, b +.+ rad *.* normalizeV (b -.- a)
|
||||
)
|
||||
@@ -262,6 +301,7 @@ hasLOS p1 p2 =
|
||||
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasButtonLOS #-}
|
||||
hasButtonLOS _ _ = const True
|
||||
|
||||
--hasButtonLOS p1 p2 =
|
||||
-- not
|
||||
-- . collidePointTestFilter (not . _wlTouchThrough) p1 p2
|
||||
|
||||
Reference in New Issue
Block a user