Refactoring
This commit is contained in:
@@ -0,0 +1,211 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{- | Basic collision detection for a moving point -}
|
||||
module Dodge.Base.Collide
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.Zone
|
||||
import Geometry
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
|
||||
hasLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOS #-}
|
||||
hasLOS p1 p2 w = (not $ pointHitsWalls p1 p2 nearbyWalls)
|
||||
where
|
||||
nearbyWalls = wallsAlongLine p1 p2 w
|
||||
-- | looks for first collision of a point with walls
|
||||
-- if found, gives point and reflection velocity
|
||||
reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
reflectPointWalls p1 p2 ws
|
||||
= listToMaybe
|
||||
. sortOn f
|
||||
. IM.elems
|
||||
$ IM.mapMaybe
|
||||
(( \(x:y:_) ->
|
||||
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
|
||||
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
|
||||
)
|
||||
(intersectSegSeg' p1 p2 x y)
|
||||
)
|
||||
. _wlLine) ws
|
||||
where
|
||||
f (a,_) = magV (p1 -.- a)
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
reflectPointWallsDamped
|
||||
:: Float -- ^ Damping factor, probably should be in (0,1)
|
||||
-> Point2
|
||||
-> Point2
|
||||
-> IM.IntMap Wall
|
||||
-> Maybe (Point2,Point2)
|
||||
reflectPointWallsDamped dfact p1 p2 ws
|
||||
= listToMaybe
|
||||
. sortOn f
|
||||
. IM.elems
|
||||
$ IM.mapMaybe
|
||||
(( \(x:y:_) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
|
||||
. (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
|
||||
(intersectSegSeg' p1 p2 x y))
|
||||
. _wlLine
|
||||
) ws
|
||||
where
|
||||
f (a,_) = magV (p1 -.- a)
|
||||
-- | Test if a point collides with walls
|
||||
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
pointHitsWalls p1 p2
|
||||
= any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine
|
||||
-- | Test if there something blocking a walk
|
||||
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
collidePointWalkable p1 p2 ws
|
||||
= any (isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
|
||||
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
|
||||
|
||||
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
|
||||
furthestPointWalkable p1 p2 ws
|
||||
= fromMaybe p2
|
||||
. listToMaybe
|
||||
. sortOn (dist p1)
|
||||
. IM.elems
|
||||
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
|
||||
|
||||
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
{-# INLINE collidePointIndirect #-}
|
||||
collidePointIndirect p1 p2 ws
|
||||
= listToMaybe
|
||||
. sortOn (dist p1)
|
||||
. IM.elems
|
||||
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
|
||||
$ IM.filter (not . _wlIsSeeThrough) ws
|
||||
{- | Checks to see whether someone can fire bullets effectively between two points.
|
||||
- Not sure if this needs vision as well, need to make this uniform. -}
|
||||
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
collidePointFire p1 p2 ws
|
||||
= listToMaybe
|
||||
. sortOn (dist p1)
|
||||
. IM.elems
|
||||
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine )
|
||||
$ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
|
||||
{- | Checks to see whether someone can fire bullets effectively between two points.
|
||||
- Not sure if this needs vision as well, need to make this uniform. -}
|
||||
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
collidePointFireVision p1 p2 ws
|
||||
= any ( isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
|
||||
$ IM.filter notBlockWindow ws
|
||||
where
|
||||
notBlockWindow wl = case wl ^? blHP of
|
||||
Just _ -> not $ _wlIsSeeThrough wl
|
||||
Nothing -> True
|
||||
|
||||
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
||||
hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w of
|
||||
Just _ -> False
|
||||
Nothing -> True
|
||||
|
||||
isWalkable :: Point2 -> Point2 -> World -> Bool
|
||||
isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
|
||||
where
|
||||
nearbyWalls = wallsAlongLine p1 p2 w
|
||||
|
||||
canSee :: Int -> Int -> World -> Bool
|
||||
canSee i j w = hasLOS p1 p2 w
|
||||
where
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
p2 = _crPos (_creatures w IM.! j)
|
||||
nearbyWalls = wallsAlongLine p1 p2 w
|
||||
|
||||
canSeePoint :: Int -> Point2 -> World -> Bool
|
||||
canSeePoint i p w = hasLOS p1 p w
|
||||
where
|
||||
nearbyWalls = wallsAlongLine p1 p w
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
|
||||
pathToPointFireable :: Int -> Point2 -> World -> Bool
|
||||
pathToPointFireable i p w
|
||||
= not
|
||||
. pointHitsWalls (_crPos (_creatures w IM.! i)) p
|
||||
$ IM.filter (not . isJust . \wl -> wl ^? blHP) $ wallsAlongLine p1 p w
|
||||
where
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
|
||||
canSeePointAll :: Int -> Point2 -> World -> Bool
|
||||
canSeePointAll i targPos w
|
||||
= and
|
||||
$ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
where
|
||||
cr = _creatures w IM.! i
|
||||
cpos = _crPos cr
|
||||
radius = _crRad cr
|
||||
|
||||
canSeeAny :: Int -> Int -> World -> Bool
|
||||
canSeeAny fromID toID w
|
||||
= or
|
||||
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
where
|
||||
cr = _creatures w IM.! toID
|
||||
cpos = _crPos cr
|
||||
radius = _crRad cr
|
||||
|
||||
canSeeAll :: Int -> Int -> World -> Bool
|
||||
canSeeAll fromID toID w
|
||||
= and
|
||||
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
|
||||
where
|
||||
cr = _creatures w IM.! toID
|
||||
cpos = _crPos cr
|
||||
radius = _crRad cr
|
||||
|
||||
canWalk :: Int -> Int -> World -> Bool
|
||||
canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
|
||||
where
|
||||
ipos = _crPos (_creatures w IM.! i)
|
||||
jpos = _crPos (_creatures w IM.! j)
|
||||
|
||||
canSeeIndirect :: Int -> Int -> World -> Bool
|
||||
canSeeIndirect i j w = not . isJust . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
|
||||
where
|
||||
ipos = _crPos (_creatures w IM.! i)
|
||||
jpos = _crPos (_creatures w IM.! j)
|
||||
|
||||
canSeeFire :: Point2 -> Point2 -> World -> Bool
|
||||
canSeeFire p p' w = not $ collidePointFireVision p p' $ wallsAlongLine p p' w
|
||||
|
||||
canSeeFireVision :: Int -> Int -> World -> Bool
|
||||
canSeeFireVision i j w = canSeeFire ipos jpos w
|
||||
where
|
||||
ipos = _crPos (_creatures w IM.! i)
|
||||
jpos = _crPos (_creatures w IM.! j)
|
||||
{- | Test whether both of the outside lines between two creatures are blocked -}
|
||||
canSeeFireVisionAny :: Int -> Int -> World -> Bool
|
||||
canSeeFireVisionAny i j w
|
||||
= not
|
||||
$ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj)
|
||||
(wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
|
||||
&& collidePointFireVision (ipos -.- ni) (jpos -.- nj)
|
||||
(wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
|
||||
where
|
||||
icr = _creatures w IM.! i
|
||||
jcr = _creatures w IM.! j
|
||||
ipos = _crPos icr
|
||||
jpos = _crPos jcr
|
||||
n = normalizeV $ vNormal $ ipos -.- jpos
|
||||
ni = _crRad icr *.* n
|
||||
nj = _crRad jcr *.* n
|
||||
{- | Test whether either of the outside lines between two creatures are blocked -}
|
||||
canSeeFireVisionAll :: Int -> Int -> World -> Bool
|
||||
canSeeFireVisionAll i j w
|
||||
= not
|
||||
$ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj)
|
||||
(wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
|
||||
|| collidePointFireVision (ipos -.- ni) (jpos -.- nj)
|
||||
(wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
|
||||
where
|
||||
icr = _creatures w IM.! i
|
||||
jcr = _creatures w IM.! j
|
||||
ipos = _crPos icr
|
||||
jpos = _crPos jcr
|
||||
n = normalizeV $ vNormal $ ipos -.- jpos
|
||||
ni = _crRad icr *.* n
|
||||
nj = _crRad jcr *.* n
|
||||
@@ -0,0 +1,24 @@
|
||||
{- | Getting the window size geometry. -}
|
||||
module Dodge.Base.Window
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Config.Data
|
||||
import Geometry
|
||||
|
||||
screenPolygon :: World -> [Point2]
|
||||
screenPolygon w = [tr,tl,bl,br]
|
||||
where
|
||||
scRot = rotateV (_cameraRot w)
|
||||
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
|
||||
scTran p = p +.+ _cameraCenter w
|
||||
tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w)
|
||||
tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w)
|
||||
br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
|
||||
bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
|
||||
|
||||
halfWidth,halfHeight :: World -> Float
|
||||
halfWidth w = getWindowX w / 2
|
||||
halfHeight w = getWindowY w / 2
|
||||
|
||||
getWindowX = _windowX . _config
|
||||
getWindowY = _windowY . _config
|
||||
@@ -0,0 +1,172 @@
|
||||
{- | Deals with the specific implementations of zoning for Dodge.
|
||||
- These are not yet fixed down. -}
|
||||
module Dodge.Base.Zone
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.Window
|
||||
import Geometry
|
||||
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import Data.Bifunctor
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.IntSet as IS
|
||||
zoneSize :: Float
|
||||
zoneSize = 50
|
||||
--zoneSize = 100
|
||||
|
||||
floorHun :: Float -> Int
|
||||
floorHun x = floor $ x / zoneSize
|
||||
zoneOfPoint :: Point2 -> (Int,Int)
|
||||
zoneOfPoint (x,y) = (floorHun x, floorHun y)
|
||||
|
||||
zoneNearPoint :: Point2 -> [(Int,Int)]
|
||||
zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
where
|
||||
x = floorHun x'
|
||||
y = floorHun y'
|
||||
|
||||
zoneAroundPoint :: Point2 -> [(Int,Int)]
|
||||
zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
|
||||
where
|
||||
x = floorHun x'
|
||||
y = floorHun y'
|
||||
|
||||
zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
|
||||
zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
|
||||
where
|
||||
x = floorHun x'
|
||||
y = floorHun y'
|
||||
xs = IS.fromAscList [x-i..x+i]
|
||||
ys = IS.fromAscList [y-i..y+i]
|
||||
|
||||
-- the laser seemed to be occasionally missing creatures,
|
||||
-- if this reoccurs, maybe change
|
||||
-- divide line factor from 2 to 1.5
|
||||
bres :: Point2 -> Point2 -> [(Int,Int)]
|
||||
bres a b = digitalLine (zoneOfPoint a) (zoneOfPoint b)
|
||||
|
||||
bresx :: Point2 -> Point2 -> [(Int,Int)]
|
||||
bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
|
||||
where
|
||||
(x,y) = zoneOfPoint a
|
||||
(x',y') = zoneOfPoint b
|
||||
|
||||
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
|
||||
zoneOfLine (aa,ab) (ba,bb)
|
||||
= nub
|
||||
. concatMap f
|
||||
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
|
||||
where
|
||||
f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
|
||||
|
||||
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
|
||||
{-# INLINE zoneOfLineIntMap #-}
|
||||
zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
|
||||
where
|
||||
(x,y) = zoneOfPoint a
|
||||
(x',y') = zoneOfPoint b
|
||||
|
||||
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
|
||||
{-# INLINE expandLine #-}
|
||||
expandLine xs = IM.map expandSet
|
||||
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
|
||||
where
|
||||
im = IM.fromListWith IS.union $ map (second IS.singleton) xs
|
||||
-- the second was suggested by hlint, but it increases laziness, so might
|
||||
-- not be ideal
|
||||
expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
|
||||
where
|
||||
mk = IS.findMax s
|
||||
|
||||
|
||||
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
|
||||
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
|
||||
|
||||
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
|
||||
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
|
||||
|
||||
-- looking at this again, I am not convinced it deals correctly with the
|
||||
-- rotation of the world
|
||||
zoneOfScreen :: World -> [(Int,Int)]
|
||||
zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
|
||||
, b <- [y - n .. y + n]
|
||||
]
|
||||
where
|
||||
(x,y) = zoneOfPoint $ _cameraCenter w
|
||||
n = ceiling $ wh / (_cameraZoom w * zoneSize)
|
||||
wh = max (getWindowX w) (getWindowY w)
|
||||
|
||||
zoneOfDoubleScreen :: World -> [(Int,Int)]
|
||||
zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
|
||||
, b <- [y - n .. y + n]
|
||||
]
|
||||
where
|
||||
(x,y) = zoneOfPoint $ _cameraCenter w
|
||||
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
|
||||
wh = max (getWindowX w) (getWindowY w)
|
||||
|
||||
zoneOfSight :: World -> [(Int,Int)]
|
||||
zoneOfSight w =
|
||||
[(a,b)
|
||||
| a <- [minimum xs .. maximum xs]
|
||||
, b <- [minimum ys .. maximum ys]
|
||||
]
|
||||
where
|
||||
(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
|
||||
|
||||
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
|
||||
wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
|
||||
where
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
|
||||
ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
|
||||
|
||||
ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
|
||||
ixNZ z p = lookLookups (zoneNearPoint p) z
|
||||
|
||||
lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a
|
||||
lookLookup i j z = case IM.lookup i z of
|
||||
Just z' -> IM.lookup j z'
|
||||
Nothing -> Nothing
|
||||
|
||||
lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
|
||||
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
|
||||
|
||||
-- possible BUG, was associated with thingsHitLongLine
|
||||
-- assumes _wallsZone is correct level generation
|
||||
-- there is certainly a problem somewhere here: it may be in the zoning, or
|
||||
-- within this function
|
||||
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
|
||||
{-# INLINE wallsAlongLine #-}
|
||||
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
|
||||
where
|
||||
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
|
||||
kps = zoneOfLineIntMap a b
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
|
||||
{-# INLINE wallsNearZone' #-}
|
||||
wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
|
||||
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
|
||||
f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
|
||||
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
|
||||
wallsAlongCirc p r w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
|
||||
where f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
|
||||
wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
where
|
||||
(x,y) = zoneOfPoint p
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
Reference in New Issue
Block a user