Reify debug booleans

2022-06-17 21:34:00 +01:00
parent 261bb0bb6b
commit 5053590792
10 changed files with 73 additions and 49 deletions
@@ -90,7 +90,7 @@ doSideEffects u = do
    u' <- _sideEffects w u
    endTicks <- SDL.ticks
    let lastFrameTicks = _frameTimer preData
-    when (_debug_seconds_frame $ _config u) $ void $ renderFoldable
+    when (debugOn Show_ms_frame $ _config u) $ void $ renderFoldable
        (_pictureShaders $ _renderData preData)
        (setDepth (-1)
            . translate (-0.5) (-0.8) . scale 0.0005 0.0005
@@ -3,6 +3,7 @@
 {-# LANGUAGE StrictData #-}
 module Dodge.Config.Data where
 import Data.Aeson
+import qualified Data.Set as S
 import GHC.Generics
 import Control.Lens
 data Configuration = Configuration
@@ -18,20 +19,23 @@ data Configuration = Configuration
    , _windowPosX           :: Int
    , _windowPosY           :: Int
    , _gameplay_rotate_to_wall :: Bool
-    , _debug_show_sound        :: Bool
-    , _debug_seconds_frame  :: Bool
-    , _debug_noclip         :: Bool
-    , _debug_cr_status      :: Bool
-    , _debug_cr_awareness   :: Bool
-    , _debug_mouse_position :: Bool
-    , _debug_view_boundaries :: Bool
-    , _debug_walls  :: Bool
    , _debug_view_clip_bounds :: RoomClipping
-    , _debug_pathing        :: Bool
-    , _debug_remove_LOS     :: Bool
-    , _debug_cull_more_lights :: Bool
+    , _debug_booleans :: S.Set DebugBool  -- consider using Data.BitSet
    }
  deriving (Generic, Show)
+data DebugBool
+    = Show_sound
+    | Show_ms_frame
+    | Noclip
+    | Cr_status
+    | Cr_awareness
+    | Mouse_position
+    | View_boundaries
+    | Walls_info
+    | Pathing        
+    | Remove_LOS    
+    | Cull_more_lights
+  deriving (Generic, Eq,Ord,Bounded, Enum, Show)
 data ResFactor = FullRes | HalfRes | QuarterRes
  deriving (Generic, Show, Eq, Ord, Enum, Bounded)
 instance ToJSON ResFactor where
@@ -49,10 +53,13 @@ resFactorNum rf = case rf of
    QuarterRes  -> 4

 makeLenses ''Configuration
+instance ToJSON DebugBool where
+  toEncoding = genericToEncoding defaultOptions

 instance ToJSON Configuration where
  toEncoding = genericToEncoding defaultOptions

+instance FromJSON DebugBool
 instance FromJSON Configuration

 defaultConfig  :: Configuration
@@ -69,16 +76,19 @@ defaultConfig = Configuration
    , _windowPosX           = 0
    , _windowPosY           = 0
    , _gameplay_rotate_to_wall       = True
-    , _debug_show_sound           = False
-    , _debug_seconds_frame  = True
-    , _debug_noclip         = False
-    , _debug_mouse_position = False
-    , _debug_cr_status      = False
-    , _debug_cr_awareness   = False
-    , _debug_view_boundaries = False
+    , _debug_booleans = S.singleton Show_ms_frame
    , _debug_view_clip_bounds = NoRoomClipBoundaries
-    , _debug_pathing    = False
-    , _debug_walls    = False
-    , _debug_remove_LOS      = False
-    , _debug_cull_more_lights     = False
+--    , _debug_show_sound           = False
+--    , _debug_seconds_frame  = True
+--    , _debug_noclip         = False
+--    , _debug_mouse_position = False
+--    , _debug_cr_status      = False
+--    , _debug_cr_awareness   = False
+--    , _debug_view_boundaries = False
+--    , _debug_pathing    = False
+--    , _debug_walls    = False
+--    , _debug_remove_LOS      = False
+--    , _debug_cull_more_lights     = False
    }
+debugOn :: DebugBool -> Configuration -> Bool
+debugOn db = S.member db . _debug_booleans
@@ -79,7 +79,7 @@ basicCrShape cr

 creatureDisplayText :: Configuration -> World -> Creature -> Picture
 creatureDisplayText cfig w cr 
-  | not (_debug_cr_awareness cfig) = []
+  | not (debugOn Cr_awareness cfig) = []
  | otherwise
    = setLayer DebugLayer 
    . setDepth 20 
@@ -1,5 +1,6 @@
 module Dodge.Debug.Terminal
    where
+import MaybeHelp
 import Dodge.Creature
 import Dodge.Creature.Damage
 --import Dodge.Creature.State
@@ -19,8 +20,9 @@ import qualified IntMapHelp as IM
 --import Graphics.Rendering.OpenGL.GL.Shaders (validateProgram)
 --import Dodge.Data (Universe(Universe))

+
 applyTerminalString :: String -> Universe -> Universe
-applyTerminalString "NOCLIP" = config . debug_noclip %~ not
+applyTerminalString "NOCLIP" = config . debug_booleans . at Noclip %~ toggleJust
 applyTerminalString "LOADME" = (uvWorld . creatures . ix 0 . crInv .~ stackedInventory)
    . (uvWorld . creatures . ix 0 . crInvCapacity .~ 50)
 applyTerminalString "LM" = applyTerminalString "LOADME"
@@ -3,6 +3,7 @@ module Dodge.Menu
    , pauseMenu
    , gameOverMenu
    ) where
+import Dodge.Config.Data
 import LensHelp
 import Dodge.Menu.OptionType
 import Dodge.StartNewGame
@@ -79,21 +80,28 @@ debugMenu = slTitleOptions
    "OPTIONS:GAMEPLAY"
    debugMenuOptions
 debugMenuOptions :: [MenuOption]
-debugMenuOptions = zipWith ($)
-    [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" 
-    , makeBoolOption debug_noclip "NOCLIP" 
-    , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" 
-    , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" 
-    , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" 
-    , makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return
-    , makeBoolOption debug_pathing "SHOW PATHING" 
-    , makeBoolOption debug_show_sound     "SHOW VISUAL SOUNDS" 
-    , makeBoolOption debug_mouse_position    "SHOW MOUSE POSITION" 
-    , makeBoolOption debug_walls "SHOW WALL INFO"
-    , makeBoolOption debug_remove_LOS "REMOVE LOS"
-    , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS"
-    ]
-    $ map Scancode [4 ..]
+debugMenuOptions = zipWith f [minBound..] $ map Scancode [4..]
+  where
+    f :: DebugBool -> Scancode -> MenuOption
+    f bd = Toggle (return . Just . (config . debug_booleans . at bd %~ toggleJust))
+        (Right . g bd . (^? config . debug_booleans . ix bd))
+    g bd Nothing = (show bd, "FALSE")
+    g bd _       = (show bd, "TRUE")
+--    zipWith ($)
+--    [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" 
+--    , makeBoolOption debug_noclip "NOCLIP" 
+--    , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" 
+--    , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" 
+--    , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" 
+--    , makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return
+--    , makeBoolOption debug_pathing "SHOW PATHING" 
+--    , makeBoolOption debug_show_sound     "SHOW VISUAL SOUNDS" 
+--    , makeBoolOption debug_mouse_position    "SHOW MOUSE POSITION" 
+--    , makeBoolOption debug_walls "SHOW WALL INFO"
+--    , makeBoolOption debug_remove_LOS "REMOVE LOS"
+--    , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS"
+--    ]
+--    $ map Scancode [4 ..]
 gameplayMenu :: ScreenLayer
 gameplayMenu  = slTitleOptions
    "OPTIONS:GAMEPLAY"
@@ -107,7 +107,7 @@ doDrawing pdata u = do
    currentProgram $= Just (_shadProg lwShad)
    uniform (head $  _shadUnis lwShad) $= viewFrom3d
    bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
-    if not (_debug_remove_LOS cfig)
+    if not (debugOn Remove_LOS cfig)
        then glDrawArrays 
            (marshalEPrimitiveMode $ _shadPrim lwShad) 
            0 
@@ -23,5 +23,5 @@ lightsForGloom cfig w = mapMaybe getLS (IM.elems $ _lightSources w)
        lpos = xyV3 $ _lsPos ls
        rad  = _lsRad ls
        extraculltest
-            | _debug_cull_more_lights cfig = True
+            | debugOn Cull_more_lights cfig = True
            | otherwise = isNothing (intersectSegPolyFirst lpos (lpos +.+ rad *.* (normalizeV (cpos -.- lpos))) cbox)
@@ -93,7 +93,7 @@ mcSPic bt = uncurryV translateSPf (_mcPos bt)

 soundPics :: Configuration -> World -> Picture
 soundPics cfig w
-    | _debug_show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w
+    | debugOn Show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w
    | otherwise = []

 soundPic :: Configuration -> World -> Sound -> Picture
@@ -111,7 +111,7 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w

 drawMousePosition :: Configuration -> World -> Picture
 drawMousePosition cfig w
-    | not $ _debug_mouse_position cfig = mempty
+    | not $ debugOn Mouse_position cfig = mempty
    | otherwise
        = setLayer FixedCoordLayer . winScale cfig
            . uncurryV translate p
@@ -124,7 +124,7 @@ drawMousePosition cfig w

 drawWallIDs :: Configuration -> World -> Picture
 drawWallIDs cfig w 
-    | _debug_walls cfig = setLayer FixedCoordLayer 
+    | debugOn Walls_info cfig = setLayer FixedCoordLayer 
        $ foldMap f (_walls w)
    | otherwise = mempty
  where
@@ -140,7 +140,7 @@ drawWallIDs cfig w

 drawPathing :: Configuration -> World -> Picture
 drawPathing cfig w
-    | _debug_pathing cfig 
+    | debugOn Pathing cfig 
        = setLayer DebugLayer $ 
        (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
        <> concatMap dispInc (graphToIncidence gr)
@@ -170,7 +170,7 @@ crDisplayInfo cfig w cr

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

 viewBoundaries :: Configuration -> World -> Picture
 viewBoundaries cfig w
-    | _debug_view_boundaries cfig 
+    | debugOn View_boundaries cfig 
        = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
        <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
    | otherwise = []
@@ -23,7 +23,7 @@ colCrsWalls cfig w = w & creatures %~ fmap (noclipCheck cfig w)

 noclipCheck :: Configuration -> World -> Creature -> Creature
 noclipCheck cfig w c 
-    | _debug_noclip cfig && _crID c == 0 = c -- for noclip
+    | debugOn Noclip cfig && _crID c == 0 = c -- for noclip
    | otherwise = colCrWall w c

 -- no noclip check, so no need for a configuration file
@@ -23,4 +23,8 @@ strictify :: Maybe a -> Maybe' a
 strictify Nothing  = Nothing'
 strictify (Just x) = Just' x

+toggleJust :: Maybe a -> Maybe ()
+toggleJust Nothing = Just ()
+toggleJust _ = Nothing
+
 makeLenses ''Maybe'