Move zoning up world spheres

This commit is contained in:
2023-02-23 18:19:48 +00:00
parent f873b679aa
commit f98f95d92f
17 changed files with 96 additions and 72 deletions
+2
View File
@@ -9,6 +9,7 @@ module Dodge.Data.CWorld (
module Dodge.Data.CamPos
) where
import Geometry.Data
import Dodge.Data.LWorld
import Control.Lens
import Data.Aeson
@@ -27,6 +28,7 @@ data CWorld = CWorld
, _pastWorlds :: [LWorld]
, _timeFlow :: TimeFlowStatus
, _seenWalls :: IS.IntSet
, _floorTiles :: [(Point3, Point3)]
}
data TimeFlowStatus
-9
View File
@@ -47,12 +47,10 @@ module Dodge.Data.LWorld (
module Dodge.Data.WorldEffect,
) where
import Data.Set (Set)
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Data.Graph.Inductive
import qualified Data.IntSet as IS
import Dodge.Data.Beam
import Dodge.Data.Block
import Dodge.Data.Bounds
@@ -99,13 +97,10 @@ import Picture.Data
data LWorld = LWorld
{ _creatures :: IM.IntMap Creature
, _crZoning :: IM.IntMap (IM.IntMap IS.IntSet)
, _creatureGroups :: IM.IntMap CrGroupParams
, _itemLocations :: IM.IntMap ItemLocation
, _clouds :: [Cloud]
, _clZoning :: IM.IntMap (IM.IntMap [Cloud])
, _gusts :: IM.IntMap Gust
, _gsZoning :: IM.IntMap (IM.IntMap IS.IntSet)
, _props :: IM.IntMap Prop
, _projectiles :: IM.IntMap Proj
, _instantBullets :: [Bullet]
@@ -134,9 +129,7 @@ data LWorld = LWorld
, _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2
, _triggers :: IM.IntMap Bool
, _wlZoning :: IM.IntMap (IM.IntMap IS.IntSet) -- Zoning IM.IntMap Wall
, _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3, Point3)]
, _modifications :: IM.IntMap Modification
, _worldEvents :: [WdWd]
, _delayedEvents :: [(Int, WdWd)]
@@ -146,8 +139,6 @@ data LWorld = LWorld
, _foregroundShapes :: IM.IntMap ForegroundShape
, _corpses :: IM.IntMap Corpse
, _pathGraph :: Gr Point2 PathEdge
, _pnZoning :: IM.IntMap (IM.IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
, _peZoning :: IM.IntMap (IM.IntMap (Set PathEdgeNodes))
, _lightSources :: IM.IntMap LightSource
, _tempLightSources :: [TempLightSource]
, _seenLocations :: IM.IntMap (WdP2, String)
+9
View File
@@ -13,6 +13,9 @@ module Dodge.Data.World (
module Dodge.Data.Input,
) where
import Geometry.Data
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
import Data.Set (Set)
import Dodge.Data.SaveSlot
import Control.Lens
@@ -39,6 +42,12 @@ data World = World
, _rbOptions :: RightButtonOptions
, _hud :: HUD
, _worldEventFlags :: Set WorldEventFlag
, _crZoning :: IntMap (IntMap IntSet)
, _clZoning :: IntMap (IntMap [Cloud])
, _wlZoning :: IntMap (IntMap IntSet) -- Zoning IM.IntMap Wall
, _pnZoning :: IntMap (IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
, _peZoning :: IntMap (IntMap (Set PathEdgeNodes))
, _gsZoning :: IntMap (IntMap IntSet)
}
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
+7 -7
View File
@@ -41,6 +41,12 @@ defaultWorld =
, _rbOptions = NoRightButtonOptions
, _hud = defaultHUD
, _worldEventFlags = mempty
, _crZoning = mempty
, _clZoning = mempty
, _wlZoning = mempty
, _pnZoning = mempty
, _peZoning = mempty
, _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
}
defaultCWGen :: CWGen
@@ -77,6 +83,7 @@ defaultCWorld =
, _pastWorlds = []
, _timeFlow = NormalTimeFlow
, _seenWalls = mempty
, _floorTiles = mempty
}
defaultLWorld :: LWorld
@@ -85,12 +92,9 @@ defaultLWorld =
{ _magnets = IM.empty
, _modifications = IM.empty
, _creatures = IM.empty
, _crZoning = mempty --Zoning IM.empty crZoneSize zoneOfCreature
, _creatureGroups = IM.empty
, _clouds = mempty
, _clZoning = mempty
, _gusts = IM.empty
, _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
, _itemLocations = IM.empty
, _props = IM.empty
, _projectiles = IM.empty
@@ -119,9 +123,7 @@ defaultLWorld =
, _doors = IM.empty
, _coordinates = IM.empty
, _triggers = IM.empty
, _wlZoning = IM.empty --Zoning IM.empty wlZoneSize zoneOfWall
, _floorItems = IM.empty
, _floorTiles = []
, _worldEvents = []
, _delayedEvents = []
, _pressPlates = IM.empty
@@ -129,8 +131,6 @@ defaultLWorld =
, _corpses = IM.empty
, _decorations = IM.empty
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pnZoning = mempty
, _peZoning = mempty
, _lightSources = IM.empty
, _tempLightSources = []
, _seenLocations =
+7 -17
View File
@@ -4,7 +4,6 @@ module Dodge.Layout (
) where
import qualified Control.Foldl as L
import Dodge.Item.Location.Initialize
import Control.Lens
import Data.Foldable
import Data.Function
@@ -16,6 +15,7 @@ import Data.Traversable
import Dodge.Data.GenWorld
import Dodge.Default.Wall
import Dodge.GameRoom
import Dodge.Item.Location.Initialize
import Dodge.LevelGen.LevelStructure
import Dodge.LevelGen.StaticWalls
import Dodge.Path
@@ -45,8 +45,8 @@ generateLevelFromRoomList gr' w =
$ w & cWorld . lWorld . walls .~ wallsFromRooms rs
& cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
& cWorld . lWorld . pathGraph .~ path
& cWorld . lWorld . pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
& cWorld . lWorld . peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
& pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
& peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
where
(_, path) = pairsToGraph pairPath'
pairPath = foldMap _rmPath rs
@@ -54,14 +54,14 @@ generateLevelFromRoomList gr' w =
rs = map doRoomShift $ IM.elems rs'
rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
fromEdgeTuple :: (Int,Int,PathEdge) -> PathEdgeNodes
fromEdgeTuple (a,b,pe) = PathEdgeNodes a b pe
fromEdgeTuple :: (Int, Int, PathEdge) -> PathEdgeNodes
fromEdgeTuple (a, b, pe) = PathEdgeNodes a b pe
randomCompass :: World -> World
randomCompass w = w & cWorld . camPos . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
putFloorTiles :: GenWorld -> GenWorld
putFloorTiles gw = gw & gwWorld . cWorld . lWorld . floorTiles .~ floorsFromGenWorld gw
putFloorTiles gw = gw & gwWorld . cWorld . floorTiles .~ floorsFromGenWorld gw
setFloors :: GenWorld -> GenWorld
setFloors = putFloorTiles . setTiles
@@ -139,7 +139,7 @@ setupWorldBounds w =
)
where
f = fromMaybe 0
ps = IM.map (fst . _wlLine) $ w ^. cWorld . lWorld . walls-- _walls (_cWorld w)
ps = IM.map (fst . _wlLine) $ w ^. cWorld . lWorld . walls -- _walls (_cWorld w)
(minx, maxx, miny, maxy) =
L.fold
( (,,,)
@@ -150,16 +150,6 @@ setupWorldBounds w =
)
ps
--polyhedrasToEdges :: [Polyhedra] -> [Point3]
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
initWallZoning :: World -> World
initWallZoning w = foldl' (flip insertWallInZones) (w & cWorld . lWorld . wlZoning .~ IM.empty)
(w ^. cWorld . lWorld . walls)
--makePath :: Tree Room -> [(Point2,Point2)]
--makePath = concatMap _rmPath . flatten
wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms =
-- divideWalls .
+1 -1
View File
@@ -49,7 +49,7 @@ walkableNodeNear :: World -> Point2 -> Maybe Int
{-# INLINE walkableNodeNear #-}
walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
where
nodesNear = zonesExtract (w ^. cWorld . lWorld . pnZoning) $ zonesAroundPoint pnZoneSize p
nodesNear = zonesExtract (w ^. pnZoning) $ zonesAroundPoint pnZoneSize p
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
--makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph (_cWorld w)) <$> makePathBetween a b w
+1 -1
View File
@@ -63,7 +63,7 @@ doDrawing pdata u = do
(shadVBOptr $ _textureArrayShader pdata)
wallPointsCol
windowPoints
(w ^. cWorld . lWorld . floorTiles)
(w ^. cWorld . floorTiles)
)
( pokeShape
(_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
+1 -1
View File
@@ -25,7 +25,7 @@ wallsToDraw w =
<*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
<*> L.premap getWallSPic L.mconcat
)
(wlsFromIXs w $ zonesExtract (w ^. cWorld . lWorld . wlZoning) $ zoneOfSight wlZoneSize cam)
(wlsFromIXs w $ zonesExtract (w ^. wlZoning) $ zoneOfSight wlZoneSize cam)
cam = w ^. cWorld . camPos
--wallsToDraw
+13 -1
View File
@@ -8,6 +8,10 @@ module Dodge.Save (
reloadLevelStart,
) where
import Data.Graph.Inductive (labEdges, labNodes)
import Dodge.Zoning.Pathing
import Data.Foldable
import Dodge.Wall.Zone
import Dodge.Concurrent
import Control.Lens
import Dodge.Data.SaveSlot
@@ -32,7 +36,6 @@ writeSaveSlot ss u = do
(u ^. uvWorld . cWorld)
return Just
readSaveSlot :: SaveSlot -> IO (Universe -> Maybe Universe)
readSaveSlot ss = do
fExists <- doesFileExist $ saveSlotPath ss
@@ -42,11 +45,20 @@ readSaveSlot ss = do
case cwstr of
Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return removescreenlayers
Just cw -> return $ \uv -> Just $ uv & uvWorld . cWorld .~ cw
& uvWorld %~ initWallZoning
& uvWorld . pnZoning .~ foldl' (flip zonePn) mempty
(labNodes $ path uv)
& uvWorld . peZoning .~ foldl' (flip zonePe) mempty
(map fromEdgeTuple $ labEdges $ path uv)
& uvScreenLayers .~ []
else putStrLn "loadSaveSlot failed to find saved file" >> return removescreenlayers
where
path uv = uv ^. uvWorld . cWorld . lWorld . pathGraph
removescreenlayers = Just . (uvScreenLayers .~ [])
fromEdgeTuple :: (Int, Int, PathEdge) -> PathEdgeNodes
fromEdgeTuple (a, b, pe) = PathEdgeNodes a b pe
saveSlotPath :: SaveSlot -> String
saveSlotPath (SaveSlotNum i) = "saveSlot/" ++ show i
saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
+4 -8
View File
@@ -202,7 +202,6 @@ functionalUpdate w =
. over uvWorld ppEvents
. colCrsWalls
. over uvWorld simpleCrSprings
. over uvWorld zoneCreatures
. over uvWorld (updateIMl (_doors . _lWorld . _cWorld) (doDrWdWd . _drMech))
. over uvWorld doWorldEvents
. over uvWorld updateDelayedEvents
@@ -226,7 +225,6 @@ functionalUpdate w =
. over uvWorld updateLightSources
. over uvWorld updateClouds
. over uvWorld updateGusts
. over uvWorld zoneClouds
. over uvWorld (updateMIM (cWorld . lWorld . magnets) (doMagnetUpdate . _mgUpdate))
. over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) tmUpdate)
-- . updateIMl _machines mcChooseUpdate
@@ -241,6 +239,8 @@ functionalUpdate w =
. over uvWorld updateRBList
. over uvWorld updateCloseObjects
. over uvWorld updateWheelEvents
. over uvWorld zoneClouds
. over uvWorld zoneCreatures
-- . over uvWorld updateInventorySelectionList
$ over (uvWorld . cWorld) updatePastWorlds w
@@ -278,11 +278,7 @@ updateLasers w =
(w', ls) = mapAccumR updateLaser w (w ^. cWorld . lWorld . lasers)
zoneClouds :: World -> World
zoneClouds w =
w
& cWorld . lWorld . clZoning .~ mempty
& cWorld . lWorld . clZoning %~ \zn ->
foldl' (flip zoneCloud) zn (w ^. cWorld . lWorld . clouds)
zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds)
updateWorldSelect' :: World -> World
updateWorldSelect' w = over input (updateWorldSelect (w ^. cWorld . camPos)) w
@@ -358,7 +354,7 @@ setOldPos cr =
-- Nothing' -> w & timeFlow .~ NormalTimeFlow
zoneCreatures :: World -> World
zoneCreatures w = w & cWorld . lWorld . crZoning
zoneCreatures w = w & crZoning
.~ foldl' (flip zoneCreature) mempty (w ^. cWorld . lWorld . creatures)
-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
+14 -10
View File
@@ -1,21 +1,25 @@
module Dodge.Wall.Zone where
module Dodge.Wall.Zone
( initWallZoning
, insertWallInZones
, deleteWallFromZones
) where
import Data.Foldable
import Control.Lens
import Dodge.Data.World
import Dodge.Zoning.Wall
initWallZoning :: World -> World
initWallZoning w = foldl'
(flip insertWallInZones)
(w & wlZoning .~ mempty)
(w ^. cWorld . lWorld . walls)
-- need to verify that this not only inserts but also overwrites (updates) any
-- already existing walls
insertWallInZones :: Wall -> World -> World
insertWallInZones wl = cWorld . lWorld . wlZoning %~ zoneWall wl
--insertWallInZones wl = wlZoning %~ updateZoning (IM.insert (_wlID wl)) wl
--insertWallInZones wl = wlZoning .updatets
-- %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
-- where
-- doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
insertWallInZones = over wlZoning . zoneWall
deleteWallFromZones :: Wall -> World -> World
deleteWallFromZones wl = cWorld . lWorld . wlZoning %~ deZoneWall wl
deleteWallFromZones = over wlZoning . deZoneWall
-- %~ flip (foldl' (flip $ \(a,b) updateeIMInZone a b (_wlID wl))) (zoneOfWall wl)
+3 -4
View File
@@ -7,14 +7,13 @@ import qualified IntMapHelp as IM
import Dodge.Zoning.Common
clsNearPoint :: Point2 -> World -> [Cloud]
--clsNearPoint p w = zoneExtract (zoneOfPoint clZoneSize p) (w ^. cWorld . lWorld . clZoning)
clsNearPoint = nearPoint clZoneSize _clZoning
clsNearPoint = nearPoint' clZoneSize _clZoning
clsNearSeg :: Point2 -> Point2 -> World -> [Cloud]
clsNearSeg = nearSeg clZoneSize _clZoning
clsNearSeg = nearSeg' clZoneSize _clZoning
clsNearRect :: Point2 -> Point2 -> World -> [Cloud]
clsNearRect = nearRect clZoneSize _clZoning
clsNearRect = nearRect' clZoneSize _clZoning
clsNearCirc :: Point2 -> Float -> World -> [Cloud]
clsNearCirc p r = clsNearRect (p +.+ V2 r r) (p -.- V2 r r)
+12
View File
@@ -10,10 +10,22 @@ nearPoint :: Monoid m => Float -> (LWorld -> IM.IntMap (IM.IntMap m)) -> Point2
{-# INLINE nearPoint #-}
nearPoint size f p w = zoneExtract (zoneOfPoint size p) (f $ w ^. cWorld . lWorld)
nearPoint' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> World -> m
{-# INLINE nearPoint' #-}
nearPoint' size f p w = zoneExtract (zoneOfPoint size p) (f w)
nearSeg :: Monoid m => Float -> (LWorld -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearSeg #-}
nearSeg size f sp ep w = zonesExtract (f $ w ^. cWorld . lWorld) (zoneOfSeg size sp ep)
nearSeg' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearSeg' #-}
nearSeg' size f sp ep w = zonesExtract (f w) (zoneOfSeg size sp ep)
nearRect :: Monoid m => Float -> (LWorld -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearRect #-}
nearRect size f sp ep w = zonesExtract (f $ w ^. cWorld . lWorld) (zoneOfRect size sp ep)
nearRect' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearRect' #-}
nearRect' size f sp ep w = zonesExtract (f w) (zoneOfRect size sp ep)
+3 -3
View File
@@ -12,7 +12,7 @@ import Dodge.Zoning.Common
crIXsNearPoint :: Point2 -> World -> IS.IntSet
--crIXsNearPoint p w = zoneExtract (zoneOfPoint crZoneSize p) (w ^. cWorld . lWorld . crZoning)
crIXsNearPoint = nearPoint crZoneSize _crZoning
crIXsNearPoint = nearPoint' crZoneSize _crZoning
crsNearPoint :: Point2 -> World -> [Creature]
crsNearPoint p w = mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid) . IS.toList $ crIXsNearPoint p w
@@ -24,7 +24,7 @@ crsNearSeg sp ep w =
$ crixsNearSeg sp ep w
crixsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
crixsNearSeg = nearSeg crZoneSize _crZoning
crixsNearSeg = nearSeg' crZoneSize _crZoning
--crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . lWorld . crZoning) (zoneOfSeg crZoneSize sp ep)
crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
@@ -34,7 +34,7 @@ crsNearCirc :: Point2 -> Float -> World -> [Creature]
crsNearCirc p r w = mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid) . IS.toList $ crIXsNearCirc p r w
crsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
crsNearRect = nearRect crZoneSize _crZoning
crsNearRect = nearRect' crZoneSize _crZoning
crZoneSize :: Float
crZoneSize = 15
+6 -6
View File
@@ -10,13 +10,13 @@ import qualified Data.Set as Set
import Dodge.Zoning.Common
pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
pnsNearPoint = nearPoint pnZoneSize _pnZoning
pnsNearPoint = nearPoint' pnZoneSize _pnZoning
pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearSeg = nearSeg pnZoneSize _pnZoning
pnsNearSeg = nearSeg' pnZoneSize _pnZoning
pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearRect = nearRect pnZoneSize _pnZoning
pnsNearRect = nearRect' pnZoneSize _pnZoning
pnsNearCirc :: Point2 -> Float -> World -> [(Int, Point2)]
pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
@@ -31,14 +31,14 @@ zonePn :: (Int, Point2) -> IM.IntMap (IM.IntMap [(Int, Point2)]) -> IM.IntMap (I
zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
pesNearPoint :: Point2 -> World -> Set PathEdgeNodes
pesNearPoint = nearPoint peZoneSize _peZoning
pesNearPoint = nearPoint' peZoneSize _peZoning
--pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . lWorld . peZoning)
pesNearSeg :: Point2 -> Point2 -> World -> Set PathEdgeNodes
pesNearSeg = nearSeg peZoneSize _peZoning
pesNearSeg = nearSeg' peZoneSize _peZoning
pesNearRect :: Point2 -> Point2 -> World -> Set PathEdgeNodes
pesNearRect = nearRect peZoneSize _peZoning
pesNearRect = nearRect' peZoneSize _peZoning
pesNearCirc :: Point2 -> Float -> World -> Set PathEdgeNodes
pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
+13 -4
View File
@@ -1,4 +1,13 @@
module Dodge.Zoning.Wall where
module Dodge.Zoning.Wall
( wlsNearSeg
, wlsNearPoint
, wlsNearRect
, wlsNearCirc
, wlsFromIXs
, wlZoneSize
, zoneWall
, deZoneWall
) where
import Control.Lens
import qualified Data.IntSet as IS
@@ -11,14 +20,14 @@ import qualified IntMapHelp as IM
import Dodge.Zoning.Common
wlIXsNearPoint :: Point2 -> World -> IS.IntSet
wlIXsNearPoint = nearPoint wlZoneSize _wlZoning
wlIXsNearPoint = nearPoint' wlZoneSize _wlZoning
wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
{-# INLINE wlIXsNearSeg #-}
wlIXsNearSeg = nearSeg wlZoneSize _wlZoning
wlIXsNearSeg = nearSeg' wlZoneSize _wlZoning
wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
wlIXsNearRect = nearRect wlZoneSize _wlZoning
wlIXsNearRect = nearRect' wlZoneSize _wlZoning
wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)