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

Remove a lot of IO/maybe cruft

Browse Source
This commit is contained in:
justin
2022-10-30 16:11:30 +00:00
parent 624a4c3bcd
commit 219379393e
9 changed files with 85 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Universe.hs
+5 -5
View File
@@ -49,7 +49,7 @@ data ScreenLayer
= OptionScreen
{ _scTitle :: Universe -> String
, _scOptions :: [MenuOption]
, _scDefaultEff :: Universe -> IO (Maybe Universe)
, _scDefaultEff :: Universe -> Universe
, _scOptionFlag :: OptionScreenFlag
, _scOptionsOffset :: Int
}
@@ -77,20 +77,20 @@ data MenuOptionDisplay
data MenuOption
= Toggle
{ _moEff :: Universe -> IO (Maybe Universe)
{ _moEff :: Universe -> Universe
, _moString :: Universe -> MenuOptionDisplay
, _moKey :: Scancode
}
| Toggle2
{ _moKey1 :: Scancode
, _moEff1 :: Universe -> IO (Maybe Universe)
, _moEff1 :: Universe -> Universe
, _moKey2 :: Scancode
, _moEff2 :: Universe -> IO (Maybe Universe)
, _moEff2 :: Universe -> Universe
, _moString :: Universe -> MenuOptionDisplay
}
| InvisibleToggle
{ _moKey :: Scancode
, _moEff :: Universe -> IO (Maybe Universe)
, _moEff :: Universe -> Universe
}
data IntID a = IntID Int a
src/Dodge/Debug/Terminal.hs
+32 -32
View File
@@ -5,15 +5,15 @@ module Dodge.Debug.Terminal where
import Dodge.Item.Location.Initialize
import Control.Applicative
import Control.Lens
import Control.Monad
import Data.List
--import Control.Monad
--import Data.List
import Data.Maybe
import qualified Data.Text as T
import Dodge.Creature
import Dodge.Data.Universe
import Dodge.Inventory.Add
import Dodge.Item
import Dodge.Menu.PushPop
--import Dodge.Menu.PushPop
import qualified IntMapHelp as IM
import LensHelp
import MaybeHelp
@@ -75,35 +75,35 @@ applySetTerminalString var = case key' of
val' = readMaybe val :: Maybe Float
key' = if isNothing val' then "" else key
autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
autoCompleteTerminal s _ =
return
. (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
where
(key, val) = getSplitString $ tail s
command_options = case val of
"" -> filter (isInfixOf key) (validTerminalCommands "")
_ -> filter (isInfixOf val) (validTerminalCommands key)
-- basic autocomplete if single option available (or as far as possible)
input_str = case (key, val) of
(_, "") ->
if length command_options == 1
then ">" ++ head command_options ++ " "
else ">" ++ longestCommonPrefix command_options
_ ->
if length command_options == 1
then ">" ++ key ++ " " ++ head command_options ++ " "
else
if null command_options
then s
else ">" ++ key ++ " " ++ longestCommonPrefix command_options
command_options' =
if not (null command_options) && head command_options == key
then validTerminalCommands key
else command_options
--val' = Debug.Trace.trace key tail val
valid_commands = "Options: " ++ intercalate ", " command_options'
--autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
--autoCompleteTerminal s _ =
-- return
-- . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
-- where
-- (key, val) = getSplitString $ tail s
-- command_options = case val of
-- "" -> filter (isInfixOf key) (validTerminalCommands "")
-- _ -> filter (isInfixOf val) (validTerminalCommands key)
-- -- basic autocomplete if single option available (or as far as possible)
-- input_str = case (key, val) of
-- (_, "") ->
-- if length command_options == 1
-- then ">" ++ head command_options ++ " "
-- else ">" ++ longestCommonPrefix command_options
-- _ ->
-- if length command_options == 1
-- then ">" ++ key ++ " " ++ head command_options ++ " "
-- else
-- if null command_options
-- then s
-- else ">" ++ key ++ " " ++ longestCommonPrefix command_options
-- command_options' =
-- if not (null command_options) && head command_options == key
-- then validTerminalCommands key
-- else command_options
--
-- --val' = Debug.Trace.trace key tail val
-- valid_commands = "Options: " ++ intercalate ", " command_options'
getSplitString :: [Char] -> ([Char], [Char])
getSplitString str = case break (== ' ') str of
src/Dodge/Event.hs
+1 -1
View File
@@ -24,7 +24,7 @@ import SDL
handleEvent :: Event -> Universe -> IO (Maybe Universe)
handleEvent e = case eventPayload e of
TextInputEvent tev -> return . Just . handleTextInput (textInputEventText tev)
KeyboardEvent kev -> handleKeyboardEvent kev
KeyboardEvent kev -> return . Just . handleKeyboardEvent kev
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev)
MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev
src/Dodge/Event/Keyboard.hs
+9 -9
View File
@@ -47,9 +47,9 @@ On release, remove scancode from the 'Set' of pressed keys.
On press, adds the scancode, and perhaps applies a direct effect:
see 'handlePressedKeyInGame'.
-}
handleKeyboardEvent :: KeyboardEventData -> Universe -> IO (Maybe Universe)
handleKeyboardEvent :: KeyboardEventData -> Universe -> Universe
handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
Released -> return . Just $ u & uvWorld . input . pressedKeys . at scode .~ Nothing
Released -> u & uvWorld . input . pressedKeys . at scode .~ Nothing
Pressed ->
handlePressedKey
(keyboardEventRepeat kev)
@@ -61,17 +61,17 @@ handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
| otherwise = InitialPress
scode = (keysymScancode . keyboardEventKeysym) kev
handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe)
handlePressedKey True _ u = return $ Just u
handlePressedKey :: Bool -> Scancode -> Universe -> Universe
handlePressedKey True _ u = u
handlePressedKey _ scode u = case scode of
ScancodeF5 -> return . Just $ doQuicksave u
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
ScancodeSemicolon -> return . Just $ gotoTerminal u
ScancodeF5 -> doQuicksave u
ScancodeF9 -> loadSaveSlot QuicksaveSlot u
ScancodeSemicolon -> gotoTerminal u
_ | null (_uvScreenLayers u) -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid)
| inTermFocus (_uvWorld u) ->
return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
_ -> return $ Just u
over uvWorld (handlePressedKeyTerminal tmid scode) u
_ -> u
_ -> handlePressedKeyInMenu (head $ _uvScreenLayers u) scode u
handlePressedKeyTerminal :: Int -> Scancode -> World -> World
src/Dodge/Event/Menu.hs
+6 -7
View File
@@ -8,24 +8,23 @@ import Dodge.Data.Universe
import Dodge.WindowLayout
import SDL
handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe)
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
_ -> return . Just
_ -> id
optionListToEffects ::
(Universe -> IO (Maybe Universe)) ->
(Universe -> Universe) ->
Scancode ->
[MenuOption] ->
Universe ->
IO (Maybe Universe)
Universe
optionListToEffects defaulteff sc mops u = case sc of
ScancodeSpace ->
return . Just
. (uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
(uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
$ u
_ ->
( fromMaybe defaulteff
@@ -40,7 +39,7 @@ optionListToEffects defaulteff sc mops u = case sc of
| otherwise = x
mlines = availableMenuLines $ _uvConfig u
menuOptionToEffects :: MenuOption -> [(Scancode, Universe -> IO (Maybe Universe))]
menuOptionToEffects :: MenuOption -> [(Scancode, Universe -> Universe)]
menuOptionToEffects Toggle{_moKey = k, _moEff = eff} = [(k, eff)]
menuOptionToEffects InvisibleToggle{_moKey = k, _moEff = eff} = [(k, eff)]
menuOptionToEffects
src/Dodge/Menu.hs
+25 -27
View File
@@ -25,20 +25,20 @@ import Data.Maybe
splashMenu :: ScreenLayer
splashMenu =
slTitleOptionsEff "AMNESIS" splashMenuOptions (return . Just)
slTitleOptionsEff "AMNESIS" splashMenuOptions id
& scOptionFlag .~ SplashOptions
splashMenuOptions :: [MenuOption]
splashMenuOptions =
basicKeyOptions
[ Toggle (return . Just . loadSaveSlot (SaveSlotNum 0)) displaycontinue
, Toggle (return . Just . startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
, Toggle (return . Just . reloadLevelStart) (displaywhenseed "NEW WITH LAST SEED")
[ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
, Toggle ( startNewGameInSlot 0) (opText "NEW WITH RANDOM 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 (return . Just) (displaywhenseed "VIEW LAST SEED")
, Toggle (return . const Nothing) (opText "QUIT")
, Toggle (id) (displaywhenseed "VIEW LAST SEED")
, Toggle (id) (opText "QUIT")
]
where
opText = const . MODString
@@ -48,30 +48,27 @@ splashMenuOptions =
| otherwise = MODString str
pauseMenu :: ScreenLayer
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (unpause)
pauseMenuOptions :: [MenuOption]
pauseMenuOptions =
basicKeyOptions
[ Toggle popScreen (opText "CONTINUE")
, Toggle (return . Just . startNewGameInSlot 0) (opText "NEW GAME")
, Toggle (return . Just . reloadLevelStart) (opText "RESTART")
, Toggle (startNewGameInSlot 0) (opText "NEW GAME")
, 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 (return . Just) (opText "VIEW CURRENT SEED")
, Toggle id (opText "VIEW CURRENT SEED")
, Toggle saveQuit (opText "SAVE AND QUIT")
]
++ [ InvisibleToggle ScancodeEscape (return . const Nothing)
++ [ InvisibleToggle ScancodeEscape id
]
where
opText = const . MODString
saveQuit :: Universe -> IO (Maybe Universe)
saveQuit u =
return $
Just $
u & addSideEffect (saveQuitConc u) "SAVING"
saveQuit :: Universe -> Universe
saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING"
saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
saveQuitConc u = do
@@ -83,19 +80,19 @@ seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
seedStartOptions :: [MenuOption]
seedStartOptions =
[ Toggle trySeedFromClipboard (const $ MODString "PASTE NUMBER FROM CLIPBOARD") ScancodeA
[ Toggle (uvIOEffects .~ trySeedFromClipboard) (const $ MODString "PASTE NUMBER FROM CLIPBOARD") ScancodeA
-- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER")
]
trySeedFromClipboard :: Universe -> IO (Maybe Universe)
trySeedFromClipboard :: Universe -> IO Universe
trySeedFromClipboard u = do
mcstr <- getClipboardString
case mcstr >>= readMaybe of
Nothing ->
pushScreen
return $ pushScreen
(seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
(u & uvScreenLayers %~ tail)
Just i -> return . Just $ startSeedGame 0 i u
Just i -> return $ startSeedGame 0 i u
slTitleOptions :: String -> [MenuOption] -> ScreenLayer
slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
@@ -122,13 +119,13 @@ debugMenuOptions :: [MenuOption]
debugMenuOptions =
zipWith
($)
(map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return])
(map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id])
$ map Scancode [4 ..]
where
f :: DebugBool -> Scancode -> MenuOption
f bd =
Toggle
(return . Just . (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")
@@ -182,7 +179,8 @@ soundMenuOptions =
scod2
(change inc stype)
(\w -> MODStringOption str (leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int)))
change g vt uv = sw uv >> return (Just $ uv & uvConfig . vt %~ g)
change g vt uv = uv & uvConfig . vt %~ g
& uvIOEffects .~ \u -> sw uv >> return u
dec x = max 0 (x - 0.1)
inc x = min 1 (x + 0.1)
sw w = setVol (_uvConfig w)
@@ -196,7 +194,7 @@ graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
graphicsMenuOptions :: [MenuOption]
graphicsMenuOptions =
basicKeyOptions
[ makeEnumOption graphics_resolution_factor "RESOLUTION" updateFramebufferSize
[ makeEnumOption graphics_resolution_factor "RESOLUTION" (uvIOEffects .~ updateFramebufferSize)
, makeBoolOption graphics_wall_textured "WALL TEXTURES"
, makeBoolOption graphics_object_shadows "OBJECT SHADOWS"
, makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
@@ -204,7 +202,7 @@ graphicsMenuOptions =
gameOverMenu :: ScreenLayer
gameOverMenu =
slTitleOptionsEff "GAME OVER" pauseMenuOptions (return . Just)
slTitleOptionsEff "GAME OVER" pauseMenuOptions id
& scOptionFlag .~ GameOverOptions
-- OptionScreen
@@ -218,8 +216,8 @@ gameOverMenu =
--charToScode :: Char -> Scancode
--charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
unpause :: Universe -> Maybe Universe
unpause w = Just . resumeSound $ w & uvScreenLayers .~ []
unpause :: Universe -> Universe
unpause w = resumeSound $ w & uvScreenLayers .~ []
displayControls :: ScreenLayer
displayControls = ColumnsScreen (const "CONTROLS") listControls
src/Dodge/Menu/Option.hs
+1 -1
View File
@@ -2,7 +2,7 @@ module Dodge.Menu.Option
where
import Dodge.Data.Universe
slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer
slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> Universe) -> ScreenLayer
slTitleOptionsEff title ops eff =
OptionScreen
{ _scTitle = const title
src/Dodge/Menu/OptionType.hs
+2 -2
View File
@@ -7,12 +7,12 @@ import Dodge.Menu.PushPop
makeBoolOption lns t =
Toggle
(return . Just . (uvConfig . lns #%~ not))
(uvConfig . lns #%~ not)
(\u -> MODStringOption t (show (u ^# uvConfig . lns)))
makeEnumOption lns str sideeff =
Toggle
(\u -> Just <$> sideeff (u & uvConfig . lns #%~ cycleEnum))
(\u -> sideeff (u & uvConfig . lns #%~ cycleEnum))
(\u -> MODStringOption str (show (u ^# uvConfig . lns)))
makeSubmenuOption submenu t = Toggle (pushScreen submenu) (const t)
src/Dodge/Menu/PushPop.hs
+4 -9
View File
@@ -3,14 +3,9 @@ module Dodge.Menu.PushPop where
import Dodge.Data.Universe
import LensHelp
popScreen' :: Universe -> Maybe Universe
popScreen' = Just . (uvScreenLayers %~ tail)
popScreen :: Universe -> Universe
popScreen = uvScreenLayers %~ tail
popScreen :: Universe -> IO (Maybe Universe)
popScreen = return . popScreen'
pushScreen :: ScreenLayer -> Universe -> Universe
pushScreen ml = (uvScreenLayers .:~ ml)
pushScreen' :: ScreenLayer -> Universe -> Maybe Universe
pushScreen' ml = Just . (uvScreenLayers .:~ ml)
pushScreen :: ScreenLayer -> Universe -> IO (Maybe Universe)
pushScreen ml = return . pushScreen' ml