-- | Deals with moving creature wall collisions.
module Dodge.WallCreatureCollisions (
    colCrsWalls,
    colCrWall,
    pushCreatureOutFromWalls,
    crOnWall,
) where

import qualified Data.IntSet as IS
import Data.Foldable
import Linear
import Dodge.Creature.Radius
import Control.Lens
import Data.Monoid
import Dodge.Base
import Dodge.Data.Universe
import Dodge.Zoning.Wall
import Geometry

colCrsWalls :: Universe -> Universe
colCrsWalls uv = uv & uvWorld . cWorld . lWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv))

noclipCheck :: Config -> World -> Creature -> Creature
noclipCheck cfig w c
    | debugOn Noclip cfig && _crID c == 0 = c -- for noclip
    | otherwise = colCrWall w c

colCrWall :: World -> Creature -> Creature
colCrWall w c = cornpush . wallpush $ pushthrough c
  where
    cornpush = crPos . _xy %~ pushOutFromCorners r ls'
    wallpush = pushCr' wls
    pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
    r = crRad (c ^. crType) + wallBuffer
    p1 = c ^. crOldPos . _xy
    p2 = c ^. crPos . _xy
    ls = _wlLine <$> wls
    ls' = filter (uncurry $ isLHS p1) ls
    wls = filter notff $ wlsNearCirc p2 r w
    notff x = x ^. wlMaterial /= ForceField

pushCr' :: [Wall] -> Creature -> Creature
pushCr' wls cr 
    | dist ep sp > r 
        && dist ep ap > r = ecr & crDamage <>~ [Crushing 1000 0]
            & crPos . _xy .~ ap
    | otherwise = ecr
  where
    ep = ecr ^. crPos . _xy
    ap = cr ^. crOldPos . _xy
    sp = cr ^. crPos . _xy
    ecr = foldl' f (cr & crWallTouch .~ mempty) wls
    r = crRad (cr ^. crType)
    f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
        Just p -> acr & crPos . _xy .~ p & crWallTouch %~ IS.insert (wl ^. wlID)
        Nothing -> acr

-- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float
wallBuffer = 0

pushCreatureOutFromWalls :: [(Point2, Point2)] -> Creature -> Creature
pushCreatureOutFromWalls ls cr = cr & crPos . _xy 
    %~ pushOutFromWalls (crRad (cr ^. crType)) ls

-- the following tests whether or not a point is on a wall, and if so pushes it
-- out from the wall
-- this is then repeated if the point ends up on a new wall
pushOutFromWalls :: Float -> [(Point2, Point2)] -> Point2 -> Point2
pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of
    Nothing -> p1
    Just p2 -> pushOutFromWalls rad (tail wls) p2

--wallPushList :: Float -> [Wall] -> Point2 -> [(Point2, Wall)]
--wallPushList rad wls p1 = mapMaybe f wls
--  where
--    f :: Wall -> Maybe (Point2,Wall)
--    f wl = case pushOutFromWall rad p1 (wl ^. wlLine) of
--        Nothing -> Nothing
--        Just p -> Just (p,wl)

-- possible improvement: choose between the closer of p2 and "p3" to p1

--pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2
--pushOutFromWalls' rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall' rad p1)) wls of
--    Nothing -> p1
--    Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall' rad p2)) wls
--    -- possible improvement: choose between the closer of p2 and "p3" to p1

-- note the inclusion of endpoints in circOnSeg
crOnWall :: Creature -> World -> Bool
crOnWall cr =
    any (uncurry (circOnSeg p r) . _wlLine)
        . filter notff
        . wlsNearCirc p r
  where
    notff x = x ^. wlMaterial /= ForceField
    p = cr ^. crPos . _xy
    r = crRad (cr ^. crType)

-- assumes that the wall is orientated
-- assumes wall points are different
pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2
pushOutFromWall rad cp2 (wp1, wp2)
    | isOnWall = Just newP
    | otherwise = Nothing
  where
    n = errorNormalizeV 61 $ vNormal (wp1 - wp2)
    wp1' = wp1 + rad *^ n
    wp2' = wp2 + rad *^ n
    newP = errorClosestPointOnLine 5 wp1' wp2' cp2
    isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad

pushOutFromCorners :: Float -> [(Point2, Point2)] -> Point2 -> Point2
--pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)

squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
squashIntersectCirclePoint rad p cCen
    | dist cCen p > rad = cCen
    | otherwise = p + (rad *^ squashNormalizeV (cCen - p))