loop/src/Dodge/Base/Collide.hs

{-# LANGUAGE TupleSections #-}

{- | Basic collision detection for a moving point.
 - Conventions: input is typically a stream of walls.
 - Collide returns an endpoint and maybe a collided with
 - object (wall).
 - Reflect maybe gives a slightly pushed out point from a collision and a
 - relection velocity.
 - Overlap returns a stream of walls.
 - A point will typically be moving.
 - A ball refers to a moving circle, i.e. a point with a radius.
 -
-}
module Dodge.Base.Collide (
    collidePoint,
    collidePointWallsFilter,
    collidePointTestFilter,
    collideCircWalls,
    overlapSegWalls,
    overlapSegCrs,
    overlapSegCrs',
    bouncePoint,
    circOnSomeWall,
    circOnAnyCr,
    overlapCircWallsClosest,
    crsNearPoint,
    allVisibleWalls,
    hasLOS,
    hasLOSIndirect,
    hasButtonLOS,
    canSee,
    canSeeIndirect,
    anythingHitCirc,
    collide3WallsFloor,
    collide3,
    crHeight,
) where

import AesonHelp
import Control.Applicative
import Data.Foldable
import qualified Data.IntMap.Strict as IM
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
import Geometry
import Linear

collidePoint :: Foldable t => Point2 -> Point2 -> t Wall -> (Point2, Maybe Wall)
{-# INLINE collidePoint #-}
collidePoint sp ep = foldl' f (ep, Nothing)
  where
    f (p, mwl) wl =
        maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl

overlapSegCrs :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
{-# INLINE overlapSegCrs #-}
overlapSegCrs sp ep = mapMaybe f
  where
    f cr =
        (,cr)
            <$> fst (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)

overlapSegCrs' :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
{-# INLINE overlapSegCrs' #-}
overlapSegCrs' sp ep = mapMaybe f
  where
    f cr =
        (,cr)
            <$> g (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)
    g (a,b) = a <|> b

doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
{-# INLINE doBounce #-}
doBounce x sp ep (p, mwl) = fmap f mwl
  where
    f wl =
        ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
        , reflVelWallDamp x wl (ep -.- sp)
        )

-- bounceBall ::
--    Float ->
--    Point2 ->
--    Point2 ->
--    Float ->
--    [Wall] ->
--    Maybe (Point2, Point2)
-- {-# INLINE bounceBall #-}
-- bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r

bouncePoint ::
    (Wall -> Bool) ->
    Float ->
    Point2 ->
    Point2 ->
    World ->
    Maybe (Point2, Point2)
{-# INLINE bouncePoint #-}
bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilter t sp ep

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)

-- 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)
        (w ^. cWorld . cliffs)

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, 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 e@(ep, _) = foldl' f e $ wlsNearSeg (xyV3 sp) (xyV3 ep) w
  where
    f x wl = collide3Wall sp wl x

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)
            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
  where
    (p, n, ss) = wallToSurface wl

collide3Creature :: Point3 -> Creature -> (Point3, MPO) -> (Point3, MPO)
collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do
    let h = crHeight cr
    (p, n) <- fst $ intersectCylSeg (cr ^. crPos) (crRad $ cr ^. crType) h sp ep
    return (p, Just (n, OCreature cr))

crHeight :: Creature -> Float
crHeight cr = case cr ^. crHP of
    HP{} -> case cr ^. crType of
        HoverCrit {} -> 10
        ChaseCrit {} -> 25
        Avatar {} -> 25
        CrabCrit {} -> 25
        SlinkCrit {} -> 25
        SlimeCrit {_slimeSlime = r} -> min 15 $ slimeToRad r
        BeeCrit {} -> 10
        HiveCrit {} -> 25
        BarrelCrit{} -> 20
        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
    CrIsCorpse{} -> 5
    AvatarDestroyed{} -> 0

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
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Bool
{-# INLINE collidePointTestFilter #-}
collidePointTestFilter t sp ep =
    any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
        . IM.filter t

---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
---- whether this is actually faster
-- 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

collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
{-# INLINE collidePointWallsFilter #-}
collidePointWallsFilter t sp ep = collidePoint sp ep . IM.filter t . wlsNearSeg sp ep

-- overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
--    -> StreamOf (Point2,Wall)
-- {-# INLINE overlapSegWalls #-}
-- overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)

overlapSegWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
{-# INLINE overlapSegWalls #-}
overlapSegWalls sp ep = IM.mapMaybe $
    \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)

visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
{-# INLINE visibleWalls #-}
visibleWalls sp ep =
    takeUntil (wlIsOpaque . snd)
        . sortOn (dist sp . fst)
        . IM.elems
        . overlapSegWalls sp ep
        . wlsNearSeg sp ep

allVisibleWalls :: World -> [(Point2, Wall)]
{-# INLINE allVisibleWalls #-}
allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 15
  where
    vPos = w ^. wCam . camViewFrom

overlapCircWalls :: Point2 -> Float -> [Wall] -> [(Point2, Wall)]
{-# INLINE overlapCircWalls #-}
overlapCircWalls p r = mapMaybe g
  where
    g wl = f (_wlLine wl) <&> (,wl)
    f (a, b) = intersectSegSeg p (p + r *^ vNormal (normalizeV (b - a))) a b

circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
circHitWall sp ep r w =
    any
        (uncurry (intersectSegSegTest xsp xep) . _wlLine)
        (wlsNearSeg xsp xep w)
        || circOnSomeWall ep r w
  where
    x = r *.* normalizeV (ep - sp)
    xsp = sp - x
    xep = ep + x

-- | note that this does not push the circle away from the wall at all
collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
{-# INLINE collideCircWalls #-}
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) =
        bimap
            f
            f
            ( a +.+ rad *.* normalizeV (a -.- b)
            , b +.+ rad *.* normalizeV (b -.- a)
            )
      where
        f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))

overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall)
{-# INLINE overlapCircWallsClosest #-}
overlapCircWallsClosest p r = safeMinimumOn (dist p . fst) . overlapCircWalls p r

{- | 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 =
    any (uncurry (circOnSeg p rad) . _wlLine)
        . wlsNearCirc p rad

circOnAnyCr :: Point2 -> Float -> World -> Bool
{-# INLINE circOnAnyCr #-}
circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
  where
    f cid bl =
        maybe
            False
            (\cr -> dist p (cr ^. crPos . _xy) < r + crRad (cr ^. crType))
            (w ^? cWorld . lWorld . creatures . ix cid)
            || bl

-- | More general collision tests follow
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
hasLOS p1 p2 =
    not
        . collidePointTestFilter (const True) p1 p2
        . wlsNearSeg p1 p2

hasButtonLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasButtonLOS #-}
hasButtonLOS _ _ = const True

-- hasButtonLOS p1 p2 =
--    not
--        . collidePointTestFilter (not . _wlTouchThrough) p1 p2
--        . wlsNearSeg p1 p2

hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOSIndirect #-}
hasLOSIndirect p1 p2 =
    not
        . collidePointTestFilter wlIsOpaque p1 p2
--        . IM.elems
        . wlsNearSeg p1 p2

canSee :: Int -> Int -> World -> Bool
{-# INLINE canSee #-}
canSee i j w = hasLOS p1 p2 w
  where
    p1 = w ^?! cWorld . lWorld . creatures . ix i . crPos . _xy
    p2 = w ^?! cWorld . lWorld . creatures . ix j . crPos . _xy

canSeeIndirect :: Int -> Int -> World -> Bool
{-# INLINE canSeeIndirect #-}
canSeeIndirect i j w = hasLOSIndirect ipos jpos w
  where
    ipos = w ^?! cWorld . lWorld . creatures . ix i . crPos . _xy
    jpos = w ^?! cWorld . lWorld . creatures . ix j . crPos . _xy

anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
anythingHitCirc rad sp ep w = hitCr || circHitWall sp ep rad w
  where
    x = rad *.* normalizeV (ep - sp)
    xsp = sp - x
    xep = ep + x
    hitCr = IS.foldr f False $ crixsNearSeg xsp xep w
    f cid bl =
        maybe
            False
            (\cr -> intersectCircSegTest (cr ^. crPos . _xy) (rad + crRad (cr ^. crType)) sp ep)
            (w ^? cWorld . lWorld . creatures . ix cid)
            || bl