Add selection box on left click drag

src/Dodge/Data/Config.hs

@@ -65,7 +65,7 @@ windowYFloat = fromIntegral . _windowY
 
 data DebugBool
     = Show_ms_frame
-    | Enable_debug
+    | Display_debug
     | Show_sound
     | Noclip
     | Cr_status
@@ -91,7 +91,6 @@ data DebugBool
     | Show_zone_circ
     | Inspect_wall
     | Show_path_between
-    | Select_creature
     deriving (Eq, Ord, Bounded, Enum, Show)
 
 data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes

src/Dodge/Data/Universe.hs

@@ -49,8 +49,8 @@ data Universe = Universe
     }
 
 data DebugItem = DebugItem
-    { _debugMessage :: [String]
-    , _debugInfo :: DebugInfo
+    { _debugMessage :: String
+    , _debugFunction :: String -> Universe -> Universe
     }
 
 data DebugInfo

src/Dodge/Debug.hs

@@ -2,46 +2,37 @@
 
 module Dodge.Debug (debugEvents,drawDebug) where
 
-import AesonHelp
 import Control.Lens
 import Control.Monad
-import Data.Aeson.Types
 import qualified Data.IntMap.Strict as IM
-import Data.List (sortOn)
 import qualified Data.Map.Strict as M
 import Data.Maybe
-import Data.Ord
 import qualified Data.Set as S
-import Dodge.Base.Coordinate
 import Dodge.Base.Window
 import Dodge.Data.Universe
 import Dodge.Debug.Picture
-import Dodge.WorldEvent.ThingsHit
-import Geometry.Vector
 import Linear
 import Padding
 import Picture.Base
-import qualified SDL
 import ShortShow
 
 debugEvents :: Universe -> Universe
-debugEvents u = case dbools ^. at Enable_debug of
+debugEvents u = case dbools ^. at Display_debug of
     Nothing -> u
     Just () -> S.foldr debugEvent (u & uvDebug .~ mempty) dbools
   where
     dbools = u ^. uvConfig . debug_booleans
 
 debugEvent :: DebugBool -> Universe -> Universe
-debugEvent db u = u & uvDebug . at db ?~ debugItem db u
+debugEvent db u = u & uvDebug . at db .~ debugItem db u
 
-debugItem :: DebugBool -> Universe -> [DebugItem]
+debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
 debugItem = \case
     Collision_test -> mempty
     Circ_collision_test -> mempty
-    Select_creature -> return . selectCreatureDebugItem
     Show_walls_near_point_cursor -> mempty
     Show_walls_near_segment -> mempty
-    Enable_debug -> mempty
+    Display_debug -> mempty
     Noclip -> mempty
     Remove_LOS -> mempty
     Cull_more_lights -> mempty
@@ -59,24 +50,22 @@ debugItem = \case
     Inspect_wall -> mempty
     Cr_awareness -> mempty
     Show_sound -> mempty
-    Cr_status -> drawCrInfo
+    Cr_status -> Just . drawCrInfo
     Mouse_position -> mempty
     Walls_info -> mempty
     Pathing -> mempty
     Show_path_between -> mempty
 
 drawCrInfo :: Universe -> [DebugItem]
-drawCrInfo u = mapMaybe f . IM.elems $ w ^. cWorld . lWorld . creatures
+drawCrInfo u = foldMap f . IM.elems $ w ^. cWorld . lWorld . creatures
   where
     w = u ^. uvWorld
     g h str = fmap $ ((rightPad 7 '.' str ++ "...") ++) . h
-    f cr = do
+    f cr = fromMaybe [] $ do
         guard $
             pointIsOnScreen (u ^. uvConfig) (w ^. wCam) (cr ^. crPos . _xy)
                 && cr ^. crID /= 0
-        Just $
-            DebugItem
-                ( catMaybes
+        Just $ (\x -> DebugItem x (const id)) <$> catMaybes
                     [ g show "crID" $ cr ^? crID
                     , g show "crHP" $ cr ^? crHP . _HP
                     , g show "crStrategy" $ cr ^? crActionPlan . apStrategy
@@ -85,114 +74,23 @@ drawCrInfo u = mapMaybe f . IM.elems $ w ^. cWorld . lWorld . creatures
                     , g show "crAction" $ cr ^? crActionPlan . apAction
                     , g show "crImpulse" $ cr ^? crActionPlan . apImpulse
                     ]
-                )
-                (DebugV2 $ cr ^. crPos . _xy)
 
---drawCrInfo :: Config -> World -> Picture
---drawCrInfo cfig w =
---    setLayer FixedCoordLayer $
---        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
---            mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
+--closestCreatureID :: Universe -> Maybe Int
+--closestCreatureID u =
+--    fmap (_crID . snd) . listToMaybe
+--        . sortOn (Down . dist mwp . fst)
+--        . crsHitRadial mwp 100
+--        $ _uvWorld u
 --  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
-        { _debugMessage = debugSelectCreatureMessage u
-        , _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 . ix 0 . debugInfo . debugInt)]
-    $ do
-        cid <- u ^? uvDebug . ix Select_creature . ix 0 . debugInfo . debugMInt . _Just
-        i <- u ^? uvDebug . ix Select_creature . ix 0 . debugInfo . debugInt
-        cap <- debugSelectCreatureList cid u !! i
-        return $ show cid : cap
-
-debugSelectCreatureList :: Int -> Universe -> [Maybe [String]]
-debugSelectCreatureList cid u =
-    [ debugList
-        "ActionPlan"
-        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan)
-    , debugList
-        "Perception"
-        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crPerception)
-    , debugList
-        "Intention"
-        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crIntention)
-    , debugList
-        "Memory"
-        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crMemory)
-    , debugList
-        "Strategy"
-        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan . apStrategy)
-    , debugList
-        "Vocalization"
-        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crVocalization)
-    ]
-
-debugList :: (Functor f, ToJSON a) => String -> f a -> f [String]
-debugList str = fmap (([str] ++) . prettyShort)
-
-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 . ix 0 . debugInfo
-
-closestCreatureID :: Universe -> Maybe Int
-closestCreatureID u =
-    fmap (_crID . snd) . listToMaybe
-        . sortOn (Down . dist mwp . fst)
-        . crsHitRadial mwp 100
-        $ _uvWorld u
-  where
-    mwp = mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)
+--    mwp = mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)
 
 drawDebug :: Universe -> DebugBool -> Picture
 drawDebug u = \case
     Collision_test -> drawCollisionTest $ _uvWorld u
     Circ_collision_test -> drawCircCollisionTest $ _uvWorld u
-    Select_creature -> mempty
     Show_walls_near_point_cursor -> drawWallsNearCursor $ _uvWorld u
     Show_walls_near_segment -> drawWallsNearSegment $ _uvWorld u
-    Enable_debug -> mempty
+    Display_debug -> mempty
     Noclip -> mempty
     Remove_LOS -> mempty
     Cull_more_lights -> mempty

src/Dodge/Render/Picture.hs

@@ -2,6 +2,7 @@
 
 module Dodge.Render.Picture (fixedCoordPictures) where
 
+import qualified SDL
 import Control.Lens
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -30,6 +31,7 @@ fixedCoordPictures u =
                 (u ^. uvWorld . cWorld . lWorld . lTestString)
             )
         <> displayFrameTicks u
+        <> drawAnySelectionBox u
         <> drawMouseCursor u
         <> toTopLeft
             cfig
@@ -44,7 +46,7 @@ fixedCoordPictures u =
     hw = halfWidth cfig
     hh = halfHeight cfig
     ttl = toTopLeft cfig
-    f (k, l) = (show k, foldMap _debugMessage l)
+    f (k, l) = (show k, map _debugMessage l)
 
 displayFrameTicks :: Universe -> Picture
 displayFrameTicks u
@@ -125,6 +127,13 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
             argV (w ^. cWorld . lWorld . lAimPos -.- cpos)
                 - w ^. wCam . camRot
 
+drawAnySelectionBox :: Universe -> Picture
+drawAnySelectionBox  u = case u ^. uvWorld . input . mouseContext of
+    OverInvDragSelect{} -> fold $ do
+        p <- u ^. uvWorld . input . clickPos . at SDL.ButtonLeft
+        return . color white . polygonWire $ rectVV (u ^. uvWorld . input . mousePos) p
+    _ -> mempty
+
 drawCursorByTerminalStatus :: TerminalStatus -> Picture
 drawCursorByTerminalStatus = \case
     TerminalPressTo "QUIT" -> drawQuitTerminal 5