From 8dc7682327b882e5f69ecc998a7c8e8796787811 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 2 Jul 2022 11:59:05 +0100 Subject: [PATCH] Readd some debug drawing (debugDraw itself still commented out) --- src/Dodge/Data.hs | 2 +- src/Dodge/Default/World.hs | 2 +- src/Dodge/Layout.hs | 6 ++++ src/Dodge/Path.hs | 7 +++- src/Dodge/Render/ShapePicture.hs | 60 ++++++++++++++++++++------------ 5 files changed, 52 insertions(+), 25 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 5505dedd1..fe195d2b3 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -150,7 +150,7 @@ data World = World , _clickMousePos :: Point2 , _pathGraph :: Gr Point2 PathEdge , _pathGraphP :: S.Set (Point2,Point2) - , _phZoning :: Zoning [] (Int,Point2) + , _pnZoning :: Zoning [] (Int,Point2) , _hud :: HUD , _lightSources :: IM.IntMap LightSource , _tempLightSources :: [TempLightSource] diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 53746c236..8370650d2 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -76,7 +76,7 @@ defaultWorld = World , _clickMousePos = V2 0 0 , _pathGraph = Data.Graph.Inductive.Graph.empty , _pathGraphP = mempty - , _phZoning = Zoning mempty wlZoneSize (zonePos snd) + , _pnZoning = Zoning mempty wlZoneSize (zonePos snd) , _hud = HUD { _hudElement = DisplayInventory NoSubInventory , _carteCenter = V2 0 0 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 3c49ee669..b5c3bb45b 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -5,6 +5,7 @@ module Dodge.Layout import Data.Tile import Dodge.Data import Dodge.Path +import Dodge.Zone.Update import Dodge.ShiftPoint import Dodge.Placement.PlaceSpot --import Dodge.LevelGen.Data @@ -21,6 +22,7 @@ import qualified IntMapHelp as IM import Tile import RandomHelp +import Data.Graph.Inductive (labNodes,labEdges) import Data.List (nubBy) import Data.Traversable import Control.Lens @@ -44,6 +46,10 @@ generateLevelFromRoomList gr' w = initWallZoning , _pathGraph = path , _pathGraphP = pairPath } + & pnZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) + (labNodes path)) +-- & peZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) +-- (labEdges (_pgGraph path))) where path = pairsToGraph pairPath pairPath = foldMap _rmPath rs diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 315d6d09d..ceceb5712 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -1,9 +1,11 @@ +--{-# LANGUAGE TupleSections #-} module Dodge.Path ( pointTowardsImpulse , makePathBetween , makePathBetweenPs , removePathsCrossing , pairsToGraph + , getNodePos ) where import Dodge.Data import Dodge.Base.Collide @@ -24,6 +26,9 @@ import qualified Streaming.Prelude as S --import Data.Graph.Inductive.PatriciaTree --import Data.Graph.Inductive.Graph hiding ((&)) +getNodePos :: Int -> World -> Maybe Point2 +getNodePos i w = _pathGraph w `lab` i + makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) na <- walkableNodeNear a @@ -31,7 +36,7 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) sp na nb (second _peDist (_pathGraph w)) where --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w) - nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w + nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p --walkableNodeNear :: Point2 -> World -> Maybe Point2 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 0bbc205b5..53bc6574e 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -120,9 +120,25 @@ drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) drawPathBetween :: World -> Picture -drawPathBetween _ = mempty +drawPathBetween w = setLayer DebugLayer + $ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist) + <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0) + <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just) + where + nodepos = (`getNodePos` w) + nodelist = makePathBetween sp ep w + sp = _lSelect w + ep = _rSelect w + drawNodesNearSelect :: World -> Picture -drawNodesNearSelect _ = mempty +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) + where + sp = _lSelect w + drawInspectWalls :: World -> Picture drawInspectWalls w = foldMap (drawInspectWall w) $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) @@ -259,28 +275,28 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w) where p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl) ---edgeToPic :: [Point2] -> PathEdge -> Picture ---edgeToPic poly pe --- | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty --- | null $ _peObstacles pe --- = anarrow green --- | hasobstacle BlockObstacle --- = anarrow red --- | hasobstacle AutoDoorObstacle = anarrow yellow --- | otherwise = anarrow cyan --- where --- hasobstacle = (`Set.member` _peObstacles pe) --- anarrow col = color col $ arrow sp ep --- sp = _peStart pe --- ep = _peEnd pe +edgeToPic :: [Point2] -> PathEdge -> Picture +edgeToPic poly pe + | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty + | null $ _peObstacles pe + = anarrow green + | hasobstacle BlockObstacle + = anarrow red + | hasobstacle AutoDoorObstacle = anarrow yellow + | otherwise = anarrow cyan + where + hasobstacle = (`Set.member` _peObstacles pe) + anarrow col = color col $ arrow sp ep + sp = _peStart pe + ep = _peEnd pe drawPathing :: Configuration -> World -> Picture -drawPathing cfig w = setLayer DebugLayer mempty --- $ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) --- <> concatMap dispInc (graphToIncidence gr) --- where --- dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n --- gr = _pathGraph w +drawPathing cfig w = setLayer DebugLayer + $ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) + <> concatMap dispInc (graphToIncidence gr) + where + dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n + gr = _pathGraph w crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String]) crDisplayInfo cfig w cr