Add debugging for pathfinding

2022-06-29 19:20:27 +01:00
parent 1f4f1f6ab1
commit 84cb830804
14 changed files with 511 additions and 432 deletions
@@ -21,7 +21,7 @@ data Configuration = Configuration
    , _windowPosY           :: Int
    , _gameplay_rotate_to_wall :: Bool
    , _debug_view_clip_bounds :: RoomClipping
-    , _debug_booleans :: S.Set DebugBool  -- consider using Data.BitSet
+    , _debug_booleans       :: S.Set DebugBool  -- consider using Data.BitSet
    }
  deriving (Generic, Show)
 data DebugBool
@@ -44,6 +44,7 @@ data DebugBool
    | Show_far_wall_detect
    | Show_select
    | Inspect_wall
+    | Show_nodes_near_select
  deriving (Generic, Eq,Ord,Bounded, Enum, Show)
 data ResFactor = FullRes | HalfRes | QuarterRes
  deriving (Generic, Show, Eq, Ord, Enum, Bounded)
@@ -172,7 +172,10 @@ data World = World
    , _genRooms             :: IM.IntMap Room
    , _deathDelay           :: Maybe Int
    , _testFloat            :: Float
-    , _wSelect              :: (Point2,Point2)
+    , _lLine               :: (Point2,Point2)
+    , _rLine               :: (Point2,Point2)
+    , _lSelect             :: Point2
+    , _rSelect             :: Point2
    }
 data WorldHammer
    = SubInvHam
@@ -74,7 +74,7 @@ defaultWorld = World
    , _clickMousePos = V2 0 0
    , _pathGraph = Data.Graph.Inductive.Graph.empty
    , _pathGraphP   = mempty
-    , _phZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _phZoning     = Zoning mempty phZoneSize (zonePos snd)
    , _hud = HUD
        { _hudElement = DisplayInventory NoSubInventory
        , _carteCenter = V2 0 0
@@ -111,7 +111,10 @@ defaultWorld = World
    , _testFloat = 0
    , _boundBox = square 100
    , _boundDist = (100,-100,100,-100)
-    , _wSelect      = (0,0)
+    , _lLine  = (0,0)
+    , _rLine  = (0,0)
+    , _lSelect   = 0
+    , _rSelect   = 0
    }
 defaultWorldHammers :: M.Map WorldHammer HammerPosition
 defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound]
@@ -4,6 +4,9 @@ module Dodge.Path
    , makePathBetweenPs
    , removePathsCrossing
    , pairsToGraph
+    , walkableNodeNear
+    , nodesNearL
+    , getNodePos
    ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -18,21 +21,28 @@ import Data.List
 import Data.Graph.Inductive hiding ((&))
 import qualified Data.Set as Set
 import qualified Streaming.Prelude as S
+import StreamingHelp
 --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
-    nb <- walkableNodeNear b
+    (na,_) <- walkableNodeNear a w
+    (nb,_) <- walkableNodeNear b w
    sp na nb (_pathGraph w)
-  where
-    --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
-    nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w
-    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p

--walkableNodeNear :: Point2 -> World -> Maybe Point2
--walkableNodeNear p w = insideCirc
+walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
+walkableNodeNear p w = minStreamOn (dist p . snd) 
+    . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
+
+nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
+nodesNear = aroundPoint _phZoning
+
+nodesNearL :: Point2 -> World -> [(Int,Point2)]
+nodesNearL p = runIdentity . S.toList_ . nodesNear p

 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
 makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
@@ -16,6 +16,8 @@ import Dodge.Graph
 import Dodge.GameRoom
 import Dodge.Update.Camera
 import Dodge.Item.Draw
+import Dodge.Render.List
+import Dodge.Path
 --import Dodge.Zone
 import Geometry
 import Geometry.Zone
@@ -76,34 +78,61 @@ extraPics cfig w = pictures (_decorations w)
 --    <> runIdentity (S.foldMap_ clDraw (_clouds w))
    <> concatMapPic clDraw (_clouds w      )
    <> concatMapPic ppDraw (_pressPlates w )
-    <> soundPics cfig w
    <> viewClipBounds cfig w
-    <> drawMousePosition cfig w
-    <> drawWallIDs cfig w
-    <> drawPathing cfig w
-    <> drawCrInfo cfig w
-    <> cfigdraw View_boundaries (const viewBoundaries)
-    <> cfigdraw Show_bound_box (const drawBoundingBox)
-    <> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
-    <> cfigdraw Show_dda_test (const drawDDATest)
-    <> cfigdraw Show_far_wall_detect    (const drawFarWallDetect)
-    <> cfigdraw Show_select             (const drawWorldSelect)
-    <> cfigdraw Inspect_wall            (const drawInspectWalls)
-    <> cfigdraw Cr_awareness            (const drawCreatureDisplayTexts)
+    <> debugDraw cfig w
+
+debugDraw :: Configuration -> World -> Picture
+debugDraw cfig w = pic
+    <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
  where
-    cfigdraw boption draw
-        | debugOn boption cfig = draw cfig w
-        | otherwise = mempty
+    (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
+    f (Left s) = ([s],mempty)
+    f (Right pic') = (mempty,pic')
+
+debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture
+debugDraw' cfig w bl = case bl of
+    Noclip      -> Left "Noclip"
+    Remove_LOS  -> Left "No line of sight"
+    Cull_more_lights    -> Left "Cull more lights"
+    Close_shape_culling -> Left "Close shape culling"
+    Bound_box_screen    -> Left "bound box screen, this should be moved"
+    Show_ms_frame           -> Right mempty
+    View_boundaries         -> Right $ viewBoundaries w
+    Show_bound_box          -> Right $ drawBoundingBox w
+    Show_wall_search_rays   -> Right $ drawWallSearchRays w
+    Show_dda_test           -> Right $ drawDDATest w
+    Show_far_wall_detect    -> Right $ drawFarWallDetect w
+    Show_select             -> Right $ drawWorldSelect w
+    Inspect_wall            -> Right $ drawInspectWalls w
+    Cr_awareness            -> Right $ drawCreatureDisplayTexts w
+    Show_sound              -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
+    Cr_status               -> Right $ drawCrInfo cfig w
+    Mouse_position          -> Right $ drawMousePosition cfig w
+    Walls_info              -> Right $ drawWlIDs cfig w
+    Pathing                 -> Right $ drawPathing w
+    Show_nodes_near_select  -> Right $ drawNodesNearSelect w

 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)

+drawNodesNearSelect :: World -> Picture
+drawNodesNearSelect w = setLayer DebugLayer $
+     runIdentity (S.foldMap_ (drawZone phZoneSize) (zoneAroundPoint phZoneSize 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) 
    $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
    $ IM.elems $ _walls w
  where
-    (a,b) = _wSelect w
+    (a,b) = _lLine w

 drawInspectWall :: World -> Wall -> Picture
 drawInspectWall _ wl = setLayer DebugLayer $ 
@@ -117,10 +146,12 @@ drawInspectWall _ wl = setLayer DebugLayer $
 --    (a,b) = _wSelect w

 drawWorldSelect :: World -> Picture
-drawWorldSelect w = setLayer DebugLayer . color cyan 
-    $ line [a,b]
+drawWorldSelect w = setLayer DebugLayer
+    $  color cyan (line [a,b])
+    <> color magenta (line [c,d])
  where
-    (a,b) = _wSelect w
+    (a,b) = _lLine w
+    (c,d) = _rLine w

 drawFarWallDetect :: World -> Picture
 drawFarWallDetect w = setLayer DebugLayer 
@@ -196,11 +227,6 @@ mcSPic :: Machine -> SPic
 mcSPic bt = uncurryV translateSPf (_mcPos bt)
    $ rotateSP (_mcDir bt) (_mcDraw bt bt)

-soundPics :: Configuration -> World -> Picture
-soundPics cfig w
-    | debugOn Show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w
-    | otherwise = []
-
 soundPic :: Configuration -> World -> Sound -> Picture
 soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
  where
@@ -215,23 +241,17 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
    f x = 1 - 0.5 * (1 - x)

 drawMousePosition :: Configuration -> World -> Picture
-drawMousePosition cfig w
-    | not $ debugOn Mouse_position cfig = mempty
-    | otherwise
-        = setLayer FixedCoordLayer . winScale cfig
-            . uncurryV translate p
-            . scale 0.1 0.1
-            . text 
-            $ shortPoint2 mwp 
+drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
+    . uncurryV translate p
+    . scale 0.1 0.1
+    . text 
+    $ shortPoint2 mwp 
  where
    p = worldPosToScreen w mwp
    mwp = mouseWorldPos w

-drawWallIDs :: Configuration -> World -> Picture
-drawWallIDs cfig w 
-    | debugOn Walls_info cfig = setLayer FixedCoordLayer 
-        $ foldMap f (_walls w)
-    | otherwise = mempty
+drawWlIDs :: Configuration -> World -> Picture
+drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
  where
    f wl 
        | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty  -- this should be improved with a better "on screen test"
@@ -243,13 +263,10 @@ drawWallIDs cfig w
      where
        p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)

-drawPathing :: Configuration -> World -> Picture
-drawPathing cfig w
-    | debugOn Pathing cfig 
-        = setLayer DebugLayer $ 
+drawPathing :: World -> Picture
+drawPathing w = setLayer DebugLayer $ 
        (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
        <> concatMap dispInc (graphToIncidence gr)
-    | otherwise = []
  where
    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
    gr = _pathGraph w
@@ -274,11 +291,9 @@ crDisplayInfo cfig w cr
    crOnScreen = pointOnScreen cfig w $ _crPos cr

 drawCrInfo :: Configuration -> World -> Picture
-drawCrInfo cfig w
-    | debugOn Cr_status cfig = setLayer FixedCoordLayer 
+drawCrInfo cfig w = setLayer FixedCoordLayer 
        $ renderInfoListsAt (2*hw - 400) 0 cfig w
        $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
-    | otherwise = mempty
  where
    hw = halfWidth cfig

@@ -98,15 +98,26 @@ functionalUpdate cfig w = checkEndGame
    $ updateCloseObjects w

 zoneClouds :: World -> World
-zoneClouds w = w & clZoning %~ \zn ->
-    foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) (_clouds w)
+zoneClouds w = w 
+    & clZoning . znObjects .~ mempty
+    & clZoning %~ \zn ->
+        foldl' (flip $ updateZoning (:)) zn (_clouds w)
    --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w))

 updateWorldSelect :: World -> World
-updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
-    Nothing     -> w
-    Just False  -> w & wSelect . _1 .~ mouseWorldPos w
-    Just True   -> w & wSelect . _2 .~ mouseWorldPos w
+updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of
+    (Nothing   ,Nothing)  -> w
+    (Just False,Nothing)  -> w & lLine . _1 .~ mwp
+    (Just True ,Nothing)  -> w & lLine . _2 .~ mwp
+    (Nothing   ,_)        -> w
+    (Just False,_)        -> w & rLine . _1 .~ mwp
+    (Just True ,_)        -> w & rLine . _2 .~ mwp
+  where
+    mwp = mouseWorldPos w
+    f   | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp
+        | otherwise = id
+    g   | ButtonRight `M.member` _mouseButtons w = rSelect .~ mwp
+        | otherwise = id

 mcChooseUpdate :: Machine -> Machine -> World -> World
 mcChooseUpdate mc mc'
@@ -33,7 +33,7 @@ updatePressedButtons subinv pkeys w = case subinv of
        | otherwise -> updatePressedButtons' pkeys w
    CombineInventory mi
        | pkeys ^? ix ButtonLeft == Just False
-                -> (maybeexitcombine $ maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown
+                -> maybeexitcombine (maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown
    DisplayTerminal tmid
        | pkeys ^? ix ButtonLeft == Just False && inTermFocus w 
                -> doTerminalEffectLB (w ^?! terminals . ix tmid) w
@@ -4,7 +4,6 @@ Find which objects lie upon a line.
 -}
 module Dodge.WorldEvent.ThingsHit
    ( thingsHit
--    , wallsHit
    , thingHit
    , thingsHitExceptCr
    )
@@ -1,6 +1,7 @@
 module Dodge.Zone
    ( zoneOfSight
    , zoneAroundPoint
+    , aroundPoint
    , nearPoint
    , wlsNearPoint
    , crsNearPoint
@@ -83,6 +84,11 @@ nearPoint f p w = S.each . fromMaybe mempty $ extractFromZone zn (zoneOfPoint (_
  where
    zn = f w

+aroundPoint :: Foldable t => (World -> Zoning t a) -> Point2 -> World -> StreamOf a
+aroundPoint f p w = streamFromZone zn $ zoneAroundPoint (_znSize zn) p
+  where
+    zn = f w
+
 clsNearPoint :: Point2 -> World -> StreamOf Cloud
 clsNearPoint = nearPoint _clZoning

@@ -95,7 +101,7 @@ crsNearPoint = nearPoint _crZoning
 nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
 nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
  where
-    zn = (f w)
+    zn = f w

 wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
 wlsNearSeg = nearSeg _wlZoning
@@ -1,5 +1,8 @@
 module Dodge.Zone.Size where

+phZoneSize :: Float
+phZoneSize = 100
+
 wlZoneSize :: Float
 wlZoneSize = 50