Reify debug booleans

appDodge/Main.hs

@@ -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

src/Dodge/Config/Data.hs

@@ -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_booleans :: S.Set DebugBool  -- consider using Data.BitSet
-    , _debug_remove_LOS     :: Bool
-    , _debug_cull_more_lights :: Bool
     }
   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_booleans = S.singleton Show_ms_frame
-    , _debug_seconds_frame  = True
-    , _debug_noclip         = False
-    , _debug_mouse_position = False
-    , _debug_cr_status      = False
-    , _debug_cr_awareness   = False
-    , _debug_view_boundaries = False
     , _debug_view_clip_bounds = NoRoomClipBoundaries
-    , _debug_pathing    = False
+--    , _debug_show_sound           = False
-    , _debug_walls    = False
+--    , _debug_seconds_frame  = True
-    , _debug_remove_LOS      = False
+--    , _debug_noclip         = False
-    , _debug_cull_more_lights     = 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

src/Dodge/Creature/Picture.hs

@@ -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 

src/Dodge/Debug/Terminal.hs

@@ -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"

src/Dodge/Menu.hs

@@ -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 ($)
+debugMenuOptions = zipWith f [minBound..] $ map Scancode [4..]
-    [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" 
+  where
-    , makeBoolOption debug_noclip "NOCLIP" 
+    f :: DebugBool -> Scancode -> MenuOption
-    , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" 
+    f bd = Toggle (return . Just . (config . debug_booleans . at bd %~ toggleJust))
-    , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" 
+        (Right . g bd . (^? config . debug_booleans . ix bd))
-    , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" 
+    g bd Nothing = (show bd, "FALSE")
-    , makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return
+    g bd _       = (show bd, "TRUE")
-    , makeBoolOption debug_pathing "SHOW PATHING" 
+--    zipWith ($)
-    , makeBoolOption debug_show_sound     "SHOW VISUAL SOUNDS" 
+--    [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" 
-    , makeBoolOption debug_mouse_position    "SHOW MOUSE POSITION" 
+--    , makeBoolOption debug_noclip "NOCLIP" 
-    , makeBoolOption debug_walls "SHOW WALL INFO"
+--    , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" 
-    , makeBoolOption debug_remove_LOS "REMOVE LOS"
+--    , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" 
-    , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS"
+--    , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" 
-    ]
+--    , makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return
-    $ map Scancode [4 ..]
+--    , 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"

src/Dodge/Render.hs

@@ -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 

src/Dodge/Render/Lights.hs

@@ -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)

src/Dodge/Render/ShapePicture.hs

@@ -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 = []

src/Dodge/WallCreatureCollisions.hs

@@ -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

src/MaybeHelp.hs

@@ -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'