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

Commit before complicating zoning

Browse Source
This commit is contained in:
justin
2022-06-28 14:35:49 +01:00
parent 9801a40b9e
commit 4965934502
6 changed files with 57 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
-10
View File
@@ -62,16 +62,6 @@ wedgeGeom t x y
where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
insertInZoneWith
:: Int -- ^ First Key
-> Int -- ^ Second Key
-> (a -> a -> a) -- ^ Combining function
-> a -- ^ Value to insert
-> IM.IntMap (IM.IntMap a)
-> IM.IntMap (IM.IntMap a)
insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj
where
f _ = IM.insertWith fun y obj
{- | I believe this overwrites the value if it already exists, but not sure. -}
insertIMInZone
:: Int -- ^ First key
src/Dodge/Data.hs
+8 -7
View File
@@ -7,6 +7,7 @@ circular imports are probably not a good idea.
{-# LANGUAGE StrictData #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
module Dodge.Data
( module Dodge.Data
, module Dodge.Data.Material
@@ -103,13 +104,13 @@ data World = World
, _boundBox :: [Point2]
, _boundDist :: (Float,Float,Float,Float) -- NSEW, S and W negative
, _creatures :: IM.IntMap Creature
, _creaturesZone :: Zone (IM.IntMap Creature)
, _creaturesZone :: Zoning (IM.IntMap Creature)
, _creatureGroups :: IM.IntMap CrGroupParams
, _itemPositions :: IM.IntMap ItemPos
, _clouds :: [Cloud]
, _cloudsZone :: Zone [Cloud]
, _cloudsZone :: Zoning [Cloud]
, _gusts :: IM.IntMap Gust
, _gustsZone :: Zone (IM.IntMap Gust)
, _gustsZone :: Zoning (IM.IntMap Gust)
, _props :: IM.IntMap Prop
, _instantParticles :: [Particle]
, _particles :: [Particle]
@@ -124,7 +125,7 @@ data World = World
, _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2
, _triggers :: IM.IntMap (World -> Bool)
, _wallsZone :: Zone (IM.IntMap Wall)
, _wallsZone :: Zoning (IM.IntMap Wall)
, _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)]
, _randGen :: StdGen
@@ -144,7 +145,7 @@ data World = World
, _clickMousePos :: Point2
, _pathGraph :: Gr Point2 Float
, _pathGraphP :: S.Set (Point2,Point2)
, _pathPoints :: IM.IntMap (IM.IntMap [(Int,Point2)])
, _pathPoints :: Zoning [(Int,Point2)]
, _hud :: HUD
, _lightSources :: IM.IntMap LightSource
, _tempLightSources :: [TempLightSource]
@@ -1326,7 +1327,7 @@ data Goal
| SentinelAt Point2 Float
deriving (Show)
newtype Zone a = Zone
newtype Zoning a = Zoning
{ _znObjects :: IM.IntMap (IM.IntMap a)
}
data DamageEffect
@@ -1514,7 +1515,7 @@ makeLenses ''Block
makeLenses ''Terminal
makeLenses ''Machine
makeLenses ''MachineType
makeLenses ''Zone
makeLenses ''Zoning
makeLenses ''ItemDimension
makeLenses ''Vocalization
makeLenses ''Universe
src/Dodge/Default/World.hs
+5 -5
View File
@@ -30,12 +30,12 @@ defaultWorld = World
, _viewDistance = 1000
, _modifications = IM.empty
, _creatures = IM.empty
, _creaturesZone = Zone IM.empty
, _creaturesZone = Zoning IM.empty
, _creatureGroups = IM.empty
, _clouds = []
, _cloudsZone = Zone IM.empty
, _cloudsZone = Zoning IM.empty
, _gusts = IM.empty
, _gustsZone = Zone IM.empty
, _gustsZone = Zoning IM.empty
, _itemPositions = IM.empty
, _props = IM.empty
, _instantParticles = []
@@ -50,7 +50,7 @@ defaultWorld = World
, _doors = IM.empty
, _coordinates = IM.empty
, _triggers = IM.empty
, _wallsZone = Zone IM.empty
, _wallsZone = Zoning IM.empty
, _floorItems = IM.empty
, _floorTiles = []
, _randGen = mkStdGen 2
@@ -71,7 +71,7 @@ defaultWorld = World
, _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraphP = mempty
, _pathPoints = IM.empty
, _pathPoints = Zoning IM.empty
, _hud = HUD
{ _hudElement = DisplayInventory NoSubInventory
, _carteCenter = V2 0 0
src/Dodge/Path.hs
+16 -11
View File
@@ -9,15 +9,15 @@ import Dodge.Data
import Dodge.Base.Collide
import Dodge.Zone
import Geometry.Data
import Dodge.Base
import Geometry
import Control.Lens
import Data.Maybe
import Data.List
import qualified Data.IntMap.Strict as IM
--import qualified Data.IntMap.Strict as IM
import Data.Graph.Inductive hiding ((&))
import qualified Data.Set as S
import qualified Data.Set as Set
import qualified Streaming.Prelude as S
--import Data.Graph.Inductive.PatriciaTree
--import Data.Graph.Inductive.Graph hiding ((&))
@@ -27,9 +27,13 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
nb <- walkableNodeNear b
sp na nb (_pathGraph w)
where
nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
--nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
nodesNear p = runIdentity . S.toList_ $ nearPoint wlZoneSize _pathPoints p w
walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
--walkableNodeNear :: Point2 -> World -> Maybe Point2
--walkableNodeNear p w = insideCirc
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
@@ -79,18 +83,19 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
-- [] -> return Nothing
-- _ -> return $ Just $ ns !! i
--
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> S.Set (a,a) -> Gr a b
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
pairsToGraph f pairs =
let nodes' = S.map fst pairs `S.union` S.map snd pairs
pairs' = S.map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (S.toList nodes') >> insMapEdgesM (S.toList pairs')
let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = w
& pathGraph .~ newGraph
& pathGraphP .~ pg'
& pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
& pathPoints .~ foldl' insertpoint (Zoning mempty) (labNodes newGraph)
where
pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
insertPoint pp@(_,p) = uncurryV insertInZoneWith (wlZoneOfPoint p) (++) [pp]
pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
insertpoint zn (i,p) = insertInZoneWith (wlZoneOfPoint p) (++) [(i,p)] zn
-- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
newGraph = pairsToGraph dist pg'
src/Dodge/Update.hs
+3 -5
View File
@@ -95,15 +95,13 @@ functionalUpdate cfig w = checkEndGame
. updateRBList
. updateBounds cfig -- where should this go? next to update camera?
$ updateCloseObjects w
where
--updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
zoneClouds :: World -> World
zoneClouds w = w & set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
zoneClouds w = w & set cloudsZone (foldl' (flip cloudInZone) (Zoning mempty) (_clouds w))
where
cloudInZone cl = insertInZoneWith x y (++) [cl]
cloudInZone cl = insertInZoneWith p (++) [cl]
where
V2 x y = clZoneOfPoint $ stripZ $ _clPos cl
p = clZoneOfPoint $ stripZ $ _clPos cl
updateWorldSelect :: World -> World
updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
src/Dodge/Zone.hs
+25 -10
View File
@@ -1,9 +1,11 @@
module Dodge.Zone
( zoneOfSeg
( insertInZoneWith
, zoneOfSeg
, zoneOfCreature
, zoneOfWall
, zoneOfSight
, zoneAroundPoint
, nearPoint
, wlsNearPoint
, crsNearPoint
, clsNearPoint
@@ -31,6 +33,22 @@ import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
extractFromZone :: Zoning a -> Int2 -> Maybe a
extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
streamFromZone :: Foldable t => Zoning (t a) -> StreamOf Int2 -> StreamOf a
streamFromZone zn = S.concat . S.mapMaybe (extractFromZone zn)
insertInZoneWith
:: Int2
-> (a -> a -> a) -- ^ Combining function
-> a -- ^ Value to insert
-> Zoning a
-> Zoning a
insertInZoneWith (V2 x y) fun obj = over znObjects $ IM.insertWith f x $ IM.singleton y obj
where
f _ = IM.insertWith fun y obj
zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2
zoneOfSeg = ddaStream
@@ -78,11 +96,10 @@ lookLookup i j z = case IM.lookup i z of
lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
extractFromZone :: Zone a -> Int2 -> Maybe a
extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
nearPoint :: (Foldable t,Monoid (t a))
=> Float -> (World -> Zone (t a)) -> Point2 -> World -> StreamOf a
=> Float -> (World -> Zoning (t a)) -> Point2 -> World -> StreamOf a
{-# INLINE nearPoint #-}
nearPoint s f p w = S.each . fromMaybe mempty $ extractFromZone (f w) (zoneOfPoint s p)
clsNearPoint :: Point2 -> World -> StreamOf Cloud
@@ -94,9 +111,8 @@ wlsNearPoint = nearPoint wlZoneSize _wallsZone
crsNearPoint :: Point2 -> World -> StreamOf Creature
crsNearPoint = nearPoint crZoneSize _creaturesZone
nearSeg :: Foldable t => Float -> (World -> Zone (t a)) -> Point2 -> Point2 -> World -> StreamOf a
nearSeg s f p r w = S.concat $ S.mapMaybe (extractFromZone (f w))
$ zoneOfSeg s p r
nearSeg :: Foldable t => Float -> (World -> Zoning (t a)) -> Point2 -> Point2 -> World -> StreamOf a
nearSeg s f p r w = streamFromZone (f w) $ zoneOfSeg s p r
wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
wlsNearSeg = nearSeg wlZoneSize _wallsZone
@@ -104,9 +120,8 @@ wlsNearSeg = nearSeg wlZoneSize _wallsZone
crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
crsNearSeg = nearSeg crZoneSize _creaturesZone
insideCirc :: Foldable t => Float -> (World -> Zone (t a)) -> Point2 -> Float -> World -> StreamOf a
insideCirc s f p r w = S.concat $ S.mapMaybe (extractFromZone (f w))
$ zoneInsideCirc s p r
insideCirc :: Foldable t => Float -> (World -> Zoning (t a)) -> Point2 -> Float -> World -> StreamOf a
insideCirc s f p r w = streamFromZone (f w) $ zoneInsideCirc s p r
wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
wlsInsideCirc = insideCirc wlZoneSize _wallsZone