justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Improve line zoning

Browse Source
This commit is contained in:
jgk
2021-08-16 14:44:52 +02:00
parent 3192ae628f
commit c58ee6d56c
13 changed files with 197 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+5 -5
View File
@@ -74,7 +74,7 @@ wallNormal wl = normalizeV . vNormal $ a -.- b
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
wallsOnLine p1 p2 ws = hitWalls
where
hitPoint w = uncurry (intersectSegSeg' p1 p2) (_wlLine w)
hitPoint w = uncurry (intersectSegSeg p1 p2) (_wlLine w)
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
@@ -252,7 +252,7 @@ collidePointFF = undefined
-- -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
--collidePointFF p1 p2 g ff = fmap f ip
-- where (p3:p4:_) = _ffLine ff
-- ip = intersectSegSeg' p1 p2 p3 p4
-- ip = intersectSegSeg p1 p2 p3 p4
-- ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff
-- f p = (p, (ref, _ffID ff))
--
@@ -267,7 +267,7 @@ collideCircWalls' p1 p2 rad ws
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
(intersectSegSeg p1 p2 x y)
)
. shiftByRad . _wlLine
) ws
@@ -288,7 +288,7 @@ collideCircWalls' p1 p2 rad ws
collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
collidePointLines p1 p2 ws
= safeMinimumOn f
$ mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> ( , vNormal $ x -.- y ) )
$ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine') ws
where
f (a,_) = magV (p1 -.- a)
@@ -298,7 +298,7 @@ collidePointLines p1 p2 ws
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws
= safeMinimumOn f
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> ( , vNormal $ x -.- y ) )
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
src/Dodge/Base/Collide.hs
+9 -9
View File
@@ -24,7 +24,7 @@ hitPointLines
hitPointLines p1 p2
= safeMinimumOn (dist p1 . fst)
. mapMaybe
(\(x,y) -> (, (x,y)) <$> intersectSegSeg' p1 p2 x y)
(\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y)
-- | looks for first collision of a point with walls
-- if found, gives point and reflection velocity
@@ -36,7 +36,7 @@ reflectPointWalls p1 p2 ws
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
(intersectSegSeg p1 p2 x y)
)
. _wlLine) ws
-- | Looks for first collision of a point with walls.
@@ -52,43 +52,43 @@ reflectPointWallsDamped dfact p1 p2 ws
$ IM.mapMaybe
(( \(x,y) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
(intersectSegSeg' p1 p2 x y))
(intersectSegSeg p1 p2 x y))
. _wlLine
) ws
-- | Test if a point collides with walls
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
pointHitsWalls p1 p2
= any $ isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine
= any $ isJust . uncurry (intersectSegSeg p1 p2) . _wlLine
-- | Test if there something blocking a walk
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws
= any (isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine)
= any (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
furthestPointWalkable p1 p2 ws
= fromMaybe p2
. safeMinimumOn (dist p1)
$ IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) ws
$ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
{-# INLINE collidePointIndirect #-}
collidePointIndirect p1 p2 ws
= safeMinimumOn (dist p1)
. IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine)
. IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _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
= safeMinimumOn (dist p1)
. IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine )
. IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _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 . uncurry (intersectSegSeg' p1 p2) . _wlLine)
= any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
$ IM.filter notBlockWindow ws
where
notBlockWindow wl = case wl ^? blHP of
src/Dodge/Base/Zone.hs
+12 -9
View File
@@ -5,6 +5,7 @@ module Dodge.Base.Zone
import Dodge.Data
import Dodge.Base.Window
import Geometry
import Geometry.Zone
import Data.Maybe
import Data.List
@@ -73,14 +74,16 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
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
--{-# INLINE zoneOfLineIntMap #-}
zoneOfLineIntMap = ddaExt zoneSize
--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 #-}
--{-# INLINE expandLine #-}
expandLine xs = IM.map expandSet
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
where
@@ -172,10 +175,10 @@ lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
-- 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
--{-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldlWithKey' g IM.empty kps
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s)) m
kps = zoneOfLineIntMap a b
f i m = case IM.lookup i m of
Just val -> val
src/Dodge/LevelGen/Pathing.hs
+1 -1
View File
@@ -23,6 +23,6 @@ removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w
where
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraph' w
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg'
src/Dodge/LevelGen/TriggerDoor.hs
+2 -2
View File
@@ -30,7 +30,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
@@ -49,7 +49,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
src/Dodge/Render/Picture.hs
+3 -3
View File
@@ -121,7 +121,7 @@ wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
-- towards the center of sight
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool
lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp' = screenPolygon w
vp = _cameraViewFrom w
@@ -132,7 +132,7 @@ lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
lineOnScreen :: World -> Point2 -> Point2 -> Bool
lineOnScreen w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
@@ -160,7 +160,7 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] +
where
borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x))
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x))
. makeLoopPairs $ screenPolygon w
rectangleSolid :: Float -> Float -> Picture
src/Dodge/Update.hs
+1 -1
View File
@@ -226,5 +226,5 @@ visibleWalls p1 p2 ws
. map f
$ IM.toList ws
where
f (i,wl) = (uncurry intersectSegSeg' (_wlLine wl) p1 p2, (i,wl))
f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, (i,wl))
src/Dodge/WallCreatureCollisions.hs
+2 -2
View File
@@ -105,11 +105,11 @@ checkPushThroughs cp1 wls cp2
checkPushThrough :: Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2
checkPushThrough cp1 cp2 (wp1,wp2)
| isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
| isPushedThrough = intersectSegSeg cp1 cp2 wp1 wp2
| otherwise = Nothing
where
--norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
--wp1' = (rad *.* norm) +.+ wp1
--wp2' = (rad *.* norm) +.+ wp2
--newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg cp1 cp2 wp1 wp2)
src/Dodge/WorldEvent/ThingsHit.hs
+2 -2
View File
@@ -34,7 +34,7 @@ thingsHit sp ep w
Just val -> val
_ -> IM.empty
wls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitPoint w' = uncurry (intersectSegSeg' sp ep) (_wlLine w')
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
{- List objects that appear on a line.
@@ -76,7 +76,7 @@ thingsHitLongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
wls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
hitPoint wl = uncurry (intersectSegSeg' sp ep) (_wlLine wl)
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs