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

Refactor path zoning

Browse Source
This commit is contained in:
justin
2022-07-23 13:47:54 +01:00
parent 94d5691f46
commit d8b1a0c71e
10 changed files with 85 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+4 -2
View File
@@ -236,8 +236,10 @@ data World = World
, _corpses :: IM.IntMap Corpse
, _clickMousePos :: Point2
, _pathGraph :: Gr Point2 PathEdge
, _pnZoning :: Zoning [] (Int,Point2)
, _peZoning :: Zoning [] (Int,Int,PathEdge)
--, _pnZoning :: Zoning [] (Int,Point2)
--, _peZoning :: Zoning [] (Int,Int,PathEdge)
, _pnZoning :: IM.IntMap (IM.IntMap [(Int,Point2)]) --Zoning IM.IntMap Creature
, _peZoning :: IM.IntMap (IM.IntMap [(Int,Int,PathEdge)]) --Zoning IM.IntMap Creature
, _hud :: HUD
, _lightSources :: IM.IntMap LightSource
, _tempLightSources :: [TempLightSource]
src/Dodge/Default/World.hs
+2 -6
View File
@@ -1,9 +1,5 @@
module Dodge.Default.World where
import Dodge.Data
import Dodge.Zone.Size
import Dodge.Zone.Object
--import Geometry.Vector3D
import Geometry.Zone
import Geometry.Data
import Geometry.Polygon
@@ -76,8 +72,8 @@ defaultWorld = World
, _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
-- , _pathGraphP = mempty
, _pnZoning = Zoning mempty peZoneSize (zonePos snd)
, _peZoning = Zoning mempty peZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
, _pnZoning = mempty
, _peZoning = mempty
, _hud = HUD
{ _hudElement = DisplayInventory NoSubInventory
, _carteCenter = V2 0 0
src/Dodge/Layout.hs
+3 -5
View File
@@ -2,10 +2,10 @@
module Dodge.Layout
( generateLevelFromRoomList
) where
import Dodge.Zoning.Pathing
import Data.Tile
import Dodge.Data
import Dodge.Path
import Dodge.Zone.Update
import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot
--import Dodge.LevelGen.Data
@@ -45,10 +45,8 @@ generateLevelFromRoomList gr' w = initWallZoning
, _gameRooms = gameRoomsFromRooms (IM.elems rs')
, _pathGraph = path
}
& pnZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
(labNodes path))
& peZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
(labEdges path))
& pnZoning .~ foldl' (flip $ zonePn) mempty (labNodes path)
& peZoning .~ foldl' (flip $ zonePe) mempty (labEdges path)
where
(_,path) = pairsToGraph pairPath'
pairPath = foldMap _rmPath rs
src/Dodge/Path.hs
+6 -5
View File
@@ -11,9 +11,10 @@ module Dodge.Path
, bfsNodePoints
, fusePairs
) where
import Dodge.Zoning.Pathing
import Dodge.Zoning.Base
import Dodge.Data
import Dodge.Base.Collide
import Dodge.Zone
import Geometry.Data
import Geometry
@@ -52,7 +53,7 @@ walkableNodeNear :: World -> Point2 -> Maybe Int
walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
where
--nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w
nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w
nodesNear = zonesExtract (w ^. pnZoning) $ zonesAroundPoint pnZoneSize p
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
@@ -137,12 +138,12 @@ addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
obstructPathsCrossing obstacletype sp' ep w =
( w & pathGraph %~ updateedges
, runIdentity $ S.toList_ es
, es
)
where
es = S.filter edgecrosses $ nearSeg _peZoning sp' ep w
es = filter edgecrosses $ pesNearSeg sp' ep w
edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
updateedges gr = runIdentity $ S.fold_ updateedge gr id es
updateedges gr = foldl' updateedge gr es
updateedge gr (x,y,pe)
= insEdge (x,y,pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x,y) gr
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -1,7 +1,7 @@
module Dodge.Render.ShapePicture
( worldSPic
) where
import Dodge.Zoning.Wall
import Dodge.Zoning
import Dodge.Button.Draw
import Dodge.LightSource.Draw
import Dodge.Targeting.Draw
src/Dodge/Zone/Size.hs
+4 -4
View File
@@ -1,10 +1,10 @@
module Dodge.Zone.Size where
pnZoneSize :: Float
pnZoneSize = 100
--pnZoneSize :: Float
--pnZoneSize = 100
clZoneSize :: Float
clZoneSize = 20
peZoneSize :: Float
peZoneSize = 50
--peZoneSize :: Float
--peZoneSize = 50
src/Dodge/Zoning.hs
+2
View File
@@ -1,7 +1,9 @@
module Dodge.Zoning
( module Dodge.Zoning.Creature
, module Dodge.Zoning.Wall
, module Dodge.Zoning.Pathing
) where
import Dodge.Zoning.Creature
import Dodge.Zoning.Wall
import Dodge.Zoning.Pathing
src/Dodge/Zoning/Base.hs
+6 -1
View File
@@ -65,6 +65,11 @@ zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton y a
deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 -> IM.IntMap (IM.IntMap IS.IntSet)
deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i
zoneOfPoint'' :: Float -> Point2 -> V2 Int
zoneOfPoint'' :: Float -> Point2 -> Int2
{-# INLINE zoneOfPoint'' #-}
zoneOfPoint'' s = fmap (divTo s)
zonesAroundPoint :: Float -> Point2 -> [Int2]
zonesAroundPoint s p = [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
where
V2 x y = zoneOfPoint' s p
src/Dodge/Zoning/Cloud.hs
+1 -1
View File
@@ -5,7 +5,7 @@ import Dodge.Zoning.Base
import Dodge.Data
import Geometry
import Data.Foldable
--import Data.Foldable
import Control.Lens
import qualified IntMapHelp as IM
src/Dodge/Zoning/Pathing.hs
+56
View File
@@ -0,0 +1,56 @@
module Dodge.Zoning.Pathing
where
import Geometry.Vector
import Dodge.Zoning.Base
import Dodge.Data
import Geometry
import Data.Foldable
import Control.Lens
import qualified IntMapHelp as IM
pnsNearPoint :: Point2 -> World -> [(Int,Point2)]
pnsNearPoint p w = zoneExtract (zoneOfPoint' pnZoneSize p) (w ^. pnZoning)
pnsNearSeg :: Point2 -> Point2 -> World -> [(Int,Point2)]
pnsNearSeg sp ep w = zonesExtract (w ^. pnZoning) (zoneOfSeg' pnZoneSize sp ep)
pnsNearRect :: Point2 -> Point2 -> World -> [(Int,Point2)]
pnsNearRect sp ep w = zonesExtract (w ^. pnZoning) $ zoneOfRect' pnZoneSize sp ep
pnsNearCirc :: Point2 -> Float -> World -> [(Int,Point2)]
pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
pnZoneSize :: Float
pnZoneSize = 50
zoneOfPn :: (Int,Point2) -> Int2
zoneOfPn = zoneOfPoint'' pnZoneSize . snd
zonePn :: (Int,Point2) -> IM.IntMap (IM.IntMap [(Int,Point2)]) -> IM.IntMap (IM.IntMap [(Int,Point2)])
zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
pesNearPoint :: Point2 -> World -> [(Int,Int,PathEdge)]
pesNearPoint p w = zoneExtract (zoneOfPoint' peZoneSize p) (w ^. peZoning)
pesNearSeg :: Point2 -> Point2 -> World -> [(Int,Int,PathEdge)]
pesNearSeg sp ep w = zonesExtract (w ^. peZoning) (zoneOfSeg' peZoneSize sp ep)
pesNearRect :: Point2 -> Point2 -> World -> [(Int,Int,PathEdge)]
pesNearRect sp ep w = zonesExtract (w ^. peZoning) $ zoneOfRect' peZoneSize sp ep
pesNearCirc :: Point2 -> Float -> World -> [(Int,Int,PathEdge)]
pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
peZoneSize :: Float
peZoneSize = 50
zoneOfPe :: (Int,Int,PathEdge) -> [Int2]
zoneOfPe (_,_,pe) = zoneOfSeg' peZoneSize (_peStart pe) (_peEnd pe)
zonePe :: (Int,Int,PathEdge) -> IM.IntMap (IM.IntMap [(Int,Int,PathEdge)]) -> IM.IntMap (IM.IntMap [(Int,Int,PathEdge)])
zonePe pe im = foldl' f im (zoneOfPe pe)
where
f im' i2 = zoneMonoid i2 [pe] im'