justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Add more debug info for selected creatures

Browse Source
This commit is contained in:
justin
2023-04-30 13:55:54 +01:00
parent 5b1212e4f6
commit 08e71e5451
17 changed files with 116 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+1
View File
@@ -95,6 +95,7 @@ firstWorldLoad theConfig = do
, _uvFrameTicks = 0
, _uvRAMSave = Nothing
, _uvDebug = mempty
, _uvDebugMessageOffset = 0
}
return $ u & uvScreenLayers .~ [splashMenu u]
src/Dodge/Creature.hs
-7
View File
@@ -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
-3
View File
@@ -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
+2 -2
View File
@@ -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
+2 -3
View File
@@ -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
WatchAndWait ->
| _crPastDamage cr > 0 &&
_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
+1 -1
View File
@@ -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
+5 -5
View File
@@ -174,8 +174,8 @@ data Action
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data Strategy
= Flank Int
| Ambush Int
= Flank {_flankTarget :: 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
| SentinelAt Point2 Float
| Kill {_killTarget :: Int}
| SentinelAt {_sentinelPos :: Point2, _sentinelDir :: Float}
deriving (Eq, Ord, Show) --Generic, Flat)
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/Config.hs
+1 -1
View File
@@ -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
+1
View File
@@ -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
+6 -2
View File
@@ -41,11 +41,12 @@ data Universe = Universe
, _uvFrameTicks :: Word32
, _uvRAMSave :: Maybe World
, _uvDebug :: M.Map DebugBool DebugItem
, _uvDebugMessageOffset :: Int
}
data DebugItem = DebugItem
{ _debugPic :: Picture
, _debugMessage :: [String]
{ _debugPic :: Universe -> Picture
, _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
+64 -5
View File
@@ -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
{ _debugPic = drawCollisionTest $ u ^. uvWorld
, _debugMessage = ["Collision test:","asdf"]
collisionDebugItem u =
DebugItem
{ _debugPic = const $ drawCollisionTest $ u ^. uvWorld
, _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
+8 -9
View File
@@ -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 . clickWorldPos . at ButtonLeft
b <- w ^. input . clickWorldPos . at ButtonRight
a <- w ^. input . heldWorldPos . at ButtonLeft
b <- w ^. input . heldWorldPos . at ButtonRight
return $
setLayer DebugLayer (color orange $ line [a, b])
<> foldMap (drawCross . fst) (crHit a b w)
<> foldMap (drawCross . _crPos) (crsNearSeg a b w)
<> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
<> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
<> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
<> foldMap (drawCrossCol red . fst) (thingHit a b w)
-- <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
-- <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
-- <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' 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
+1
View File
@@ -16,6 +16,7 @@ defaultInput =
{ _clickPos = mempty
, _clickWorldPos = mempty
, _heldPos = mempty
, _heldWorldPos = mempty
, _textInput = mempty
, _pressedKeys = mempty
, _mouseButtons = mempty
src/Dodge/Render/ShapePicture.hs
+4 -2
View File
@@ -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 -3
View File
@@ -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
+15 -4
View File
@@ -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 .~ []
--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 300 . ((w ^. cWorld . lWorld) :))
doWorldEvents :: World -> World
doWorldEvents w =
src/Dodge/WorldEvent/ThingsHit.hs
+2 -1
View File
@@ -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