From 988a0de5787fdb22c7cac2ef9746ad79d852f536 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 20 Mar 2022 19:41:40 +0000 Subject: [PATCH] Cleanup console input slightly --- src/Dodge/Data.hs | 6 ++++- src/Dodge/Debug/Terminal.hs | 7 +----- src/Dodge/Event/Keyboard.hs | 2 +- src/Dodge/Event/Menu.hs | 46 +++++++++++++++------------------- src/Dodge/Menu.hs | 2 +- src/Dodge/Render/MenuScreen.hs | 17 ++++++++----- 6 files changed, 39 insertions(+), 41 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b6ab4c1b9..6c60b996e 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -173,7 +173,10 @@ data ScreenLayer , _scDefaultEff :: Universe -> IO (Maybe Universe) , _scOptionFlag :: OptionScreenFlag } - | ColumnsScreen String [(String,String)] + | ColumnsScreen + { _scTitle :: Universe -> String + , _scColumns :: [(String,String)] + } | InputScreen { _scInput :: String , _scFooter :: String @@ -1031,3 +1034,4 @@ makeLenses ''SubInventory makeLenses ''TerminalParams makeLenses ''TerminalLine makeLenses ''ItemValue +makeLenses ''ScreenLayer diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index ac265d473..c7d18cf33 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -87,12 +87,7 @@ getSplitString str = case break (==' ') str of (a, _) -> (a, "") isValidCommand :: String -> String -> Bool -isValidCommand arg1 arg2 - | arg2 `elem` v = True - | otherwise = False - where - v = validTerminalCommands arg1 - +isValidCommand arg1 arg2 = arg2 `elem` validTerminalCommands arg1 validTerminalCommands :: String -> [String] validTerminalCommands "set" = ["hp", "invcap", "invsel", "mass", "mvspeed"] diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index f77465201..7b4b6e6b7 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -27,7 +27,7 @@ handleTextInputEvent tev = handleTextInput text text = unpack $ textInputEventText tev handleTextInput :: String -> Universe -> IO (Maybe Universe) -handleTextInput text w +handleTextInput text w | null (_menuLayers w) = return $ Just w | otherwise = handleTextInMenu (head $ _menuLayers w) text w diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index f73cd4850..327d31c53 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -9,23 +9,18 @@ import Dodge.Debug.Terminal import Dodge.Menu.PushPop import Data.Maybe -import Control.Monad ---import Control.Lens +--import Control.Monad +import Control.Lens import SDL -import Control.Lens ((%~)) --import qualified Debug.Trace - handleTextInMenu :: ScreenLayer -> [Char] -> Universe -> IO (Maybe Universe) -handleTextInMenu mState text = case mState of - InputScreen s help -> return . (popScreen' >=> pushScreen' (InputScreen new_text help)) - where - new_text - -- Text events occur after key events so ignore the first - -- (key that opened the terminal menu) - | s == "" = ">" - | otherwise = s ++ text - _ -> return . Just +handleTextInMenu mState text = return . Just . case mState of + InputScreen {} -> menuLayers . ix 0 . scInput %~ updateText + _ -> id + where + updateText "" = ">" + updateText s = s ++ text handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKeyInMenu mState scode = case mState of @@ -35,23 +30,22 @@ handlePressedKeyInMenu mState scode = case mState of ColumnsScreen {} -> popScreen WaitScreen {} -> return . Just InputScreen s help -> case scode of - ScancodeEscape -> popScreen - -- Remove the menu layer (we readd it in applyTerminalString if the commmand fails) - ScancodeReturn -> return. Just . applyTerminalString (tail s) . (menuLayers %~ tail) - ScancodeTab -> autoCompleteTerminal s help - ScancodeBackspace - -> return . (popScreen' >=> pushScreen' (InputScreen (dropLast s) "Enter command")) - -- Ignore (text input now handled by handleText) - _ -> return . (popScreen' >=> pushScreen' (InputScreen s help)) + ScancodeEscape -> popScreen + ScancodeReturn -> popScreen . applyTerminalString (tail s) + ScancodeTab -> autoCompleteTerminal s help + ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace) + -- text input handled by handleText + _ -> return . Just where - dropLast [_] = ['>'] - dropLast (x:xs) = init (x:xs) - dropLast _ = ['>'] + doBackspace [_] = ['>'] + doBackspace (x:xs) = init (x:xs) + doBackspace _ = ['>'] optionListToEffects :: [MenuOption] -> (Universe -> IO (Maybe Universe)) -> Scancode -> Universe -> IO (Maybe Universe) -optionListToEffects mos defaulteff sc = fromMaybe defaulteff . - lookup sc $ concatMap menuOptionToEffects mos +optionListToEffects mos defaulteff sc = fromMaybe defaulteff + . lookup sc + $ concatMap menuOptionToEffects mos menuOptionToEffects :: MenuOption -> [(Scancode,Universe -> IO (Maybe Universe))] menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)] diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 36c8a1286..7d772a36d 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -151,7 +151,7 @@ unpause :: Universe -> Maybe Universe unpause w = Just . resumeSound $ w & menuLayers .~ [] displayControls :: ScreenLayer -displayControls = ColumnsScreen "CONTROLS" listControls +displayControls = ColumnsScreen (const "CONTROLS") listControls listControls :: [(String,String)] listControls = diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index f0ab6409a..5d9037ff5 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -15,7 +15,7 @@ menuScreen w screen = case screen of (WaitScreen sf _) -> drawOptions w (sf w) [] "" (InputScreen inputstr help) -> drawOptions w inputstr [] help (DisplayScreen sd ) -> sd w - (ColumnsScreen title pairs) -> drawTwoColumnsScreen (_config w) title pairs + (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_config w) (titf w) pairs --displayStringList :: World -> [String] -> Picture --displayStringList w ss = pictures @@ -37,8 +37,7 @@ drawTwoColumnsScreen cfig title lps = pictures drawTwoColumns :: Configuration -> [(String,String)] -> Picture drawTwoColumns cfig lps = pictures $ zipWith f [hh-100,hh-130..] lps where - f y (s1,s2) = translate (50-hw) y $ sc $ rightPad ln '.' s1 ++ s2 - sc = scale 0.15 0.15 . color white . text + f y (s1,s2) = placeString (50-hw) y 0.15 $ rightPad ln '.' s1 ++ s2 hh = halfHeight cfig hw = halfWidth cfig ln = maximum (map (length . fst) lps) + 3 @@ -61,7 +60,6 @@ drawOptions u title ops footer = pictures $ ops' = filter notInvisible ops notInvisible InvisibleToggle {} = False notInvisible _ = True - placeString x y sc t = translate x y $ scale sc sc $ color white $ text t hh = halfHeight cfig hw = halfWidth cfig cfig = _config u @@ -72,12 +70,19 @@ darkenBackground = color (withAlpha 0.5 black) . polygon . screenBox drawTitle :: Configuration -> String -> Picture drawTitle cfig = placeString (-hw + 30) (hh - 50) 0.4 where - placeString x y sc t = translate x y $ scale sc sc $ color white $ text t hh = halfHeight cfig hw = halfWidth cfig +placeString + :: Float -- | x distance from center + -> Float -- | y distance from center + -> Float -- | scale + -> String + -> Picture +placeString x y sc = color white . translate x y . scale sc sc . text + drawFooterText :: Configuration -> Color -> String -> Picture -drawFooterText cfig col = translate (-hw + 30) (-hh+10) . scale 0.1 0.1 . color col . text +drawFooterText cfig col = color col . placeString (-hw + 30) (-hh+10) 0.1 where hh = halfHeight cfig hw = halfWidth cfig