Add more debug info for selected creatures

appDodge/Main.hs

@@ -95,6 +95,7 @@ firstWorldLoad theConfig = do
                 , _uvFrameTicks = 0
                 , _uvRAMSave = Nothing
                 , _uvDebug = mempty
+                , _uvDebugMessageOffset = 0
                 }
     return $ u & uvScreenLayers .~ [splashMenu u]
 

src/Dodge/Creature.hs

@@ -67,13 +67,6 @@ miniGunCrit =
 longCrit :: Creature
 longCrit =
     defaultCreature
-        & crActionPlan
-            .~ ActionPlan
-                { _apImpulse = []
-                , _apAction = []
-                , _apStrategy = StrategyActions WatchAndWait [StartSentinelPost]
-                , _apGoal = []
-                }
         & crInv .~ IM.fromList [(0, sniperRifle), (1, medkit 100)]
         & crType . humanoidAI .~ LongAI
         & crType . skinUpper .~ lightx4 red

src/Dodge/Creature/ChainUpdates.hs

@@ -11,6 +11,3 @@ chainCreatureUpdates ::
 chainCreatureUpdates ls w cr = foldl' unf cr ls
   where
     unf cr' g = g w cr'
---chainCreatureUpdates ls w cr = foldr unf cr ls
---  where
---    unf g cr' = g w cr'

src/Dodge/Creature/HandPos.hs

@@ -45,7 +45,7 @@ translatePointToRightHand' cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 translateToRightHand :: Creature -> SPic -> SPic
-translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz
+translateToRightHand = translateToRightHand' -- . mirrorSPxz
 
 translateToRightHand' :: Creature -> SPic -> SPic
 translateToRightHand' cr
@@ -61,7 +61,7 @@ translateToRightHand' cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 translateToRightWrist :: Creature -> SPic -> SPic
-translateToRightWrist cr = translateToRightWrist' cr -- . mirrorSPxz
+translateToRightWrist = translateToRightWrist' -- . mirrorSPxz
 
 translateToRightWrist' :: Creature -> SPic -> SPic
 translateToRightWrist' cr

src/Dodge/Creature/ReaderUpdate.hs

@@ -197,8 +197,8 @@ targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of
 
 searchIfDamaged :: Creature -> Creature
 searchIfDamaged cr
-    | _crPastDamage cr > 0 = case _apStrategy (_crActionPlan cr) of
+    | _crPastDamage cr > 0 && 
-        WatchAndWait ->
+        _apStrategy (_crActionPlan cr) == WatchAndWait =
             cr & crPerception . cpVigilance .~ Vigilant
                 & crActionPlan . apStrategy
                     .~ StrategyActions
@@ -206,7 +206,6 @@ searchIfDamaged cr
                         [ TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr))
                             `DoActionThen` 40 `WaitThen` bfsThenReturn 500
                         ]
-        _ -> cr
     | otherwise = cr
 
 bfsThenReturn :: Int -> Action

src/Dodge/Creature/SetTarget.hs

@@ -12,5 +12,5 @@ targetYouWhenCognizant ::
     Creature
 targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of
     --Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0
-    Just (Cognizant _) -> cr & crIntention . targetCr .~ Just (w ^?! cWorld . lWorld . creatures . ix 0)
+    Just (Cognizant _) -> cr & crIntention . targetCr ?~ (w ^?! cWorld . lWorld . creatures . ix 0)
     _ -> cr & crIntention . targetCr .~ Nothing

src/Dodge/Data/ActionPlan.hs

@@ -174,8 +174,8 @@ data Action
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Strategy
-    = Flank Int
+    = Flank {_flankTarget :: Int}
-    | Ambush Int
+    | Ambush {_ambushTarget :: Int}
     | Lure Int Point2
     | Patrol [Point2]
     | ShootAt Int
@@ -183,7 +183,7 @@ data Strategy
     | WatchAndWait
     | WarningCry
     | LookAround
-    | CloseToMelee Int
+    | CloseToMelee {_meleeTarget :: Int}
     | StrategyActions Strategy [Action]
     | GetTo Point2
     | Reload
@@ -194,8 +194,8 @@ data Strategy
 
 data Goal
     = LiveLongAndProsper
-    | Kill Int
+    | Kill {_killTarget :: Int}
-    | SentinelAt Point2 Float
+    | SentinelAt {_sentinelPos :: Point2, _sentinelDir :: Float}
     deriving (Eq, Ord, Show) --Generic, Flat)
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Config.hs

@@ -89,7 +89,7 @@ data DebugBool
     | Inspect_wall
     | Show_nodes_near_select
     | Show_path_between
-    | Pacify_enemies
+    | Select_creature
     deriving (Eq, Ord, Bounded, Enum, Show)
 
 data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes

src/Dodge/Data/Input.hs

@@ -26,6 +26,7 @@ data Input = Input
     , _clickPos :: M.Map MouseButton Point2 -- updates on initial mouse button press
     , _heldPos :: M.Map MouseButton Point2 -- updates while mouse button is held, lags one frame
     , _clickWorldPos :: M.Map MouseButton Point2 -- updates on initial mouse button press
+    , _heldWorldPos :: M.Map MouseButton Point2 -- updates while mouse button is held, lags one frame
     , _textInput :: [Either TermSignal Char]
     , _scrollTestFloat :: Float
     , _scrollTestInt :: Int

src/Dodge/Data/Universe.hs

@@ -41,11 +41,12 @@ data Universe = Universe
     , _uvFrameTicks :: Word32
     , _uvRAMSave :: Maybe World
     , _uvDebug :: M.Map DebugBool DebugItem
+    , _uvDebugMessageOffset :: Int
     }
 
 data DebugItem = DebugItem
-    { _debugPic :: Picture
+    { _debugPic :: Universe -> Picture
-    , _debugMessage :: [String]
+    , _debugMessage :: Universe -> [String]
     , _debugInfo :: DebugInfo
     }
 
@@ -54,6 +55,7 @@ data DebugInfo
     | DebugV3 { _debugV3 :: V3 Float}
     | DebugV2 { _debugV2 :: V2 Float}
     | DebugMInt { _debugMInt :: Maybe Int}
+    | DebugIntMInt {_debugInt :: Int, _debugMInt :: Maybe Int}
 
 data SideEffect
     = NewSideEffect
@@ -113,3 +115,5 @@ makeLenses ''SideEffect
 makeLenses ''MenuOptionDisplay
 makeLenses ''MenuOption
 makeLenses ''PositionedMenuOption
+makeLenses ''DebugItem
+makeLenses ''DebugInfo

src/Dodge/Debug.hs

@@ -1,9 +1,17 @@
 module Dodge.Debug where
 
-import Dodge.Debug.Picture
+import AesonHelp
 import Control.Lens
-import Dodge.Data.Universe
+import Data.List (sortOn)
+import qualified Data.Map.Strict as M
+import Data.Maybe
 import qualified Data.Set as S
+import Dodge.Base.Coordinate
+import Dodge.Data.Universe
+import Dodge.Debug.Picture
+import Dodge.WorldEvent.ThingsHit
+import Geometry.Vector
+import qualified SDL
 
 debugEvents :: Universe -> Universe
 debugEvents u = case dbools ^. at Enable_debug of
@@ -15,11 +23,62 @@ debugEvents u = case dbools ^. at Enable_debug of
 debugEvent :: DebugBool -> Universe -> Universe
 debugEvent db u = case db of
     Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
+    Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
     _ -> u
 
 collisionDebugItem :: Universe -> DebugItem
-collisionDebugItem u = DebugItem
+collisionDebugItem u =
-    { _debugPic = drawCollisionTest $ u ^. uvWorld
+    DebugItem
-    , _debugMessage = ["Collision test:","asdf"]
+        { _debugPic = const $ drawCollisionTest $ u ^. uvWorld
-    , _debugInfo = NoDebugInfo
+        , _debugMessage = const []
-    }
+        , _debugInfo = NoDebugInfo
+        }
+
+selectCreatureDebugItem :: Universe -> DebugItem
+selectCreatureDebugItem u =
+    DebugItem
+        { _debugPic = const mempty
+        , _debugMessage = debugSelectCreatureMessage
+        , _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
+        }
+
+scrollDebugInfoInt :: Int -> Universe -> DebugInfo -> DebugInfo
+scrollDebugInfoInt i u
+    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
+        debugInt %~ ((`mod` i) . (+ (u ^. uvWorld . input . scrollAmount)))
+    | otherwise = id
+
+debugSelectCreatureMessage :: Universe -> [String]
+debugSelectCreatureMessage u = fromMaybe
+    [show (u ^? uvDebug . ix Select_creature . debugInfo . debugInt)]
+    $ do
+        cid <- u ^? uvDebug . ix Select_creature . debugInfo . debugMInt . _Just
+        i <- u ^? uvDebug . ix Select_creature . debugInfo . debugInt
+        cap <- debugSelectCreatureList cid u !! i
+        return $ show cid : getPretty cap
+
+debugSelectCreatureList :: Int -> Universe -> [Maybe [String]]
+debugSelectCreatureList cid u =
+    [ fmap getPretty $ u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan
+    , fmap getPretty $ u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crPerception
+    , fmap getPretty $ u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crIntention
+    , fmap getPretty $ u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crMemory
+    ]
+
+clickGetCreature :: Universe -> DebugInfo
+clickGetCreature u
+    | SDL.ButtonLeft `M.member` (u ^. uvWorld . input . mouseButtons)
+        && SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
+        DebugIntMInt 0 (closestCreatureID u)
+    | otherwise =
+        fromMaybe (DebugIntMInt 0 Nothing) $
+            u ^? uvDebug . ix Select_creature . debugInfo
+
+closestCreatureID :: Universe -> Maybe Int
+closestCreatureID u =
+    fmap (_crID . snd) . listToMaybe . reverse
+        . sortOn (dist mwp . fst)
+        . crsHitRadial mwp 100
+        $ _uvWorld u
+  where
+    mwp = mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)

src/Dodge/Debug/Picture.hs

@@ -102,16 +102,15 @@ intersectLinefromScreen cfig w a b =
 
 drawCollisionTest :: World -> Picture
 drawCollisionTest w = fromMaybe mempty $ do
---    let f = fmap (screenToWorldPos (w ^. wCam))
+    a <- w ^. input . heldWorldPos . at ButtonLeft
-    a <- w ^. input . clickWorldPos . at ButtonLeft
+    b <- w ^. input . heldWorldPos . at ButtonRight
-    b <- w ^. input . clickWorldPos . at ButtonRight
     return $
         setLayer DebugLayer (color orange $ line [a, b])
-            <> foldMap (drawCross . fst) (crHit a b w)
+            <> foldMap (drawCrossCol red . fst) (thingHit a b w)
-            <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
+--            <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
-            <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
+--            <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
-            <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
+--            <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
-            <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
+--            <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
 
 drawZoneCol :: Color -> Float -> V2 Int -> Picture
 drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
@@ -159,7 +158,7 @@ debugDraw' cfig w bl = case bl of
     Show_nodes_near_select -> undefined --drawNodesNearSelect w
     Show_path_between -> drawPathBetween w
     Collision_test -> mempty
-    Pacify_enemies -> mempty
+    Select_creature -> mempty
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)

src/Dodge/Default/World.hs

@@ -16,6 +16,7 @@ defaultInput =
         { _clickPos = mempty
         , _clickWorldPos = mempty
         , _heldPos = mempty
+        , _heldWorldPos = mempty
         , _textInput = mempty
         , _pressedKeys = mempty
         , _mouseButtons = mempty

src/Dodge/Render/ShapePicture.hs

@@ -140,9 +140,11 @@ extraPics cfig u =
         <> concatMapPic ppDraw (_pressPlates lw)
         <> viewClipBounds cfig w
         <> debugDraw cfig w
-        <> foldMap _debugPic (_uvDebug u)
+        <> foldMap (`_debugPic` u) (_uvDebug u)
         <> setLayer FixedCoordLayer
-            (listPicturesAt (1.3 * halfWidth cfig) 0 cfig (map text (foldMap _debugMessage (_uvDebug u))))
+            (listPicturesAt (1.3 * halfWidth cfig) 0 cfig 
+                . take 50 . drop (u ^. uvDebugMessageOffset)
+                . map text $ foldMap (`_debugMessage` u) (_uvDebug u))
   where
     w = u ^. uvWorld
     lw = w ^. cWorld . lWorld

src/Dodge/TestString.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.TestString where
 
+import AesonHelp
 import Dodge.SmoothScroll
 import HelpNum
 import Dodge.Base.Coordinate
@@ -39,9 +40,6 @@ testStringInit u = [show $ u ^. uvWorld . input . smoothScrollAmount
     --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]
 --    [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections]
 
-getPretty :: ToJSON a => a -> [String]
-getPretty = lines . unpack . AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
-
 showTimeFlow :: TimeFlowStatus -> String
 showTimeFlow tfs = case tfs of
     DeathTime i -> "DeathTime"++show i

src/Dodge/Update.hs

@@ -86,8 +86,15 @@ updateUniverseFirst u =
         & uvWorld . input . clickWorldPos %~ M.union (setClickWorldPos u)
         & uvWorld . input . smoothScrollAmount %~ calcSmoothScroll (u ^. uvWorld . input . scrollAmount)
         & over (uvWorld . input) updateScrollTestValue
+        & updateDebugMessageOffset
         & over (uvWorld . cWorld . cClock) (+ 1)
 
+updateDebugMessageOffset :: Universe -> Universe
+updateDebugMessageOffset u
+    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys)
+        = u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
+    | otherwise = u
+
 setClickWorldPos :: Universe -> M.Map MouseButton Point2
 setClickWorldPos u = fmap 
     (const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
@@ -125,8 +132,10 @@ updateUniverseLast u =
         & uvWorld . input . mouseMoving .~ False
         & uvWorld . input . mouseButtons . each +~ 1
         & uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
+        & uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
   where
     mp = u ^. uvWorld . input . mousePos
+    mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
     f LongPress = LongPress
     f _ = ShortPress
 
@@ -151,7 +160,10 @@ timeFlowUpdate :: Universe -> Universe
 timeFlowUpdate u = case u ^. uvWorld . timeFlow of
     NormalTimeFlow -> functionalUpdate u
     ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u
-    CameraScrollTimeFlow smoothing _ _ -> over uvWorld (doTimeScroll smoothing) u
+    CameraScrollTimeFlow smoothing _ _ 
+        | SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) 
+            -> over uvWorld (doTimeScroll smoothing) u
+    CameraScrollTimeFlow {} -> u
     RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
     RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
     DeathTime{} -> u
@@ -282,9 +294,8 @@ advanceScrollAmount u =
         & uvWorld . input . smoothScrollAmount %~ advanceSmoothScroll
 
 updatePastWorlds :: World -> World
-updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
+--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
-
+updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 300 . ((w ^. cWorld . lWorld) :))
---updatePastWorlds w = w & pastWorlds .~ []
 
 doWorldEvents :: World -> World
 doWorldEvents w =

src/Dodge/WorldEvent/ThingsHit.hs

@@ -104,7 +104,8 @@ crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
 crsHitRadial p r = mapMaybe f . crsNearCirc p r
   where
     f cr
-        | dist cpos p <= r = Just (cpos +.+ r *.* normalizeV (p -.- cpos), cr)
+        | dist hitpos p <= r = Just (hitpos, cr)
         | otherwise = Nothing
       where
+        hitpos = cpos +.+ r *.* normalizeV (p -.- cpos)
         cpos = _crPos cr