From 2cedc1b968fc95e3bd72526f2823c34fa59af912 Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 1 Jun 2022 14:34:16 +0100 Subject: [PATCH] Move towards inputs in terminal --- src/Dodge/Data.hs | 10 +++++-- src/Dodge/Debug/Terminal.hs | 5 ++-- src/Dodge/Default.hs | 2 +- src/Dodge/Event.hs | 4 +-- src/Dodge/Event/Keyboard.hs | 24 ++++++++++------- src/Dodge/Event/Menu.hs | 33 +++++++++++++----------- src/Dodge/Inventory.hs | 3 +++ src/Dodge/LevelGen/Switch.hs | 6 ++--- src/Dodge/Placement/Instance/Analyser.hs | 5 ++-- src/Dodge/Placement/Instance/Terminal.hs | 32 +++++++++-------------- src/Dodge/Render/HUD.hs | 10 +++++-- src/Dodge/Render/MenuScreen.hs | 4 ++- src/Dodge/Room/Warning.hs | 16 ++++++++---- 13 files changed, 90 insertions(+), 64 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 0313b9eb2..e4eb423bb 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -57,6 +57,7 @@ import qualified Data.Set as S import qualified Data.IntSet as IS import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M +import qualified Data.Text as T import SDL (Scancode, MouseButton) type CRUpdate = Creature -> World -> (World -> World, Maybe Creature) type CRUpdate' = Creature -> World -> (World -> World, Creature) @@ -225,7 +226,7 @@ data ScreenLayer , _scColumns :: [(String,String)] } | InputScreen - { _scInput :: String + { _scInput :: T.Text , _scFooter :: String } | WaitScreen @@ -378,7 +379,7 @@ data Button = Button , _btID :: Int , _btText :: String , _btState :: ButtonState - , _btTerminalParams :: TerminalParams + , _btTerminalParams :: World -> TerminalParams } data TerminalParams = NoTerminalParams | TerminalParams { _termDisplayedLines :: [World -> (String,Color)] @@ -387,6 +388,7 @@ data TerminalParams = NoTerminalParams | TerminalParams , _termTitle :: String , _termSel :: Maybe Int , _termOptions :: [(String, World -> World)] + , _termInput :: Maybe (String, String -> World -> World) } data TerminalLine = TerminalLineDisplay @@ -397,6 +399,10 @@ data TerminalLine {_tlPause :: Int ,_tlOptions :: [(String,World -> World)] } + | TerminalLineInput + {_tlPause :: Int + ,_tlInputFunction :: String -> World -> World + } | TerminalLineEffect {_tlPause :: Int ,_tlEffect :: SubInventory -> World -> World diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index b8d430468..656912b65 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -13,6 +13,7 @@ import Text.Read (readMaybe) import Data.List --(isPrefixOf, isInfixOf, intercalate) import Data.Maybe import LensHelp +import qualified Data.Text as T --import qualified Debug.Trace --import Graphics.Rendering.OpenGL.GL.Shaders (validateProgram) --import Dodge.Data (Universe(Universe)) @@ -52,7 +53,7 @@ applyTerminalString ('s': 'p': 'a': 'w': 'n': ' ': var) applyTerminalString _ = id showTerminalError :: String -> String -> Universe -> Universe -showTerminalError cmd s = menuLayers .:~ InputScreen cmd s +showTerminalError cmd s = menuLayers .:~ InputScreen (T.pack cmd) s applySetTerminalString :: String -> Universe -> Universe applySetTerminalString [] = id @@ -71,7 +72,7 @@ applySetTerminalString var = case key' of autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe) autoCompleteTerminal s _ = return . - (popScreen' >=> pushScreen' (InputScreen input_str valid_commands)) + (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands)) where (key, val) = getSplitString $ tail s command_options = case val of diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index c9065ce67..a0d741256 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -247,7 +247,7 @@ defaultButton = Button , _btID = 0 , _btText = "Button" , _btState = BtOff - , _btTerminalParams = NoTerminalParams + , _btTerminalParams = const NoTerminalParams } defaultPT :: Prop defaultPT = Projectile diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 08c223fc3..608f18be4 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -41,7 +41,7 @@ import SDL handleEvent :: Event -> Universe -> IO (Maybe Universe) handleEvent e = case eventPayload e of - TextInputEvent tev -> handleTextInputEvent tev + TextInputEvent tev -> handleTextInput (textInputEventText tev) KeyboardEvent kev -> handleKeyboardEvent kev MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev MouseButtonEvent mbev -> return . handleMouseButtonEvent mbev @@ -98,7 +98,7 @@ handlePressedMouseButton but w = case (_hudElement (_hud $ _uvWorld w), but) of i <- _termSel tp f <- _termOptions tp !? i return $ w & uvWorld %~ snd f - & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory +-- & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory ( DisplayInventory (CombineInventory mi) , ButtonLeft) -> Just $ fromMaybe (w & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory) $ do -- ugly diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index fef47cec5..e0a067e82 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -1,7 +1,7 @@ {- | Deals with keyboard events. -} module Dodge.Event.Keyboard ( handleKeyboardEvent - , handleTextInputEvent + , handleTextInput ) where import qualified Data.IntMap.Strict as IM import Dodge.Base @@ -19,15 +19,21 @@ import LensHelp import Data.Maybe import qualified Data.Set as S import SDL -import Data.Text (unpack) +--import Data.Text (unpack) +import qualified Data.Text as T -handleTextInputEvent :: TextInputEventData -> Universe -> IO (Maybe Universe) -handleTextInputEvent = handleTextInput . unpack . textInputEventText +handleTextInput :: T.Text -> Universe -> IO (Maybe Universe) +handleTextInput text = return . Just . -- case mState of +-- InputScreen {} -> + (menuLayers . ix 0 . scInput %~ updateText) +-- _ -> id + where + updateText s = case T.unpack text of + "\b" -> undefined + _ -> s `T.append` text -handleTextInput :: String -> Universe -> IO (Maybe Universe) -handleTextInput text w - | null (_menuLayers w) = return $ Just w - | otherwise = handleTextInMenu (head $ _menuLayers w) text w +-- | null (_menuLayers w) = return $ Just w +-- | otherwise = handleTextInMenu (head $ _menuLayers w) text w {- | Handles keyboard press and release. On release, remove scancode from the 'Set' of pressed keys. @@ -78,7 +84,7 @@ toggleInspectInv he = case he of gotoTerminal :: Universe -> Universe gotoTerminal w = case _menuLayers w of (InputScreen {} : _) -> w - _ -> w & menuLayers .:~ InputScreen [] "Enter command" + _ -> w & menuLayers .:~ InputScreen T.empty "Enter command" spaceAction :: World -> World spaceAction w = case _hudElement $ _hud w of diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index bb7904c74..72468698e 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -1,6 +1,6 @@ module Dodge.Event.Menu ( handlePressedKeyInMenu - , handleTextInMenu +-- , handleTextInMenu ) where import Dodge.Data import Dodge.Debug.Terminal @@ -9,17 +9,20 @@ import Dodge.Menu.PushPop import Data.Maybe --import Control.Monad -import Control.Lens +--import Control.Lens import SDL --import qualified Debug.Trace +import qualified Data.Text as T -handleTextInMenu :: ScreenLayer -> [Char] -> Universe -> IO (Maybe Universe) -handleTextInMenu mState text = return . Just . case mState of - InputScreen {} -> menuLayers . ix 0 . scInput %~ updateText - _ -> id - where - updateText "" = ">" - updateText s = s ++ text +--handleTextInMenu :: ScreenLayer -> T.Text -> Universe -> IO (Maybe Universe) +--handleTextInMenu mState text = return . Just . -- case mState of +---- InputScreen {} -> +-- (menuLayers . ix 0 . scInput %~ updateText) +---- _ -> id +-- where +-- updateText s = case T.unpack text of +-- "\b" -> undefined +-- _ -> s `T.append` text handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKeyInMenu mState scode = case mState of @@ -30,15 +33,15 @@ handlePressedKeyInMenu mState scode = case mState of WaitScreen {} -> return . Just InputScreen s help -> case scode of ScancodeEscape -> popScreen - ScancodeReturn -> popScreen . applyTerminalString (tail s) - ScancodeTab -> autoCompleteTerminal s help - ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace) + ScancodeReturn -> popScreen . applyTerminalString (T.unpack s) + ScancodeTab -> autoCompleteTerminal (T.unpack s) help +-- ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace) -- text input handled by handleText _ -> return . Just where - doBackspace [_] = ['>'] - doBackspace (x:xs) = init (x:xs) - doBackspace _ = ['>'] +-- doBackspace [_] = ['>'] +-- doBackspace (x:xs) = init (x:xs) +-- doBackspace _ = ['>'] optionListToEffects :: (Universe -> IO (Maybe Universe)) diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index f13ff3ca5..f1d5a8068 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -168,6 +168,9 @@ updateTerminalLine w = case w ^? hud . hudElement . subInventory . termParams . & hud . hudElement . subInventory . termParams . termFutureLines %~ tail & hud . hudElement . subInventory . termParams . termOptions .~ ops & hud . hudElement . subInventory . termParams . termSel ?~ 0 + Just (TerminalLineInput _ func) -> w + & hud . hudElement . subInventory . termParams . termFutureLines %~ tail + & hud . hudElement . subInventory . termParams . termInput ?~ ("",func) -- this looks ugly... updateCloseObjects :: World -> World diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index 4256e136f..0f0437914 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/src/Dodge/LevelGen/Switch.hs @@ -28,7 +28,7 @@ makeButton col eff = Button , _btID = 0 , _btText = "Button" , _btState = BtOff - , _btTerminalParams = NoTerminalParams + , _btTerminalParams = const NoTerminalParams } where turnOn bt = bt {_btState = BtNoLabel, _btEvent = const id} @@ -69,7 +69,7 @@ makeSwitchSPic dswitch effOn effOff = Button , _btID = 0 , _btText = "SWITCH/" , _btState = BtOff - , _btTerminalParams = NoTerminalParams + , _btTerminalParams = const NoTerminalParams } where flipSwitch b w = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) click1S Nothing $ w @@ -104,7 +104,7 @@ makeSwitch col1 col2 effOn effOff = Button , _btID = 0 , _btText = "SWITCH/" , _btState = BtOff - , _btTerminalParams = NoTerminalParams + , _btTerminalParams = const NoTerminalParams } where flipSwitch b w = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) click1S Nothing $ w diff --git a/src/Dodge/Placement/Instance/Analyser.hs b/src/Dodge/Placement/Instance/Analyser.hs index 539ab6fb3..6aa883552 100644 --- a/src/Dodge/Placement/Instance/Analyser.hs +++ b/src/Dodge/Placement/Instance/Analyser.hs @@ -62,7 +62,7 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t where termupdate tp btid = initMCUpdate (\mc -> buttons . ix btid . btTerminalParams .~ - TerminalParams + const (TerminalParams { _termDisplayedLines = [] , _termFutureLines = map simpleline (topFlushStrings allstrings) @@ -73,7 +73,8 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t , _termTitle = "ANALYSER" , _termSel = Nothing , _termOptions = [] - } + , _termInput = Nothing + }) ) (\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)) ) diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index 57d76a3f8..9f67df01c 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/src/Dodge/Placement/Instance/Terminal.hs @@ -25,7 +25,7 @@ putTerminal' :: Color -> (Int -> Machine -> World -> World) -- | machine update, takes button id as input -> Placement -putTerminal' col mcf = ps0PushPS (PutButton thebutton) +putTerminal' col mcf = ps0PushPS (PutButton termButton) $ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine { _mcDraw = noPic . terminalShape col , _mcHP = 100 @@ -33,20 +33,9 @@ putTerminal' col mcf = ps0PushPS (PutButton thebutton) , _mcSensor = SensorCloseToggle NotClose False }) $ const Nothing - where - thebutton = Button - { _btPict = const mempty - , _btPos = 0 - , _btRot = 0 - , _btEvent = displayTerminalMessage . _btID - , _btID = 0 - , _btText = "TERMINAL" - , _btState = BtOff - , _btTerminalParams = TerminalParams [] [] 10 "TERMINAL" Nothing [] - } -putTerminal :: (GenParams -> TerminalParams) -> Placement -putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton) +putTerminal :: (GenParams -> World -> TerminalParams) -> Placement +putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton termButton) $ \pl -> Just $ pt0 (PutMachine terminalColor (reverse $ square 10) defaultMachine { _mcDraw = noPic . terminalShape terminalColor , _mcHP = 100 @@ -60,7 +49,8 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton) pl & plType . putButton . btTerminalParams .~ f gp & plGenUpdate .~ Nothing ) - thebutton = Button +termButton :: Button +termButton = Button { _btPict = const mempty , _btPos = 0 , _btRot = 0 @@ -68,9 +58,10 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton) , _btID = 0 , _btText = "TERMINAL" , _btState = BtOff - , _btTerminalParams = TerminalParams [] [] 10 "TERMINAL" Nothing [] + , _btTerminalParams = const $ TerminalParams [] [] 10 "TERMINAL" Nothing [] Nothing } + terminalColor :: Color terminalColor = dark magenta @@ -90,10 +81,10 @@ terminalShape col _ = colorSH col (prismPoly displayTerminalMessage :: Int -> World -> World displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory DisplayTerminal { _termID = btid - , _termParams = fromMaybe NoTerminalParams $ w ^? buttons . ix btid . btTerminalParams + , _termParams = fromMaybe NoTerminalParams $ (w ^? buttons . ix btid . btTerminalParams) <&> ($ w) } -simpleTermMessage :: [String] -> (GenParams -> TerminalParams) +simpleTermMessage :: [String] -> (GenParams -> World -> TerminalParams) simpleTermMessage = genTermMessage . const --simpleTermMessage ss = const $ TerminalParams -- {_termDisplayedLines = [] @@ -116,8 +107,8 @@ topFlushStrings = topFlush . maximum . map length topFlush :: Int -> [String] topFlush twidth = [replicate i ' ' ++ "*" | i <- [0, max 1 $ twidth `div` 5 .. twidth]] -genTermMessage :: (GenParams -> [String]) -> (GenParams -> TerminalParams) -genTermMessage f = \gp -> TerminalParams +genTermMessage :: (GenParams -> [String]) -> (GenParams -> World -> TerminalParams) +genTermMessage f = \gp _ -> TerminalParams {_termDisplayedLines = [] ,_termFutureLines = termSoundLine computerBeepingS : map totermline (topFlushStrings (f gp) ++ f gp) @@ -125,6 +116,7 @@ genTermMessage f = \gp -> TerminalParams ,_termTitle = "TERMINAL" ,_termSel = Nothing ,_termOptions = [] + ,_termInput = Nothing } where totermline s = TerminalLineDisplay 0 (const (s,white)) diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 0d009553a..9f883cf08 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -4,6 +4,7 @@ module Dodge.Render.HUD ) where import Dodge.Data import Dodge.Combine +import Dodge.Clock import Dodge.Base --import Dodge.Combine.Combinations import Dodge.Inventory @@ -15,6 +16,7 @@ import Geometry import Padding import ListHelp +import qualified Data.Vector as V --import Data.Foldable import Data.Maybe import qualified Data.IntMap.Strict as IM @@ -81,9 +83,10 @@ subInventoryDisplay subinv cfig w = case subinv of , invHead cfig "TWEAK" , listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it) ] - DisplayTerminal {_termParams = tp} -> pictures - [ invHead cfig (_termTitle tp) + DisplayTerminal {_termParams = tp,_termID = tid} -> pictures + [ invHead cfig (_termTitle tp ++ ":T" ++ show tid) , renderListAt subInvX 60 cfig + . displayTermInput tp . (++ (map (\(str,_) -> (str,white)) (_termOptions tp))) . reverse . take (_termMaxLines tp) @@ -118,6 +121,9 @@ subInventoryDisplay subinv cfig w = case subinv of ] InspectInventory -> invHead cfig "INSPECT" where + displayTermInput tp = case _termInput tp of + Nothing -> id + Just (s,_) -> (++ [('>':s++clockCycle 10 (V.fromList ["_",""]) w,white)]) closeobjectcursor = case selectedCloseObject w of Nothing -> mempty Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w) diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 2d80cd48a..bfae181aa 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -8,12 +8,14 @@ import Picture import Dodge.Menu import Padding +import qualified Data.Text as T + menuScreen :: Universe -> ScreenLayer -> Picture menuScreen w screen = case screen of OptionScreen {_scTitle = titf, _scOptions = mos} -> drawOptions w (titf w) mos "Use keys to navigate the menu" (WaitScreen sf _) -> drawOptions w (sf w) [] "" - (InputScreen inputstr help) -> drawOptions w inputstr [] help + (InputScreen inputstr help) -> drawOptions w ('>':T.unpack inputstr) [] help (DisplayScreen sd ) -> sd w (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_config w) (titf w) pairs diff --git a/src/Dodge/Room/Warning.hs b/src/Dodge/Room/Warning.hs index dac6989d9..917f1bde7 100644 --- a/src/Dodge/Room/Warning.hs +++ b/src/Dodge/Room/Warning.hs @@ -66,9 +66,15 @@ addWarningTerminal outplid = (rmName .++~ "warningTerm-") then Just (rtpos, rpdir) else Just (ltpos, rpdir) _ -> Nothing - termMessages trid = (genTermMessage $ const ["A","TEST"]) - <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)]) - ops trid = [ ("OPEN", triggers . ix (fromJust $ _plMID trid) .~ const True) - , ("LEAVE", id) - ] + termMessages trid = ops trid (genTermMessage $ const ["AVAILABLE COMMANDS:" + , " QUIT TOGGLE" + , replicate 50 'M' + ]) +-- <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)]) + ops _ f gw w = f gw w & termFutureLines %~ + (++ [ TerminalLineInput 0 (const id) ]) +-- (++ [ TerminalLineChoice 0 [ ("TOGGLE", toggledoor trid) +-- , ("EXIT", id) +-- ]]) + --toggledoor trid w' = w' & triggers . ix (fromJust $ _plMID trid) .~ const True