188 lines
5.4 KiB
Haskell
188 lines
5.4 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
{- |
|
|
Find which objects lie upon a line.
|
|
-}
|
|
module Dodge.WorldEvent.ThingsHit (
|
|
thingsHit,
|
|
thingsHitZ,
|
|
thingHit,
|
|
thingHitFilt,
|
|
thingsHitExceptCr,
|
|
crsHitRadial,
|
|
wlsHitRadial,
|
|
wlHitPos,
|
|
crHit,
|
|
crWlPbHit,
|
|
wlsHitUnsorted,
|
|
isWalkable,
|
|
) where
|
|
|
|
import ListHelp
|
|
import Control.Applicative
|
|
import Dodge.Wall.Pathing
|
|
--import Data.Monoid
|
|
import qualified Data.Set as S
|
|
import Linear
|
|
import Dodge.Data.Object
|
|
import Dodge.Creature.Radius
|
|
import Control.Monad
|
|
import Control.Lens
|
|
import Data.Bifunctor
|
|
import qualified Data.IntSet as IS
|
|
--import Data.List (sortOn)
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.World
|
|
import Dodge.Zoning.Creature
|
|
import Dodge.Zoning.Wall
|
|
import Geometry
|
|
import qualified ListHelp as List
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
{- List those objects that appear on a line. -}
|
|
thingsHit :: Point2 -> Point2 -> World -> [(Point2, Either Creature Wall)]
|
|
thingsHit sp ep w =
|
|
List.mergeOn
|
|
(dist sp . fst)
|
|
(map (second Left) (crsHit sp ep w))
|
|
(map (second Right) (wlsHit sp ep w))
|
|
|
|
{- Does not hit corpses -}
|
|
thingsHitZ :: Float -> Point2 -> Point2 -> World -> [(Point2, Either Creature Wall)]
|
|
thingsHitZ z sp ep w =
|
|
List.mergeOn
|
|
(dist sp . fst)
|
|
(map (second Left) (crsHitZ z sp ep w))
|
|
(map (second Right) (wlsHit sp ep w))
|
|
|
|
crWlPbHit :: Point2 -> Point2 -> World -> [(Point2, Object)]
|
|
crWlPbHit sp ep w =
|
|
List.mergeOn
|
|
(dist sp . fst)
|
|
(map (fmap toobj) (thingsHit sp ep w))
|
|
(map (fmap OPulseBall) (pbsHit sp ep w))
|
|
where
|
|
toobj (Left cr) = OCreature cr
|
|
toobj (Right wl) = OWall wl
|
|
|
|
crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)]
|
|
crsHit sp ep w
|
|
| sp == ep = mempty
|
|
| otherwise =
|
|
sortOn (dist sp . fst)
|
|
. overlapSegCrs sp ep
|
|
. mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid)
|
|
. IS.toList
|
|
. crixsNearSeg sp ep
|
|
$ w
|
|
|
|
crsHitZ :: Float -> Point2 -> Point2 -> World -> [(Point2, Creature)]
|
|
crsHitZ z sp ep w
|
|
| sp == ep = mempty
|
|
| otherwise =
|
|
sortOn (dist sp . fst)
|
|
. overlapSegCrs sp ep
|
|
. mapMaybe (\cid -> f =<< w ^? cWorld . lWorld . creatures . ix cid)
|
|
. IS.toList
|
|
. crixsNearSeg sp ep
|
|
$ w
|
|
where
|
|
f cr
|
|
| HP{} <- cr ^. crHP = Just cr
|
|
| CrIsCorpse{} <- cr ^. crHP
|
|
, z < 5 = Just cr
|
|
| otherwise = Nothing
|
|
|
|
pbsHit :: Point2 -> Point2 -> World -> [(Point2, PulseBall)]
|
|
pbsHit sp ep w
|
|
| sp == ep = mempty
|
|
| otherwise =
|
|
sortOn (dist sp . fst)
|
|
. mapMaybe (\pb -> (,pb) <$> fst (intersectCircSeg (_pbPos pb) 8 sp ep))
|
|
. IM.elems
|
|
$ w ^. cWorld . lWorld . pulseBalls
|
|
|
|
thingHitFilt ::
|
|
(Creature -> Bool) ->
|
|
(Wall -> Bool) ->
|
|
Point2 ->
|
|
Point2 ->
|
|
World ->
|
|
Maybe (Point2, Either Creature Wall)
|
|
thingHitFilt fcr fwl sp ep = List.find (f . snd) . thingsHit sp ep
|
|
where
|
|
f (Left cr) = fcr cr
|
|
f (Right wl) = fwl wl
|
|
|
|
thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
|
|
thingHit sp ep = listToMaybe . thingsHit sp ep
|
|
|
|
crHit :: Point2 -> Point2 -> World -> Maybe (Point2,Creature)
|
|
--crHit sp ep = listToMaybe . sortOn (dist sp . fst) . crsHit sp ep
|
|
crHit sp ep = listToMaybe . crsHit sp ep
|
|
|
|
{- List objects that appear on a line.
|
|
Can filter out a creature. -}
|
|
thingsHitExceptCr ::
|
|
-- | A possible creature ID
|
|
Maybe Int ->
|
|
-- | Line start point
|
|
Point2 ->
|
|
-- | Line end point
|
|
Point2 ->
|
|
World ->
|
|
[(Point2, Either Creature Wall)]
|
|
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
|
|
thingsHitExceptCr (Just cid) sp ep = filter t . thingsHit sp ep
|
|
where
|
|
t = (Just cid /=) . (^? _2 . _Left . crID)
|
|
|
|
wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)]
|
|
wlsHit sp ep = sortOn (dist sp . fst) . wlsHitUnsorted sp ep
|
|
|
|
---- pushes out any hit point by one
|
|
wlHitPos :: Point2 -> Point2 -> World -> Point2
|
|
wlHitPos sp ep = maybe ep ((+ normalize (ep - sp)) . fst) . safeHead . wlsHit sp ep
|
|
|
|
wlsHitUnsorted :: Point2 -> Point2 -> World -> [(Point2, Wall)]
|
|
wlsHitUnsorted sp ep
|
|
| sp == ep = const mempty
|
|
| otherwise = overlapSegWalls sp ep . wlsNearSeg sp ep
|
|
|
|
wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
|
|
wlsHitRadial p r = mapMaybe f . wlsNearCirc p r
|
|
where
|
|
--f wl = uncurry (intersectSegSeg p (p - r *.* v)) (_wlLine wl) <&> (,wl)
|
|
f wl = mhp <&> (,wl)
|
|
where
|
|
(x,y) = wl ^. wlLine
|
|
t mp = do
|
|
p' <- mp
|
|
guard (distance p p' < r)
|
|
mp
|
|
orthp = t $ orthogonalPointOnSeg x y p
|
|
mhp = orthp <|> t (return x) <|> t (return y)
|
|
-- v = normalizeV . vNormal . uncurry (-) $ _wlLine wl
|
|
|
|
crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
|
|
crsHitRadial p r = mapMaybe f . crsNearCirc p r
|
|
where
|
|
f cr = do
|
|
let cp = cr ^. crPos . _xy
|
|
guard $ dist p cp < r + crRad (_crType cr)
|
|
return (cp + (1 + crRad (_crType cr)) *^ (cp - p), cr)
|
|
|
|
isFlyable :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE isFlyable #-}
|
|
isFlyable p1 p2 =
|
|
not . (WallNotAutoOpen `S.member`)
|
|
. foldMap (^. _2 . to getWallPathing)
|
|
. wlsHitUnsorted p1 p2
|
|
|
|
isWalkable :: Point2 -> Point2 -> World -> Bool
|
|
{-# INLINE isWalkable #-}
|
|
isWalkable p1 p2 w = isFlyable p1 p2 w && not (any f (w ^. cWorld . cliffs))
|
|
where
|
|
f = isJust . uncurry (intersectSegSeg p1 p2)
|