diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 9d24bec9e..269244dc6 100644 --- a/src/Dodge/Event/Menu.hs +++ b/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 :: @@ -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 diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index fd7410ae0..6a278f8e4 100644 --- a/src/Dodge/Menu.hs +++ b/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) (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") diff --git a/src/Dodge/Menu/PushPop.hs b/src/Dodge/Menu/PushPop.hs index 7fad6cb9c..de6d9f2f8 100644 --- a/src/Dodge/Menu/PushPop.hs +++ b/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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 70e5d7302..da667db65 100644 --- a/src/Dodge/Update.hs +++ b/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 @@ -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 =