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

Bug tracking in menu key presses

Browse Source
This commit is contained in:
justin
2022-10-30 17:37:53 +00:00
parent 219379393e
commit 82c4b992b0
4 changed files with 69 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Event/Menu.hs
+3 -4
View File
@@ -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 ::
@@ -24,8 +23,8 @@ optionListToEffects ::
Universe
optionListToEffects defaulteff sc mops u = case sc of
ScancodeSpace ->
(uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
$ u
(uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
u
_ ->
( fromMaybe defaulteff
. lookup sc
src/Dodge/Menu.hs
+10 -7
View File
@@ -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) (opText "QUIT")
, Toggle id (displaywhenseed "VIEW LAST SEED")
, 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
+1 -1
View File
@@ -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
+55 -48
View File
@@ -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
@@ -63,13 +64,13 @@ import Sound.Data
import StrictHelp
updateUniverse :: Universe -> Universe
updateUniverse u =
updateUniverseLast
. over (uvWorld . input . textInput) (const mempty)
. updateUniverseMid
updateUniverse u =
updateUniverseLast
. over (uvWorld . input . textInput) (const mempty)
. 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,34 +78,38 @@ 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
-> u
-- Just OptionScreen{} -> --{_scOptions = mos, _scDefaultEff = defeff} -> 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
. over uvWorld (input . pressedKeys . each %~ f)
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
f _ = ShortPress
{- For most menus the only way to change the world is using event handling. -}
updateUniverseMid :: Universe -> Universe
updateUniverseMid u
| otherwise = case _uvScreenLayers u of
(OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
u & uvWorld
%~ (
--updateParticles
(cWorld . lWorld . radarBlips .~ [])
-- . updateIMl _props _pjUpdate
. updateLightSources
. updateClouds
)
(_ : _) -> u
[] -> functionalUpdate'' u
updateUniverseMid u = case _uvScreenLayers u of
(OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
u & uvWorld
%~ (
--updateParticles
(cWorld . lWorld . radarBlips .~ [])
-- . updateIMl _props _pjUpdate
. updateLightSources
. updateClouds
)
(_ : _) -> u
[] -> functionalUpdate'' u
functionalUpdate'' :: Universe -> Universe
functionalUpdate'' = advanceScrollAmount . functionalUpdate'
@@ -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 < 0 -> w & scrollTimeForward & cWorld .timeFlow . scrollSmoothing %~ min 0
_ | smoothing > 0 -> scrollTimeBack w & cWorld .timeFlow . scrollSmoothing -~ 1
_ | smoothing < 0 -> scrollTimeForward w & cWorld .timeFlow . scrollSmoothing +~ 1
x | x < (-1) -> w & scrollTimeForward & cWorld . timeFlow . scrollSmoothing .~ negate 20
x | x < 0 -> w & scrollTimeForward & cWorld . timeFlow . scrollSmoothing %~ min 0
_ | smoothing > 0 -> scrollTimeBack 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
x | x > 0 ->
Just lw -> case w ^?! cWorld . timeFlow . reverseAmount of
x
| x > 0 ->
w & cWorld . pastWorlds %~ tail
& cWorld .timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
& cWorld .timeFlow . reverseAmount -~ 1
& cWorld . timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
& 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
:: (([a] -> Identity [a]) -> LWorld -> Identity LWorld)
-> (a -> Maybe a)
-> World
-> World
updateObjMapMaybe ::
(([a] -> Identity [a]) -> LWorld -> Identity LWorld) ->
(a -> Maybe a) ->
World ->
World
updateObjMapMaybe p f = cWorld . lWorld . p %~ mapMaybe f
updateObjCatMaybes
:: ALens' LWorld [a]
-> (World -> a -> (World, Maybe a))
-> World
-> World
updateObjCatMaybes ::
ALens' LWorld [a] ->
(World -> a -> (World, Maybe a)) ->
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
@@ -416,7 +423,7 @@ updateFlames :: World -> World
updateFlames = updateObjCatMaybes flames moveFlame
updateEnergyBalls :: World -> World
updateEnergyBalls = updateObjCatMaybes energyBalls moveEnergyBall
updateEnergyBalls = updateObjCatMaybes energyBalls moveEnergyBall
updateRadarSweeps :: World -> World
updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep
@@ -439,7 +446,7 @@ updateBeams w =
& cWorld . lWorld . beams .~ thebeams
& combineBeams thebeams
where
thebeams = w ^. cWorld . lWorld . newBeams
thebeams = w ^. cWorld . lWorld . newBeams
combineBeams :: WorldBeams -> World -> World
combineBeams wbeams w =