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

Make pathedge zoning use sets, probably doesn't help

Browse Source
This commit is contained in:
justin
2022-08-24 14:01:39 +01:00
parent 13b07b53ce
commit 6973663055
16 changed files with 68 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block.hs
+2 -1
View File
@@ -1,5 +1,6 @@
module Dodge.Block where
import Data.Set (Set)
import Dodge.Data.MountedObject
import Control.Lens
import Data.Foldable
@@ -64,7 +65,7 @@ destroyBlock bl w =
ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
-- this does not handle eg doors blocking the path as well
maybeClearPaths :: [(Int, Int, PathEdge)] -> World -> World
maybeClearPaths :: Set (Int, Int, PathEdge) -> World -> World
maybeClearPaths ps w = foldl' maybeClearPath w ps
maybeClearPath :: World -> (Int, Int, PathEdge) -> World
src/Dodge/Data/Block.hs
+2 -1
View File
@@ -9,6 +9,7 @@ module Dodge.Data.Block (
module Dodge.Data.PathGraph,
) where
import Data.Set (Set)
import Color
import Control.Lens
import Data.Aeson
@@ -30,7 +31,7 @@ data Block = Block
, _blHeight :: Float
, _blMaterial :: Material
, _blDraw :: BlockDraw --Block -> SPic
, _blObstructs :: [(Int, Int, PathEdge)]
, _blObstructs :: Set (Int, Int, PathEdge)
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/CWorld.hs
+3 -1
View File
@@ -48,6 +48,7 @@ module Dodge.Data.CWorld (
module Dodge.Data.WorldEffect,
) where
import Data.Set (Set)
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -176,7 +177,8 @@ data CWorld = CWorld
, _corpses :: IM.IntMap Corpse
, _pathGraph :: Gr Point2 PathEdge
, _pnZoning :: IM.IntMap (IM.IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
, _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature
--, _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature
, _peZoning :: IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge))) --Zoning IM.IntMap Creature
, _hud :: HUD
, _lightSources :: IM.IntMap LightSource
, _tempLightSources :: [TempLightSource]
src/Dodge/Data/Door.hs
+2 -1
View File
@@ -10,6 +10,7 @@ module Dodge.Data.Door (
module Dodge.Data.WorldEffect,
) where
import Data.Set (Set)
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -45,7 +46,7 @@ data Door = Door
, _drPushedBy :: PushSource
, _drPushes :: Maybe Int
, _drMounts :: [MountedObject]
, _drObstructs :: [(Int, Int, PathEdge)]
, _drObstructs :: Set (Int, Int, PathEdge)
, _drObstacleType :: EdgeObstacle
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/PathGraph.hs
+9
View File
@@ -30,6 +30,13 @@ data PathGraph = PathGraph
}
deriving (Eq, Show, Read) --, Generic)
data PathEdgeNodes = PathEdgeNodes
{ _penStart :: Int
, _penEnd :: Int
, _penPathEdge :: PathEdge
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
data PathEdge = PathEdge
{ _peStart :: Point2
, _peEnd :: Point2
@@ -54,7 +61,9 @@ data EdgeObstacle
makeLenses ''PathGraph
makeLenses ''PathEdge
makeLenses ''PathEdgeNodes
deriveJSON defaultOptions ''EdgeObstacle
deriveJSON defaultOptions ''PathEdge
deriveJSON defaultOptions ''PathEdgeNodes
deriveJSON defaultOptions ''Gr
deriveJSON defaultOptions ''PathGraph
src/Dodge/Default/Block.hs
+1 -1
View File
@@ -14,7 +14,7 @@ defaultBlock = Block
, _blDraw = BlockDrawMempty
, _blHeight = 100
, _blMaterial = Stone
, _blObstructs = []
, _blObstructs = mempty
}
defaultDirtBlock :: Block
defaultDirtBlock = defaultBlock & blHP .~ 50
src/Dodge/Humanoid.hs
-4
View File
@@ -188,11 +188,7 @@ defaultImpulsive ::
World ->
World
defaultImpulsive
--xs cr = id
-- updateRandGen -- . stateUpdate (const id) cr
= fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates
--xs cr = updateRandGen . stateUpdate (const id) cr
--xs cr = stateUpdate (const id) cr
where
updateRandGen w =
let (_, g) = randomR (0, 1 :: Int) (_randGen w)
src/Dodge/Path.hs
+4 -4
View File
@@ -12,6 +12,8 @@ module Dodge.Path (
fusePairs,
) where
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Lens
import Data.Foldable
import Data.Graph.Inductive hiding ((&))
@@ -19,8 +21,6 @@ import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Dodge.Base.Collide
import Dodge.Data.World
import Dodge.Zoning.Base
@@ -131,13 +131,13 @@ addEdges nodemap gr = foldl' f (mempty, gr)
theedge = (g a, g b, PathEdge a b (dist a b) mempty)
g a = nodemap M.! a
obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, [(Int, Int, PathEdge)])
obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, Set (Int, Int, PathEdge))
obstructPathsCrossing obstacletype sp' ep w =
( w & cWorld . pathGraph %~ updateedges
, es
)
where
es = filter edgecrosses $ pesNearSeg sp' ep w
es = Set.filter edgecrosses $ pesNearSeg sp' ep w
edgecrosses (_, _, pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
updateedges gr = foldl' updateedge gr es
updateedge gr (x, y, pe) =
src/Dodge/Placement/PlaceSpot/Block.hs
+5 -3
View File
@@ -4,6 +4,8 @@ module Dodge.Placement.PlaceSpot.Block (
plLineBlock,
) where
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Lens
import qualified Data.IntSet as IS
import Data.List
@@ -85,7 +87,7 @@ plLineBlock basePane blwidth a b gw =
, _blShadows = shadowsAt i
, _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
, _blObstructs = []
, _blObstructs = mempty
, _blMaterial = _wlMaterial basePane
, _blHeight = 100
, _blPos = p
@@ -113,11 +115,11 @@ plLineBlock basePane blwidth a b gw =
-- | Must be done after inserting the block
insertWalls :: Int -> [Wall] -> World -> World
insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ concat paths
insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ Set.unions paths
where
(w', paths) = mapAccumR (flip insertWall) w wls
insertWall :: Wall -> World -> (World, [(Int, Int, PathEdge)])
insertWall :: Wall -> World -> (World, Set (Int, Int, PathEdge))
insertWall wl =
uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
. (cWorld . walls . at (_wlID wl) ?~ wl)
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+3 -2
View File
@@ -4,6 +4,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
maybeClearDoorPaths,
) where
import Data.Set (Set)
import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS
import Data.List
@@ -60,11 +61,11 @@ addDoorWall eo drid wl w (wlid, wlps) =
, _wlID = wlid
, _wlStructure = DoorPart drid
}
& cWorld . doors . ix drid . drObstructs .++~ es
& cWorld . doors . ix drid . drObstructs <>~ es
where
(w', es) = uncurry (obstructPathsCrossing eo) wlps w
maybeClearDoorPaths :: EdgeObstacle -> [(Int, Int, PathEdge)] -> World -> World
maybeClearDoorPaths :: EdgeObstacle -> Set (Int, Int, PathEdge) -> World -> World
maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
maybeClearDoorPath :: EdgeObstacle -> World -> (Int, Int, PathEdge) -> World
src/Dodge/Render/ShapePicture.hs
+4 -4
View File
@@ -188,9 +188,9 @@ drawCollisionTest cfig w =
<> foldMap (drawCross . fst) (crHit a b w)
<> foldMap (drawCross . _crPos) (crsNearSeg a b w)
-- <> foldMap (drawZoneCol green crZoneSize) (zoneOfSeg' crZoneSize a b)
<> foldMap (drawZoneCol green crZoneSize . zoneOfPoint' crZoneSize) (xIntercepts' crZoneSize a b)
<> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint' crZoneSize) (yIntercepts' crZoneSize a b)
<> foldMap (drawLabCrossCol cfig w blue) (xIntercepts' crZoneSize a b)
<> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
<> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
<> foldMap (drawLabCrossCol cfig w blue) (xIntercepts crZoneSize a b)
where
(a, b) = _lrLine w
@@ -290,7 +290,7 @@ drawDDATest w =
cvf = w ^. cWorld . cwCam . cwcViewFrom
mwp = mouseWorldPos w
--ps = ddaStreamX 50 cvf mwp
ps = zoneOfSeg' 50 cvf mwp
ps = zoneOfSeg 50 cvf mwp
--ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
--qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
src/Dodge/Zoning/Base.hs
+13 -13
View File
@@ -13,8 +13,8 @@ zoneOfCirc zsize p r = zoneOfRect' zsize (p +.+ V2 r r) (p -.- V2 r r)
zoneOfRect' :: Float -> Point2 -> Point2 -> [Int2]
zoneOfRect' s sp ep = [V2 x y | x <- makeIntInterval sx ex, y <- makeIntInterval sy ey]
where
V2 sx sy = zoneOfPoint' s sp
V2 ex ey = zoneOfPoint' s ep
V2 sx sy = zoneOfPoint s sp
V2 ex ey = zoneOfPoint s ep
makeIntInterval :: Int -> Int -> [Int]
makeIntInterval x y
@@ -25,12 +25,12 @@ makeInt2Interval :: Int2 -> Int2 -> [Int2]
makeInt2Interval (V2 x1 y1) (V2 x2 y2) =
[V2 x y | x <- makeIntInterval x1 x2, y <- makeIntInterval y1 y2]
zoneOfPoint' :: Float -> Point2 -> Int2
zoneOfPoint' = fmap . divTo
zoneOfPoint :: Float -> Point2 -> Int2
zoneOfPoint = fmap . divTo
zoneOfSeg' :: Float -> Point2 -> Point2 -> [Int2]
{-# INLINE zoneOfSeg' #-}
zoneOfSeg' s sp ep = map (zoneOfPoint' s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep)
zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
{-# INLINE zoneOfSeg #-}
zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts' s sp ep)
zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
zoneExtract (V2 x y) = fromMaybe mempty . (^? ix x . ix y)
@@ -39,9 +39,9 @@ zonesExtract :: Monoid m => IM.IntMap (IM.IntMap m) -> [Int2] -> m
{-# INLINE zonesExtract #-}
zonesExtract = foldMap . flip zoneExtract
xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
{-# INLINE xIntercepts' #-}
xIntercepts' s (V2 sx sy) (V2 ex ey)
xIntercepts :: Float -> Point2 -> Point2 -> [Point2]
{-# INLINE xIntercepts #-}
xIntercepts s (V2 sx sy) (V2 ex ey)
| xdx == 0 = []
| otherwise = zipWith V2 [halfstep + sx', halfstep + sx' + xdx * s .. ex] ([sy', sy' + ydx * s .. ey] ++ repeat ey)
where
@@ -57,12 +57,12 @@ xIntercepts' s (V2 sx sy) (V2 ex ey)
yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
{-# INLINE yIntercepts' #-}
yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep)
yIntercepts' s sp ep = map f $ xIntercepts s (f sp) (f ep)
where
f (V2 x y) = V2 y x
zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton y a
zoneMonoid (V2 x y) a = IM.insertWith f x $! IM.singleton y a
where
f _ = IM.insertWith (<>) y a
@@ -76,4 +76,4 @@ 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
V2 x y = zoneOfPoint s p
src/Dodge/Zoning/Cloud.hs
+2 -2
View File
@@ -8,10 +8,10 @@ import Geometry
import qualified IntMapHelp as IM
clsNearPoint :: Point2 -> World -> [Cloud]
clsNearPoint p w = zoneExtract (zoneOfPoint' clZoneSize p) (w ^. cWorld . clZoning)
clsNearPoint p w = zoneExtract (zoneOfPoint clZoneSize p) (w ^. cWorld . clZoning)
clsNearSeg :: Point2 -> Point2 -> World -> [Cloud]
clsNearSeg sp ep w = zonesExtract (w ^. cWorld . clZoning) (zoneOfSeg' clZoneSize sp ep)
clsNearSeg sp ep w = zonesExtract (w ^. cWorld . clZoning) (zoneOfSeg clZoneSize sp ep)
clsNearRect :: Point2 -> Point2 -> World -> [Cloud]
clsNearRect sp ep w = zonesExtract (w ^. cWorld . clZoning) $ zoneOfRect' clZoneSize sp ep
src/Dodge/Zoning/Creature.hs
+2 -2
View File
@@ -10,7 +10,7 @@ import Geometry
import qualified IntMapHelp as IM
crIXsNearPoint :: Point2 -> World -> IS.IntSet
crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. cWorld . crZoning)
crIXsNearPoint p w = zoneExtract (zoneOfPoint crZoneSize p) (w ^. cWorld . crZoning)
crsNearPoint :: Point2 -> World -> [Creature]
crsNearPoint p w = mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) . IS.toList $ crIXsNearPoint p w
@@ -22,7 +22,7 @@ crsNearSeg sp ep w =
$ crixsNearSeg sp ep w
crixsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . crZoning) (zoneOfSeg' crZoneSize sp ep)
crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . crZoning) (zoneOfSeg crZoneSize sp ep)
crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
crIXsNearCirc p r = crsNearRect (p +.+ V2 r r) (p -.- V2 r r)
src/Dodge/Zoning/Pathing.hs
+13 -11
View File
@@ -6,12 +6,14 @@ import Dodge.Data.World
import Dodge.Zoning.Base
import Geometry
import qualified IntMapHelp as IM
import Data.Set (Set)
import qualified Data.Set as Set
pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
pnsNearPoint p w = zoneExtract (zoneOfPoint' pnZoneSize p) (w ^. cWorld . pnZoning)
pnsNearPoint p w = zoneExtract (zoneOfPoint pnZoneSize p) (w ^. cWorld . pnZoning)
pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearSeg sp ep w = zonesExtract (w ^. cWorld . pnZoning) (zoneOfSeg' pnZoneSize sp ep)
pnsNearSeg sp ep w = zonesExtract (w ^. cWorld . pnZoning) (zoneOfSeg pnZoneSize sp ep)
pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearRect sp ep w = zonesExtract (w ^. cWorld . pnZoning) $ zoneOfRect' pnZoneSize sp ep
@@ -28,25 +30,25 @@ 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 ^. cWorld . peZoning)
pesNearPoint :: Point2 -> World -> Set (Int, Int, PathEdge)
pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . peZoning)
pesNearSeg :: Point2 -> Point2 -> World -> [(Int, Int, PathEdge)]
pesNearSeg sp ep w = zonesExtract (w ^. cWorld . peZoning) (zoneOfSeg' peZoneSize sp ep)
pesNearSeg :: Point2 -> Point2 -> World -> Set (Int, Int, PathEdge)
pesNearSeg sp ep w = zonesExtract (w ^. cWorld . peZoning) (zoneOfSeg peZoneSize sp ep)
pesNearRect :: Point2 -> Point2 -> World -> [(Int, Int, PathEdge)]
pesNearRect :: Point2 -> Point2 -> World -> Set (Int, Int, PathEdge)
pesNearRect sp ep w = zonesExtract (w ^. cWorld . peZoning) $ zoneOfRect' peZoneSize sp ep
pesNearCirc :: Point2 -> Float -> World -> [(Int, Int, PathEdge)]
pesNearCirc :: Point2 -> Float -> World -> Set (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)
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 :: (Int, Int, PathEdge) -> IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge))) -> IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge)))
zonePe pe im = foldl' f im (zoneOfPe pe)
where
f im' i2 = zoneMonoid i2 [pe] im'
f im' i2 = zoneMonoid i2 (Set.singleton pe) im'
src/Dodge/Zoning/Wall.hs
+3 -3
View File
@@ -10,11 +10,11 @@ import Geometry
import qualified IntMapHelp as IM
wlIXsNearPoint :: Point2 -> World -> IS.IntSet
wlIXsNearPoint p w = zoneExtract (zoneOfPoint' wlZoneSize p) (w ^. cWorld . wlZoning)
wlIXsNearPoint p w = zoneExtract (zoneOfPoint wlZoneSize p) (w ^. cWorld . wlZoning)
wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
{-# INLINE wlIXsNearSeg #-}
wlIXsNearSeg sp ep w = zonesExtract (w ^. cWorld . wlZoning) (zoneOfSeg' wlZoneSize sp ep)
wlIXsNearSeg sp ep w = zonesExtract (w ^. cWorld . wlZoning) (zoneOfSeg wlZoneSize sp ep)
wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
wlIXsNearRect sp ep w = zonesExtract (w ^. cWorld . wlZoning) $ zoneOfRect' wlZoneSize sp ep
@@ -41,7 +41,7 @@ wlZoneSize :: Float
wlZoneSize = 50
zoneOfWl :: Wall -> [Int2]
zoneOfWl = uncurry (zoneOfSeg' wlZoneSize) . _wlLine
zoneOfWl = uncurry (zoneOfSeg wlZoneSize) . _wlLine
--minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature
--minCrIXOn f is w = fmap fst $ IS.foldl' g Nothing is