diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 9bf40d033..a3f216a0a 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -45,6 +45,7 @@ data DebugBool | Show_select | Inspect_wall | Show_nodes_near_select + | Show_path_between deriving (Generic, Eq,Ord,Bounded, Enum, Show) data ResFactor = FullRes | HalfRes | QuarterRes deriving (Generic, Show, Eq, Ord, Enum, Bounded) diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs index 338fdba5c..913282282 100644 --- a/src/Dodge/Data/PathGraph.hs +++ b/src/Dodge/Data/PathGraph.hs @@ -22,6 +22,7 @@ data EdgeObstacle = BlockObstacle | DoorObstacle | AutoDoorObstacle + | WallObstacle deriving (Eq,Ord,Show,Bounded,Enum) makeLenses ''PathGraph diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 3a19d2ffa..f86379694 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -19,7 +19,7 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import qualified Data.Set as S import Data.Graph.Inductive.Graph hiding ((&)) -import Data.Graph.Inductive.NodeMap +--import Data.Graph.Inductive.NodeMap --import qualified Data.Vector.Fusion.Stream.Monadic as VS defaultWorld :: World defaultWorld = World diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 4e7b2a4af..da97ea03e 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -3,7 +3,6 @@ module Dodge.Path ( pointTowardsImpulse , makePathBetween , makePathBetweenPs - , removePathsCrossing , pairsToGraph , pairsToGraph'' , walkableNodeNear @@ -38,7 +37,9 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) (na,_) <- walkableNodeNear a w (nb,_) <- walkableNodeNear b w - sp na nb (second pathDist $ _pgGraph $ _pathGraph w) + sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w) + where + noobstacle (_,_,PathEdge _ _ s) = null s pathDist :: PathEdge -> Float pathDist pe = dist (_peStart pe) (_peEnd pe) @@ -170,33 +171,6 @@ addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2 -> World -> World addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b - where - paths = S.filter f $ nearSeg _peZoning a b w - f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b - -removePathsCrossing :: Point2 -> Point2 -> World -> World -removePathsCrossing a b w = w --- & pathGraph . pgGraph %~ deleteEdges --- & pathGraphP %~ deletePairs --- & pathGraph .~ newGraph --- & pathGraphP .~ pg' --- & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) --- (labNodes newGraph) - where - thegr = _pgGraph (_pathGraph w) - ns = nearSeg _pnZoning a b w - pairs = S.filter testEdge $ S.for ns (nodePairs thegr) - testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q - deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs - deleteEdge gr ((x,_),(y,_)) = delEdge (x,y) $ delEdge (y,x) gr --- deletePairs s = runIdentity $ S.fold_ deletePair s id pairs --- deletePair s (x,y) = Set.delete (x,y) $ Set.delete (y,x) s - -nodePairs :: Gr a b -> (Int,a) -> StreamOf ((Int,a),(Int,a)) -nodePairs gr (n,p) = S.mapMaybe (fmap ((n,p),) . nodeLabel gr) . S.each $ neighbors gr n - -nodeLabel :: Gr a b -> Int -> Maybe (Int, a) -nodeLabel gr n = (n,) <$> lab gr n -- pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w -- -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp] diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index e53035621..9ad5bb90a 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -123,7 +123,7 @@ placeWallPoly :: [Point2] -> Wall -> World -> World --placeWallPoly ps wl = over walls (placeWalls ps wl) placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl) where - rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps + rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) w $ loopPairs ps placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall placeWalls qs wl wls = foldl' (addPane wl) wls pairs diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 927dbe0d4..c44d8081e 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -71,8 +71,8 @@ placeLineBlock -> World -> (Int, World) placeLineBlock basePane blockWidth depth a b gw = ( 0 - , (foldr insertWall (insertBlocks gw) listWalls) --- , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls) +-- , (foldr insertWall (insertBlocks gw) listWalls) + , addObstacleCrossing' BlockObstacle a b (foldr insertWall (insertBlocks gw) listWalls) ) where psOnLine = divideLineOddNumPoints blockWidth a b diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 82e23718b..580985db0 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -30,7 +30,7 @@ import Geometry.ConvexPoly --import Data.Foldable import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M -import qualified Data.Set as Set +--import qualified Data.Set as Set import Control.Lens import Data.Maybe import qualified Streaming.Prelude as S @@ -113,21 +113,26 @@ debugDraw' cfig w bl = case bl of Walls_info -> Right $ drawWlIDs cfig w Pathing -> Right $ drawPathing cfig w Show_nodes_near_select -> Right $ drawNodesNearSelect w + Show_path_between -> Right $ drawPathBetween w drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) +drawPathBetween :: World -> Picture +drawPathBetween w = color yellow + $ foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w) + where + sp = _lSelect w + ep = _rSelect w + drawNodesNearSelect :: World -> Picture drawNodesNearSelect w = setLayer DebugLayer $ runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp)) <> color red (foldMap (drawCross . snd) $ nodesNearL sp w) <> color green (drawCross sp) <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w) - <> color yellow (foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w)) where sp = _lSelect w - ep = _rSelect w - drawInspectWalls :: World -> Picture drawInspectWalls w = foldMap (drawInspectWall w)