Bug tracking in menu key presses

src/Dodge/Event/Menu.hs

@@ -1,5 +1,6 @@
 module Dodge.Event.Menu (
     handlePressedKeyInMenu,
+    optionListToEffects,
 ) where
 
 import Control.Lens
@@ -12,8 +13,6 @@ handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> Universe
 handlePressedKeyInMenu mState scode = case mState of
     OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
         optionListToEffects defeff scode mos
-    --DisplayScreen{} -> popScreen
---    WaitScreen{} -> return . Just
     _ -> id
 
 optionListToEffects ::
@@ -25,7 +24,7 @@ optionListToEffects ::
 optionListToEffects defaulteff sc mops u = case sc of
     ScancodeSpace ->
         (uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
-            $ u
+            u
     _ ->
         ( fromMaybe defaulteff
             . lookup sc

src/Dodge/Menu.hs

@@ -33,12 +33,12 @@ splashMenuOptions =
     basicKeyOptions
         [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
         , Toggle ( startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
-        , Toggle ( reloadLevelStart) (displaywhenseed "NEW WITH LAST SEED")
+        , Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
         , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
         , Toggle (pushScreen optionMenu) (opText "OPTIONS")
         , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
-        , Toggle (id) (displaywhenseed "VIEW LAST SEED")
+        , Toggle id (displaywhenseed "VIEW LAST SEED")
-        , Toggle (id) (opText "QUIT")
+        , Toggle hardQuit  (opText "QUIT")
         ]
   where
     opText = const . MODString
@@ -48,21 +48,21 @@ splashMenuOptions =
         | otherwise = MODString str
 
 pauseMenu :: ScreenLayer
-pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (unpause)
+pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions unpause
 
 pauseMenuOptions :: [MenuOption]
 pauseMenuOptions =
     basicKeyOptions
         [ Toggle popScreen (opText "CONTINUE")
         , Toggle (startNewGameInSlot 0) (opText "NEW GAME")
-        , Toggle (reloadLevelStart) (opText "RESTART")
+        , Toggle reloadLevelStart (opText "RESTART")
         , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
         , Toggle (pushScreen optionMenu) (opText "OPTIONS")
         , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
         , Toggle id (opText "VIEW CURRENT SEED")
         , Toggle saveQuit (opText "SAVE AND QUIT")
         ]
-        ++ [ InvisibleToggle ScancodeEscape id
+        ++ [ InvisibleToggle ScancodeEscape hardQuit
            ]
   where
     opText = const . MODString
@@ -70,6 +70,9 @@ pauseMenuOptions =
 saveQuit :: Universe -> Universe
 saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING"
 
+hardQuit :: Universe -> Universe
+hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
+
 saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
 saveQuitConc u = do
     void $ writeSaveSlot (SaveSlotNum 0) u
@@ -125,7 +128,7 @@ debugMenuOptions =
     f :: DebugBool -> Scancode -> MenuOption
     f bd =
         Toggle
-            ((uvConfig . debug_booleans . at bd %~ toggleJust))
+            (uvConfig . debug_booleans . at bd %~ toggleJust)
             (uncurry MODStringOption . g bd . (^? uvConfig . debug_booleans . ix bd))
     g bd Nothing = (show bd, "False")
     g bd _ = (show bd, "True")

src/Dodge/Menu/PushPop.hs

@@ -7,5 +7,5 @@ popScreen :: Universe -> Universe
 popScreen = uvScreenLayers %~ tail
 
 pushScreen :: ScreenLayer -> Universe -> Universe
-pushScreen ml = (uvScreenLayers .:~ ml)
+pushScreen ml = uvScreenLayers .:~ ml
 

src/Dodge/Update.hs

@@ -6,9 +6,8 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
+import Dodge.Event.Menu
 import Color
-import Dodge.Update.Input
-import Dodge.Update.Scroll
 import Control.Applicative
 import Data.List
 import qualified Data.Map.Strict as M
@@ -49,6 +48,8 @@ import Dodge.TmTm
 import Dodge.TractorBeam.Update
 import Dodge.Update.Camera
 import Dodge.Update.Cloud
+import Dodge.Update.Input
+import Dodge.Update.Scroll
 import Dodge.Update.WallDamage
 import Dodge.WallCreatureCollisions
 import Dodge.WorldEffect
@@ -69,7 +70,7 @@ updateUniverse u =
         . updateUniverseMid
         . updateUseInput
         . over uvWorld (updateCamera cfig)
-        . over (uvWorld . cWorld . cClock) ( + 1)
+        . over (uvWorld . cWorld . cClock) (+ 1)
         $ updateBounds u -- where should this go? next to update camera?
   where
     cfig = u ^. uvConfig
@@ -77,14 +78,19 @@ updateUniverse u =
 updateUseInput :: Universe -> Universe
 updateUseInput u = case u ^? uvScreenLayers . _head of
     Just (InputScreen thetext _) -> doInputScreenInput thetext u
-    Just OptionScreen{} --{_scOptions = mos, _scDefaultEff = defeff} -> u
+--    Just OptionScreen{} -> --{_scOptions = mos, _scDefaultEff = defeff} -> u
-        -> u
+--        u
+--
+    Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
+        foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys)
     Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
-    _ -> M.foldlWithKey' updateKeyInGame u (u ^. uvWorld . input . pressedKeys)
+    _ -> M.foldlWithKey' updateKeyInGame u pkeys
-
+  where
+    pkeys = u ^. uvWorld . input . pressedKeys
 
 updateUniverseLast :: Universe -> Universe
-updateUniverseLast = over uvWorld (input . mouseButtons . each .~ True) -- to determine if the mouse button is held
+updateUniverseLast =
+    over uvWorld (input . mouseButtons . each .~ True) -- to determine if the mouse button is held
         . over uvWorld (input . pressedKeys . each %~ f)
   where
     f LongPress = LongPress
@@ -92,8 +98,7 @@ updateUniverseLast = over uvWorld (input . mouseButtons . each .~ True) -- to de
 
 {- For most menus the only way to change the world is using event handling.  -}
 updateUniverseMid :: Universe -> Universe
-updateUniverseMid u
+updateUniverseMid u = case _uvScreenLayers u of
-    | otherwise = case _uvScreenLayers u of
     (OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
         u & uvWorld
             %~ (
@@ -124,20 +129,21 @@ doTimeScroll' :: Int -> World -> World
 doTimeScroll' smoothing w = case w ^. input . scrollAmount of
     x | x > 1 -> w & scrollTimeBack & cWorld . timeFlow . scrollSmoothing .~ 20
     x | x > 0 -> w & scrollTimeBack & cWorld . timeFlow . scrollSmoothing %~ max 0
-    x | x < (-1) -> w & scrollTimeForward & cWorld .timeFlow . scrollSmoothing .~ negate 20
+    x | x < (-1) -> w & scrollTimeForward & cWorld . timeFlow . scrollSmoothing .~ negate 20
-    x | x < 0 -> w & scrollTimeForward & cWorld .timeFlow . scrollSmoothing %~ min 0
+    x | x < 0 -> w & scrollTimeForward & cWorld . timeFlow . scrollSmoothing %~ min 0
-    _ | smoothing > 0 -> scrollTimeBack w & cWorld .timeFlow . scrollSmoothing -~ 1
+    _ | smoothing > 0 -> scrollTimeBack w & cWorld . timeFlow . scrollSmoothing -~ 1
-    _ | smoothing < 0 -> scrollTimeForward w & cWorld .timeFlow . scrollSmoothing +~ 1
+    _ | smoothing < 0 -> scrollTimeForward w & cWorld . timeFlow . scrollSmoothing +~ 1
     _ -> w
 
 scrollTimeBack :: World -> World
 scrollTimeBack w = case w ^? cWorld . pastWorlds . _head of
     Nothing -> w
-    Just lw -> case w ^?! cWorld .timeFlow . reverseAmount of
+    Just lw -> case w ^?! cWorld . timeFlow . reverseAmount of
-        x | x > 0 ->
+        x
+            | x > 0 ->
                 w & cWorld . pastWorlds %~ tail
-                    & cWorld .timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
+                    & cWorld . timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
-                    & cWorld .timeFlow . reverseAmount -~ 1
+                    & cWorld . timeFlow . reverseAmount -~ 1
                     & cWorld . lWorld .~ lw
                     & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ (x -1)
         _ -> w
@@ -221,7 +227,6 @@ updateWheelEvents w = foldr ($) w (replicate (abs y) (updateWheelEvent (signum y
   where
     y = w ^. input . scrollAmount
 
-
 advanceScrollAmount :: Universe -> Universe
 advanceScrollAmount u =
     u
@@ -231,6 +236,8 @@ advanceScrollAmount u =
 updatePastWorlds :: World -> World
 updatePastWorlds w = w & cWorld . pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
 
+--updatePastWorlds w = w & cWorld . pastWorlds .~ []
+
 moveHammersUp :: Universe -> Universe
 --moveHammersUp = uvWorld . hammers .~ M.empty
 moveHammersUp = uvWorld . input . hammers %~ M.map moveHammerUp
@@ -362,30 +369,30 @@ updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
 updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
 updateIMl' fim fup w = foldl' (flip fup) w (fim w)
 
-
 updateCreatureGroups :: World -> World
 updateCreatureGroups w =
     w & cWorld . lWorld . creatureGroups
         %~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp)
 
-updateObjMapMaybe 
+updateObjMapMaybe ::
-    :: (([a] -> Identity [a]) -> LWorld -> Identity LWorld) 
+    (([a] -> Identity [a]) -> LWorld -> Identity LWorld) ->
-    -> (a -> Maybe a) 
+    (a -> Maybe a) ->
-    -> World 
+    World ->
-    -> World
+    World
 updateObjMapMaybe p f = cWorld . lWorld . p %~ mapMaybe f
 
-updateObjCatMaybes
+updateObjCatMaybes ::
-    :: ALens' LWorld [a] 
+    ALens' LWorld [a] ->
-    -> (World -> a -> (World, Maybe a))
+    (World -> a -> (World, Maybe a)) ->
-    -> World 
+    World ->
-    -> World
+    World
 updateObjCatMaybes p f w = w' & cWorld . lWorld . p #~ catMaybes newxs
   where
     (w', newxs) = mapAccumR f w $ w ^# cWorld . lWorld . p
 
 updateDistortions :: World -> World
 updateDistortions = updateObjMapMaybe distortions updateDistortion
+
 --updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion
 
 updateLightSources :: World -> World