diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 273016466..9106b3139 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} {- | Basic helpers. -Consider splitting. -} +These modules should have few dependencies. -} module Dodge.Base ( module Dodge.Base , module Dodge.Base.Arithmetic @@ -20,20 +20,17 @@ import Dodge.Base.Arithmetic import Dodge.Base.NewID import Dodge.Base.Coordinate import Dodge.Base.CardinalPoint -import Dodge.Zone +--import Dodge.Zone --import Dodge.Zone.Data import Dodge.Base.Window import Dodge.Base.Collide import Geometry --import Picture import qualified IntMapHelp as IM -import FoldableHelp -import qualified FoldlHelp as L +--import FoldableHelp import Dodge.Base.You import Control.Lens -import Data.Monoid -import Data.Maybe --import Data.Bifunctor --import qualified Data.IntSet as IS --import qualified Data.Set as S @@ -42,34 +39,6 @@ import Data.Maybe allWalls :: World -> IM.IntMap Wall allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone -creatureNearPoint :: Point2 -> World -> Maybe Creature -creatureNearPoint = creatureNearPointI 1 - -creatureNearPointI :: Int -> Point2 -> World -> Maybe Creature -creatureNearPointI n p = L.fold (L.minimumOn (dist p . _crPos)) . creaturesNearPointI n p - -creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature -creaturesNearPoint = creaturesNearPointI 1 - -creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature -creaturesNearPointI n p w = IM.unions - [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]] - where - (x,y) = crZoneOfPoint p - f i m = fromMaybe IM.empty $ IM.lookup i m - --- possible BUG, occurs when used in thingsHitLongLine -creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature ---creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b] --- where f i m = case IM.lookup i m of Just val -> val --- _ -> IM.empty - -creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b) - where - g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s)) - f i = fromMaybe IM.empty . IM.lookup i --- f i m = case IM.lookup i m of Just val -> val --- _ -> IM.empty {- | Expands a line out to a given thickness. -} lineGeom :: Float -> Point2 -> Point2 -> [Point2] @@ -131,225 +100,6 @@ adjustIMZone f x y n = IM.adjust f' x where f' = IM.adjust f'' y f'' = IM.adjust f n ---{- | Finds unused projectile key. -} ---newProjectileKey :: World -> Int ---newProjectileKey = IM.newKey . _props ---{- | Finds unused creature key. -} ---newCrKey :: World -> Int ---newCrKey = IM.newKey . _creatures --- | Looks for overlap of a circle with walls. --- If found, gives wall -overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall -overlapCircWallsReturnWall p rad - = L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine)) - where - f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b - --- | 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 - --- | Looks for collision of a point with walls. --- If found, gives collision point --- If not found, returns point -collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 -collidePointWalls p1 p2 - = foldr findPoint p2 . fmap _wlLine - where - findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y - -collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2 -collidePointWallsFilter t p1 p2 = foldr findPoint p2 . fmap _wlLine . IM.filter t - where - findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y -collidePointWallsFilter' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2 -collidePointWallsFilter' t p1 p2 = foldl' findPoint p2 . fmap _wlLine . IM.filter t - where - findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) - --- | Looks for first collision of a circle with walls. --- If found, gives point and reflection velocity, reflection damped in normal. --- note that the "intersection" point is the center of the circle flush against the wall -collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) -collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2) - where - findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl - getp (Left p) = p - getp (Right (p,_)) = p - doReflection p (x,y) = case intersectSegSeg p1 p x y of - Nothing -> Nothing - Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1)) - shiftByRad (a,b) = - (g $ a +.+ rad *.* normalizeV (a -.-b) - ,g $ b +.+ rad *.* normalizeV (b -.-a) - ) - where - g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) - --- | 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 a list of lines. --- If found, gives point and normal of wall. ---collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2) ---collidePointLines p1 p2 ws --- = safeMinimumOn f --- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) --- . _wlLine') ws --- where --- f (a,_) = magV (p1 -.- a) --- - --- | 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 -circOnSomeWall p rad - = any (\(x,y) -> circOnSeg x y p rad) - . fmap _wlLine - . IM.elems - . wallsNearPoint p -{- | Test whether there is a creature of weight 4 or greater near a line. -} -isHeavyCrNearLine - :: Float - -> [Point2] - -> World - -> Bool -isHeavyCrNearLine d (p1:p2:_) - = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c)) - . IM.filter (\cr -> _crMass cr > 4) - . _creatures -isHeavyCrNearLine _ _ = error "Testing whether creature is near empty line" -{- | Adds the distance to the creature radius, tests whether the center is in -the circle of this size centered at the point -} -crsNearPoint :: Float -> Point2 -> World -> Bool -crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures -{- | Produce an unordered list of creatures on a line. -} -crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature -crsOnLine p1 p2 - = IM.filter (\cr -> circOnSeg 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 -> circOnSeg 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) -{- | Test whether a creature is in a polygon. -} -crInPolygon :: Creature -> [Point2] -> Bool -crInPolygon = pointInPolygon . _crPos {- | Create a logistic function given three parameters. -} logistic :: Float -> Float -> Float -> (Float -> Float) @@ -375,11 +125,6 @@ mvPointToward !ep !p | dist p ep < 1 = ep | otherwise = p +.+ normalizeV (ep -.- p) -isAnimate :: Creature -> Bool -{-# INLINE isAnimate #-} -isAnimate cr = case _crActionPlan cr of - Inanimate -> False - _ -> True sigmoid :: Floating a => a -> a sigmoid x = x/sqrt(1+x^(2::Int)) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 36931848b..9a90872bd 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -16,6 +16,23 @@ module Dodge.Base.Collide , wlIsSeeThrough , wallsOnCirc , wallsOnLineHit + , collideCircWalls + , collideCircWalls' + , circOnSomeWall + , collidePointWalls + , collidePointWallsNorm + , collidePointWalls' + , overlapCircWallsReturnWall + , collideCircCrsPoint + , collideCircCreatures + , collidePointCreatures + , collidePointAnyWallsReflect + , crsNearPoint + , crsOnLine + , crsOnThickLine + , nearestCrInRad + , nearestCrInTri + , nearestCrInFront ) where import Dodge.Data import Dodge.Zone @@ -28,6 +45,7 @@ import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens import qualified FoldlHelp as L +import Data.Monoid hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} @@ -323,3 +341,196 @@ wallsOnCirc p r = IM.filter f --wallNormal :: Wall -> Point2 --wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine +-- | Looks for overlap of a circle with walls. +-- If found, gives wall +overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall +overlapCircWallsReturnWall p rad + = L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine)) + where + f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b + +-- | 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 + +-- | Looks for collision of a point with walls. +-- If found, gives collision point +-- If not found, returns point +collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 +collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine + where + findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y +collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 +collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine + where + findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) + +-- | Looks for first collision of a circle with walls. +-- If found, gives point and reflection velocity, reflection damped in normal. +-- note that the "intersection" point is the center of the circle flush against the wall +collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) +collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2) + where + findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl + getp (Left p) = p + getp (Right (p,_)) = p + doReflection p (x,y) = case intersectSegSeg p1 p x y of + Nothing -> Nothing + Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1)) + shiftByRad (a,b) = + (g $ a +.+ rad *.* normalizeV (a -.-b) + ,g $ b +.+ rad *.* normalizeV (b -.-a) + ) + where + g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) + +-- | 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 a list of lines. +-- If found, gives point and normal of wall. +--collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2) +--collidePointLines p1 p2 ws +-- = safeMinimumOn f +-- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) +-- . _wlLine') ws +-- where +-- f (a,_) = magV (p1 -.- a) +-- + +-- | 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 +circOnSomeWall p rad + = any (\(x,y) -> circOnSeg x y p rad) + . fmap _wlLine + . IM.elems + . wallsNearPoint p +{- | Adds the distance to the creature radius, tests whether the center is in +the circle of this size centered at the point -} +crsNearPoint :: Float -> Point2 -> World -> Bool +crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures +{- | Produce an unordered list of creatures on a line. -} +crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature +crsOnLine p1 p2 + = IM.filter (\cr -> circOnSeg 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 -> circOnSeg 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) diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index c6289accc..4368a8515 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -18,6 +18,7 @@ import Dodge.Data import Dodge.Creature.Test import Dodge.Creature.Volition import Dodge.Base +import Dodge.Zone import Geometry import FoldableHelp diff --git a/src/Dodge/Creature/Test.hs b/src/Dodge/Creature/Test.hs index 380abe35e..a37da9fd0 100644 --- a/src/Dodge/Creature/Test.hs +++ b/src/Dodge/Creature/Test.hs @@ -108,3 +108,9 @@ crNearSeg d p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr + d) crNearPoint :: Float -> Point2 -> Creature -> Bool crNearPoint d p cr = dist (_crPos cr) p < d + _crRad cr + +isAnimate :: Creature -> Bool +{-# INLINE isAnimate #-} +isAnimate cr = case _crActionPlan cr of + Inanimate -> False + _ -> True diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index f919750e0..687349e0d 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -506,7 +506,6 @@ data Item = Item , _itIsHeld :: Bool , _itEffect :: ItEffect , _itInvSize :: Float - , _itInvDisplay :: Item -> [String] , _itInvColor :: Color , _itTargeting :: Targeting , _itDimension :: ItemDimension @@ -1400,7 +1399,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutButton {_putButton :: Button} | PutProp Prop | PutTerminal {_unputTerminal :: Terminal} - | PutFlIt Item + | PutFlIt {_putItem :: Item} | PutPPlate PressPlate | PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2] } | PutCoord Point2 diff --git a/src/Dodge/Default/Item.hs b/src/Dodge/Default/Item.hs index 5e56e4a75..b1ec39395 100644 --- a/src/Dodge/Default/Item.hs +++ b/src/Dodge/Default/Item.hs @@ -1,21 +1,10 @@ module Dodge.Default.Item - ( basicItemDisplay - , maybeWarmupStatus - , maybeRateStatus - , moduleStrings - , defaultItem + ( defaultItem ) where import Dodge.Data -import Padding -import Dodge.Inventory.ItemSpace -import Dodge.Module import Picture import Shape -import Data.Maybe -import Data.Sequence -import Control.Lens - defaultItem :: Item defaultItem = Item { _itCurseStatus = Uncursed @@ -25,7 +14,6 @@ defaultItem = Item , _itID = Nothing , _itIsHeld = False , _itInvColor = yellow - , _itInvDisplay = basicItemDisplay , _itInvSize = 1 , _itInvPos = Nothing , _itDimension = ItemDimension 0 0 NoPortage (const mempty) @@ -39,51 +27,5 @@ defaultItem = Item , _itValue = ItemValue 0 MundaneItem } -{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -} --- TODO make work on remote launchers -basicItemDisplay :: Item -> [String] -basicItemDisplay it = Prelude.take (itSlotsTaken it) $ - (midPadL 15 ' ' thename (' ' : thenumber) ++ theparam) - : catMaybes [maybeWarmupStatus it] - ++ moduleStrings it ++ repeat "*" - where - thename = show . _iyBase $ _itType it - thenumber = case it ^? itConsumption of - Just am@LoadableAmmo{} -> case _laReloadState am of - Nothing' -> show (_laLoaded am) - Just' x -> show x ++ "R" ++ show (_laLoaded am) - Just am@ChargeableAmmo{} -> show $ _wpCharge am - Just x@ItemItselfConsumable{} -> show (_icAmount x) - Just NoConsumption -> "" - Nothing -> "" - theparam = fromMaybe [] - . listToMaybe - $ mapMaybe ($ it) - [ maybeModeStatus --- , maybeWarmupStatus --- , maybeRateStatus - ] --- this can be moved to Dodge/Module and unified with moduleSizes - -maybeModeStatus :: Item -> Maybe String -maybeModeStatus it = case it ^? itAttachment of - Just AttachCharMode {_atCharMode = (c :<| _)} -> Just [' ',c] - Just AttachMode {_atMode = i} -> Just $ show i - _ -> Nothing - -maybeRateStatus :: Item -> Maybe String -maybeRateStatus it = case it ^? itUse . useDelay . rateMaxMax of - Nothing -> Nothing - _ -> Just $ leftPad 3 ' ' (show (_rateMax . _useDelay $ _itUse it)) - -maybeWarmupStatus :: Item -> Maybe String -maybeWarmupStatus it = case it ^? itUse . useDelay . warmMax of - Nothing -> Nothing - Just m -> case m - (_warmTime . _useDelay $ _itUse it) of - x | x <= 1 -> Just "*WARM" - | otherwise -> let n = show x - in Just $ Prelude.take (5 - Prelude.length n) "*WARM" ++ n - defaultItemType :: ItemType defaultItemType = ItemType NOTDEFINED mempty NoStack - diff --git a/src/Dodge/Default/Weapon.hs b/src/Dodge/Default/Weapon.hs index 5be62acff..cf12b276d 100644 --- a/src/Dodge/Default/Weapon.hs +++ b/src/Dodge/Default/Weapon.hs @@ -107,7 +107,6 @@ defaultGun = defaultItem , _itInvPos = Nothing , _itIsHeld = False , _itEffect = NoItEffect - , _itInvDisplay = basicItemDisplay , _itInvColor = white , _itInvSize = 1 , _itParams = NoParams diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 3ea12ed5f..1fa0f4513 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -39,11 +39,7 @@ import Data.List (intersperse) initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) --- [ IntAnno $ AnTree . startRoom - [ AnRoom tanksPipesRoom - , AnRoom tanksPipesRoom - , AnRoom $ tanksRoom [] [] - , AnRoom roomPillarsPassage + [ IntAnno $ AnTree . startRoom , AnTree firstBreather -- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) , AnRoom $ roomCCrits 10 diff --git a/src/Dodge/Item/Display.hs b/src/Dodge/Item/Display.hs new file mode 100644 index 000000000..66e51c365 --- /dev/null +++ b/src/Dodge/Item/Display.hs @@ -0,0 +1,60 @@ +module Dodge.Item.Display where +import Dodge.Module +import Dodge.Data +import Dodge.Inventory.ItemSpace +import Padding +import LensHelp + +import Data.Maybe +import Data.Sequence + +itemString :: Item -> String +itemString = head . itemDisplay + +{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -} +-- TODO make work on remote launchers +itemDisplay :: Item -> [String] +itemDisplay it = Prelude.take (itSlotsTaken it) $ + (midPadL 15 ' ' thename (' ' : thenumber) ++ theparam) + : catMaybes [maybeWarmupStatus it] + ++ moduleStrings it ++ repeat "*" + where + thename = show . _iyBase $ _itType it + thenumber = case it ^? itConsumption of + Just am@LoadableAmmo{} -> case _laReloadState am of + Nothing' -> show (_laLoaded am) + Just' x -> show x ++ "R" ++ show (_laLoaded am) + Just am@ChargeableAmmo{} -> show $ _wpCharge am + Just x@ItemItselfConsumable{} -> show (_icAmount x) + Just NoConsumption -> "" + Nothing -> "" + theparam = fromMaybe [] + . listToMaybe + $ mapMaybe ($ it) + [ maybeModeStatus +-- , maybeWarmupStatus +-- , maybeRateStatus + ] + +-- & itInvDisplay .~ \it -> head (basicItemDisplay it) : +-- ["*FIRERATE:" ++ fromMaybe "" (maybeRateStatus it) +-- ] + +maybeWarmupStatus :: Item -> Maybe String +maybeWarmupStatus it = case it ^? itUse . useDelay . warmMax of + Nothing -> Nothing + Just m -> case m - (_warmTime . _useDelay $ _itUse it) of + x | x <= 1 -> Just "*WARM" + | otherwise -> let n = show x + in Just $ Prelude.take (5 - Prelude.length n) "*WARM" ++ n + +maybeModeStatus :: Item -> Maybe String +maybeModeStatus it = case it ^? itAttachment of + Just AttachCharMode {_atCharMode = (c :<| _)} -> Just [' ',c] + Just AttachMode {_atMode = i} -> Just $ show i + _ -> Nothing + +maybeRateStatus :: Item -> Maybe String +maybeRateStatus it = case it ^? itUse . useDelay . rateMaxMax of + Nothing -> Nothing + _ -> Just $ leftPad 3 ' ' (show (_rateMax . _useDelay $ _itUse it)) diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index 2e79ac1f3..baefaf63a 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -139,10 +139,6 @@ flatShield = defaultEquipment , _heldScroll = \_ _ -> id } , _itInvSize = 3 - , _itInvDisplay = \it -> head (basicItemDisplay it) : - ["*" ++ replicate 13 ' ' ++ "*" - ,"*" ++ replicate 13 ' ' ++ "*" - ] } & itType . iyBase .~ FLATSHIELD flatShieldEquipSPic :: Item -> SPic diff --git a/src/Dodge/Item/Weapon/BulletGun/Rod.hs b/src/Dodge/Item/Weapon/BulletGun/Rod.hs index c7b84d63b..69bffa794 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Rod.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Rod.hs @@ -7,7 +7,6 @@ module Dodge.Item.Weapon.BulletGun.Rod , machineGun ) where import Dodge.Data -import Dodge.Default.Item import Dodge.Item.Weapon.BulletGun.Clip import Dodge.Particle.HitEffect import Dodge.Particle.Damage @@ -33,7 +32,6 @@ import Shape --import Sound.Data import LensHelp -import Data.Maybe --import qualified Data.Sequence as Seq --import Control.Lens --import Control.Monad.State @@ -150,6 +148,3 @@ machineGun = bangRod & itConsumption . laReloadTime .~ 75 & itInvSize .~ 3 & itParams. torqueAfter .~ 0.2 -- not sure if this is necessary? - & itInvDisplay .~ \it -> head (basicItemDisplay it) : - ["*FIRERATE:" ++ fromMaybe "" (maybeRateStatus it) - ] diff --git a/src/Dodge/Item/Weapon/ExtraEffect.hs b/src/Dodge/Item/Weapon/ExtraEffect.hs index 7958d22f1..a69712bbc 100644 --- a/src/Dodge/Item/Weapon/ExtraEffect.hs +++ b/src/Dodge/Item/Weapon/ExtraEffect.hs @@ -16,6 +16,7 @@ module Dodge.Item.Weapon.ExtraEffect ) where import Dodge.Data import Dodge.Base +import Dodge.Zone import Dodge.SoundLogic --import Dodge.Item.Weapon.Decoration import Dodge.Item.Weapon.UseEffect diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index c8f86980b..ec2dab0aa 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -5,7 +5,7 @@ module Dodge.Placement.Instance.Door , switchDoor -- not used 9/3/22 ) where import Dodge.Data -import Dodge.Base +--import Dodge.Base import Color import Geometry import Dodge.LevelGen.Data diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index fc279b867..a6068af09 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -3,6 +3,7 @@ module Dodge.Render.HUD ( hudDrawings ) where import Dodge.Data +import Dodge.Item.Display import Dodge.Combine import Dodge.Clock import Dodge.Base @@ -281,7 +282,7 @@ invDimColor :: Color invDimColor = greyN 0.7 closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture] closeObjectToTextPictures nfreeslots e = case e of - Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ _itInvDisplay it it + Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it Right bt -> [color yellow $ textindent $ _btText bt] where textindent = text . (replicate clObjIntIn ' '++) @@ -369,9 +370,9 @@ mainListCursor c = openCursorAt 120 c 5 0 itemText :: Item -> [Picture] {-# INLINE itemText #-} itemText it = f $ case _itCurseStatus it of - UndroppableIdentified -> map (color yellow . text) (_itInvDisplay it it) + UndroppableIdentified -> map (color yellow . text) (itemDisplay it) -- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90))) - _ -> map (color thecolor . text) (_itInvDisplay it it) + _ -> map (color thecolor . text) (itemDisplay it) where thecolor = _itInvColor it f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*")) diff --git a/src/Dodge/Room/Breather.hs b/src/Dodge/Room/Breather.hs index 578713393..d41182224 100644 --- a/src/Dodge/Room/Breather.hs +++ b/src/Dodge/Room/Breather.hs @@ -31,8 +31,7 @@ import Dodge.Room.Containing firstBreather :: State StdGen (MetaTree Room String) firstBreather = do itms <- takeOne - [[] - ,[itemFromBase $ CRAFT TUBE] + [[itemFromBase $ CRAFT TUBE] ,[itemFromBase $ CRAFT PIPE] ,[itemFromBase $ CRAFT HARDWARE] ,[itemFromBase $ CRAFT CAN] diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs index 15083575a..d4a56602e 100644 --- a/src/Dodge/Room/Containing.hs +++ b/src/Dodge/Room/Containing.hs @@ -1,6 +1,7 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.Containing where import Dodge.Data +import Dodge.Item.Display import Dodge.Tree import Dodge.LevelGen.Data import Dodge.PlacementSpot @@ -16,7 +17,9 @@ import Geometry --import Dodge.Item.Equipment roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String) -roomsContaining crs its = tToBTree "roomsContaining" <$> roomsContaining' crs its +roomsContaining crs its = tToBTree str <$> roomsContaining' crs its + where + str = "roomsContaining "++ concatMap _crName crs ++ concatMap (head . itemDisplay) its roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room) roomsContaining' crs its = do @@ -24,6 +27,7 @@ roomsContaining' crs its = do [ roomPillarsSquare <&> rmPmnts .++~ crsItmsUnused crs its , randomFourCornerRoomCrsIts crs its , tanksRoom crs its + , tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its , roomPillarsContaining crs its , roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its ] diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 851d1b906..406d5b710 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -10,6 +10,7 @@ module Dodge.Room.Room , corDoor ) where import Dodge.Cleat +import Dodge.Item.Display import Dodge.Data import Dodge.PlacementSpot import Dodge.RoomLink @@ -135,8 +136,8 @@ roomCenterPillar = do ] {- Probabilites of the type of the first floor weapon. -} -randFirstWeapon :: State StdGen PSType -randFirstWeapon = takeOne $ map PutFlIt $ +randFirstWeapon :: State StdGen Item +randFirstWeapon = takeOne $ replicate 10 pistol ++ replicate 5 (bangStick 4) ++ replicate 5 (bangCaneX 3) @@ -148,7 +149,7 @@ weaponEmptyRoom = do w <- state $ randomR (220,300) h <- state $ randomR (220,300) let plmnts = - [sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon + [sPS (V2 (w/2) (h-40)) 0 $ RandPS $ fmap PutFlIt randFirstWeapon ,sPS (V2 20 20) (pi/2) randC1 ,sPS (V2 (w-20) 20) (pi/2) randC1 ,mntLightLnkCond useUnusedLnk @@ -160,7 +161,7 @@ weaponEmptyRoom = do weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String) weaponUnderCrits i = do - let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon) + let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS $ fmap PutFlIt randFirstWeapon) continuationRoom = treePost [ addwpat (V2 20 0) corridorN , addwpat (V2 20 0) corridorN @@ -185,13 +186,13 @@ weaponBehindPillar = do return $ treePost [ corridor , rcp & rmPmnts ++.~ - [sPS wpos wpa $ RandPS randFirstWeapon + [sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon ,sPS cpos (argV $ V2 120 80 -.- cpos) randC1 ] , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN ] -weaponBetweenPillars :: RandomGen g => State g (Tree Room) +weaponBetweenPillars :: State StdGen (MetaTree Room String) weaponBetweenPillars = do (w,wn) <- takeOne [(240,2),(340,3)] (h,hn) <- takeOne [(240,2),(340,3)] @@ -202,13 +203,14 @@ weaponBetweenPillars = do , any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r) ] ncrits <- state $ randomR (1,3) + wp <- randFirstWeapon critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r -> rpIsOnPath rp && _rpPlacementUse rp == 0 && all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r) - fmap pure $ roomPillars 30 w h wn hn - <&> rmPmnts .++~ sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots - <&> cleatOnward + (fmap pure $ roomPillars 30 w h wn hn + <&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [ sps wpPos (PutFlIt wp) ] + <&> cleatOnward) >>= rToOnward ("weaponBetweenPillars_"++itemString wp) weaponLongCorridor :: RandomGen g => State g (Tree Room) weaponLongCorridor = do @@ -222,7 +224,7 @@ weaponLongCorridor = do return $ Node rt [branch1,branch2] where putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ] - putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] + putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] critInDeadEnd :: Room critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1] @@ -239,12 +241,12 @@ deadEndRoom = defaultRoom where lnks = [(V2 0 30 ,0) ] {- A random Either tree with a weapon and melee monster challenge. -} -weaponRoom :: RandomGen g => Int -> State g (MetaTree Room String) +weaponRoom :: Int -> State StdGen (MetaTree Room String) weaponRoom i = join $ takeOne [ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom" , weaponUnderCrits i -- this int is used for PickOnePlacement , weaponBehindPillar >>= rToOnward "weaponBehindPillar" - , weaponBetweenPillars >>= rToOnward "weaponBetweenPillars" + , weaponBetweenPillars-- >>= rToOnward "weaponBetweenPillars" , weaponLongCorridor >>= rToOnward "weaponLongCorridor" ] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index b503bdb04..02a95bc2c 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -56,7 +56,7 @@ powerFakeout = do ,cleatOnward door] -- the i is used either for a PickOnePlacement or a room id, this is not great -startRoom :: RandomGen g => Int -> State g (MetaTree Room String) +startRoom :: Int -> State StdGen (MetaTree Room String) startRoom i = join $ takeOne [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 5833baa5e..0fb9294d7 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -126,4 +126,4 @@ numMetaTree' (MTree lab mn bs) = do return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs' showIntsString :: ([Int],String) -> String -showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show is)) ++ ':':s +showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show $ reverse is)) ++ ':':s diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 5592c39e7..25f193319 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -210,7 +210,7 @@ farWallDistDirection :: Point2 -> Configuration -> World -> (Float,Float,Float,F --farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps farWallDistDirection p cfig w = foldr (m . f) (0,0,0,0) vps where - f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilter' wlIsOpaque p q wos -.- p + f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWalls' p q (IM.filter wlIsOpaque wos) -.- p g (V2 x y) = (y, negate y, x, negate x) m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w') vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index fce69e267..18c6b6e3b 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -8,7 +8,6 @@ module Dodge.WorldEvent.SpawnParticle , concBall ) where import Dodge.Data -import Dodge.Base import Dodge.Zone import Dodge.Particle.HitEffect.ExpireAndDamage import Dodge.Particle.Damage diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 23204ddcd..2de0c461e 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -17,12 +17,18 @@ module Dodge.Zone , wallsNearZones , zoneOfSight , flattenIMIMIM + , creaturesNearPointI + , creaturesNearPoint + , creatureNearPoint + , creatureNearPointI + , creaturesAlongLine ) where import Dodge.Data import Dodge.Base.Window import Geometry import Geometry.Zone +import qualified FoldlHelp as L import Data.Maybe import Data.List @@ -179,3 +185,32 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1 flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a flattenIMIMIM = IM.unions . fmap IM.unions + +creatureNearPoint :: Point2 -> World -> Maybe Creature +creatureNearPoint = creatureNearPointI 1 + +creatureNearPointI :: Int -> Point2 -> World -> Maybe Creature +creatureNearPointI n p = L.fold (L.minimumOn (dist p . _crPos)) . creaturesNearPointI n p + +creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature +creaturesNearPoint = creaturesNearPointI 1 + +creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature +creaturesNearPointI n p w = IM.unions + [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]] + where + (x,y) = crZoneOfPoint p + f i m = fromMaybe IM.empty $ IM.lookup i m + +-- possible BUG, occurs when used in thingsHitLongLine +creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature +--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b] +-- where f i m = case IM.lookup i m of Just val -> val +-- _ -> IM.empty + +creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b) + where + g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s)) + f i = fromMaybe IM.empty . IM.lookup i +-- f i m = case IM.lookup i m of Just val -> val +-- _ -> IM.empty