Commit before working on debugging

2025-10-13 23:43:29 +01:00
parent c3a0cb0527
commit 3d602b4f57
7 changed files with 144 additions and 102 deletions
@@ -81,7 +81,8 @@ doCrWdAc cw = case cw of
    CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
        n <- walkableNodeNear w (cr ^. crPos . _xy)
        let as = take 20 $ map PathTo $ bfsNodePoints n w
-        return $
+        return $ DoActionThen (DoImpulses [ChangeStrategy Search])
+            $
            DoReplicate t $
                foldr DoActionThen NoAction as
    ChooseMovementSpreadGun -> chooseMovementSpreadGun
@@ -190,6 +190,7 @@ data Strategy
    | Reload
    | Flee
    | MeleeStrike
+    | Search
    deriving (Eq, Ord, Show) --Generic, Flat)
    --deriving (Eq, Ord, Show, Read) --Generic, Flat)

@@ -1,6 +1,14 @@
 {-# LANGUAGE LambdaCase #-}
 module Dodge.Debug (debugEvents) where

+import Padding
+import Dodge.Base.Window
+import ShortShow
+import Linear
+import Dodge.Render.InfoBox
+import Picture.Base
+import Geometry.Data
+import qualified Data.IntMap.Strict as IM
 import Data.Aeson.Types
 import AesonHelp
 import Control.Lens
@@ -15,7 +23,7 @@ import Dodge.WorldEvent.ThingsHit
 import Geometry.Vector
 import qualified SDL
 import Data.Ord
-import Data.Foldable (fold)
+--import Data.Foldable (fold)

 debugEvents :: Universe -> Universe
 debugEvents u = case dbools ^. at Enable_debug of
@@ -62,6 +70,75 @@ debugItem = \case
 constDPic :: (Universe -> Picture) -> Universe -> Maybe DebugItem
 constDPic p u = Just $ DebugItem (p u) mempty NoDebugInfo

+drawCrInfo' :: Universe -> Maybe DebugItem
+drawCrInfo' u = do
+    undefined
+--    
+--    setLayer FixedCoordLayer $
+--        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
+--            mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
+--  where
+--    w = u ^. uvWorld
+--    cfig = u ^. uvConfig
+--    cam = w ^. wCam
+--    crDisplayInfo :: Creature -> Maybe (Point2, [String])
+--    crDisplayInfo cr
+--        | _crID cr == 0 = Nothing
+--        | crOnScreen =
+--            Just
+--                ( cr ^. crPos . _xy
+--                , catMaybes
+--                    --        [fmap show $ ap ^? crGoal
+--                    [ fpreShow "crHP" $ cr ^? crHP . _HP
+--                    , fpreShow "crStrategy" $ ap ^? apStrategy
+--                    , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos . _xy
+--                    , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
+--                    , fpreShow "crAction" $ ap ^? apAction
+--                    , fpreShow "crImpulse" $ ap ^? apImpulse
+--                    ]
+--                )
+--        | otherwise = Nothing
+--      where
+--        ap = _crActionPlan cr
+--        crOnScreen = pointIsOnScreen cfig cam $ cr ^. crPos . _xy
+--
+--    fpreShow :: (Show a, Functor f) => String -> f a -> f String
+--    fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
+--    hw = halfWidth cfig
+
+drawCrInfo :: Config -> World -> Picture
+drawCrInfo cfig w =
+    setLayer FixedCoordLayer $
+        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
+            mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
+  where
+    cam = w ^. wCam
+    crDisplayInfo :: Creature -> Maybe (Point2, [String])
+    crDisplayInfo cr
+        | _crID cr == 0 = Nothing
+        | crOnScreen =
+            Just
+                ( cr ^. crPos . _xy
+                , catMaybes
+                    --        [fmap show $ ap ^? crGoal
+                    [ fpreShow "crHP" $ cr ^? crHP . _HP
+                    , fpreShow "crStrategy" $ ap ^? apStrategy
+                    , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos . _xy
+                    , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
+                    , fpreShow "crAction" $ ap ^? apAction
+                    , fpreShow "crImpulse" $ ap ^? apImpulse
+                    ]
+                )
+        | otherwise = Nothing
+      where
+        ap = _crActionPlan cr
+        crOnScreen = pointIsOnScreen cfig cam $ cr ^. crPos . _xy
+
+    fpreShow :: (Show a, Functor f) => String -> f a -> f String
+    fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
+    hw = halfWidth cfig
+
+
 selectCreatureDebugItem :: Universe -> DebugItem
 selectCreatureDebugItem u =
    DebugItem
@@ -14,7 +14,7 @@ import Dodge.GameRoom
 import Dodge.Graph
 import Dodge.Path
 import Dodge.Picture.SizeInvariant
-import Dodge.Render.InfoBox
+--import Dodge.Render.InfoBox
 import Dodge.Render.Label
 import Dodge.Render.List
 import Dodge.ShortShow
@@ -26,10 +26,10 @@ import Dodge.Zoning.Base
 import Geometry
 import Geometry.ConvexPoly
 import qualified IntMapHelp as IM
-import Padding
+--import Padding
 import Picture
 import SDL (MouseButton (..))
-import ShortShow
+--import ShortShow
 import Sound.Data

 printPoint :: Point2 -> Picture
@@ -394,47 +394,6 @@ drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls
      where
        p = worldPosToScreen (w ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl)

-drawCrInfo :: Config -> World -> Picture
-drawCrInfo cfig w =
-    setLayer FixedCoordLayer $
-        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
-            mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
-  where
-    cam = w ^. wCam
-    --    drawPathing :: Config -> World -> Picture
-    --    drawPathing cfig w =
-    --        setLayer DebugLayer $
-    --            foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
-    --                <> foldMap dispInc (graphToIncidence gr)
-    --      where
-    --        dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
-    --        gr = w ^. cWorld . pathGraph
-
-    crDisplayInfo :: Creature -> Maybe (Point2, [String])
-    crDisplayInfo cr
-        | _crID cr == 0 = Nothing
-        | crOnScreen =
-            Just
-                ( cr ^. crPos . _xy
-                , catMaybes
-                    --        [fmap show $ ap ^? crGoal
-                    [ fpreShow "crHP" $ cr ^? crHP . _HP
-                    , fpreShow "crStrategy" $ ap ^? apStrategy
-                    , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos . _xy
-                    , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
-                    , --        , fmap show $ cr ^? crOldPos
-                      fpreShow "crAction" $ ap ^? apAction
-                    , fpreShow "crImpulse" $ ap ^? apImpulse
-                    ]
-                )
-        | otherwise = Nothing
-      where
-        ap = _crActionPlan cr
-        crOnScreen = pointIsOnScreen cfig cam $ cr ^. crPos . _xy
-
-    fpreShow :: (Show a, Functor f) => String -> f a -> f String
-    fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
-    hw = halfWidth cfig

 drawPathing :: Config -> World -> Picture
 drawPathing cfig w =
@@ -48,15 +48,14 @@ generateLevelFromRoomList gr' w =
            & pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
            & peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
  where
-    (_, path) = pairsToGraph pairPath'
-    pairPath = foldMap _rmPath rs
-    pairPath' = snapToGrid pairPath
+    (_, path) = pairsToGraph . snapToGrid $ foldMap _rmPath rs
    rs = map doRoomShift $ IM.elems rs'
    rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w


 randomCompass :: World -> World
-randomCompass w = w & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
+randomCompass w = w 
+    & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)

 -- note the order of traversal of the rooms is important
 -- hence the reverse
@@ -67,12 +66,14 @@ setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
 setTile :: Room -> GenWorld -> GenWorld
 setTile r gw = case _rmFloor r of
    Tiled{} -> gw
-    InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
+    InheritFloor -> gw 
+        & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
  where
    t = case _rmMParent r of
        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
        Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
-    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
+    poly = orderPolygon . convexHullSafe 
+        . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r

 shuffleRoomPos :: RandomGen g => Room -> State g Room
 shuffleRoomPos rm = do
@@ -30,13 +30,15 @@ import Data.Bifunctor
 getNodePos :: Int -> World -> Maybe Point2
 getNodePos i w = (w ^. cWorld . pathGraph) `lab` i

+makePathUsing :: (PathEdge -> Bool) -> Point2 -> Point2 -> World -> Maybe [Int]
+makePathUsing t s e w = do
+    na <- walkableNodeNear w s
+    nb <- walkableNodeNear w e
+    sp na nb . second _peDist 
+        . efilter (t . (^. _3)) $ w ^. cWorld . pathGraph
+
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
-makePathBetween a b w = do
-    -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
-    na <- walkableNodeNear w a
-    nb <- walkableNodeNear w b
-    sp na nb (second _peDist (efilter (not . pathEdgeObstructed . (^. _3)) $ w ^. cWorld . pathGraph))
-    --_pathGraph (_cWorld w)))
+makePathBetween = makePathUsing $ not . pathEdgeObstructed

 pathEdgeObstructed :: PathEdge -> Bool
 pathEdgeObstructed pe = DoorObstacle `Set.member` obs || BlockObstacle `Set.member` obs