diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 9174f073f..945487632 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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 diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index d3ee74a9b..25342ea7f 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 8b3ca553c..019ab9538 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -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 diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 435088584..9d30e664d 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -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' diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 1c1848bf2..fdde9cc1a 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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 diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index b37171771..aa1130ab3 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -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