From 26b4b77ff6da6c0f21070141409070a59869f5a5 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 30 Dec 2025 19:28:05 +0000 Subject: [PATCH] Fix terminal scrolling --- src/Dodge/Terminal.hs | 76 +++++++++++++++++++++++++++----------- src/Dodge/Update/Scroll.hs | 23 ++++++------ tags | 7 ++-- 3 files changed, 70 insertions(+), 36 deletions(-) diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index 45efd0a7b..6c352928a 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -16,10 +16,11 @@ module Dodge.Terminal ( tlDoEffect, termTextColor, doTabComplete, --- recComFindSuccessor, --- recComFindPredecessor, + recComFindSuccessor, + recComFindPredecessor, recComFindMin, recComFindMax, + recComLookup, ) where import Color @@ -36,7 +37,6 @@ import Dodge.Terminal.Type import Justify import LensHelp import Sound.Data -import Control.Applicative textTerminal :: Terminal textTerminal = defaultTerminal{_tmBootLines = textInputBlurb []} @@ -101,8 +101,8 @@ toggleCommands tm ] ) -helpPara :: [TerminalLine] -helpPara = makeTermPara "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE." +--helpPara :: [TerminalLine] +--helpPara = makeTermPara "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE." quitCommand :: TCommands quitCommand = RCommands . PTE.singleton "QUIT" $ Right [TLine 0 [] TmWdWdPowerDownTerminal] @@ -178,16 +178,35 @@ recComFindMax (RCommands m) = case PTE.findMax m of Just (s,Left m') -> recComFindMax m' & _Just . _1 .:~ s Nothing -> Nothing ---recComFindSuccessor :: [String] -> RecCommands a -> Maybe ([String],a) ---recComFindSuccessor (s:[]) (RCommands m) = case PTE.lookup s m of --- Just (Left rm) -> --- _ -> do --- (s',_) <- PTE.findSuccessor s m & _Just . _1 %~ return ---recComFindSuccessor (s:ss) (RCommands m) --- = do --- Left rm <- PTE.lookup s m --- recComFindSuccessor ss rm -- & _Just . _1 .:~ s ----- fromMaybe (recComFindSuccessor (s:[]) (RCommands m)) $ +recComLookup :: [String] -> RecCommands a -> Maybe a +recComLookup (s:ss) (RCommands t) = do + x <- PTE.lookup s t + case x of + Left m -> recComLookup ss m + Right y -> return y +recComLookup [] _ = Nothing + +-- assumes that the commands are well-formed, i.e. every tree does end in a +-- command +recComFindSuccessor :: [String] -> RecCommands a -> Maybe ([String],a) +recComFindSuccessor (s:ss) (RCommands m) + | Just (Left rm) <- PTE.lookup s m + , Just (ss', x) <- recComFindSuccessor ss rm = Just (s:ss',x) + | otherwise = case PTE.findSuccessor s m of + Just (s',Right x) -> Just ([s'],x) + Just (s',Left rm') -> recComFindMin rm' & _Just . _1 .:~ s' + Nothing -> Nothing +recComFindSuccessor [] rm = recComFindMin rm + +recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a) +recComFindPredecessor (s:ss) (RCommands m) + | Just (Left rm) <- PTE.lookup s m + , Just (ss', x) <- recComFindPredecessor ss rm = Just (s:ss',x) + | otherwise = case PTE.findPredecessor s m of + Just (s',Right x) -> Just ([s'],x) + Just (s',Left rm') -> recComFindMax rm' & _Just . _1 .:~ s' + Nothing -> Nothing +recComFindPredecessor [] _ = Nothing -- --recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a) --recComFindPredecessor (s:ss) (RCommands m) = Nothing @@ -232,14 +251,9 @@ doTabComplete w tm = fromMaybe tm $ do TabMultiComplete ss -> return $ tm & tmStatus .~ TerminalLineRead & tmFutureLines .~ + [TLine 0 [TerminalLineConst (getPromptTM <> s) termTextColor] TmWdId] <> (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s]) - - TabFail -> return tm --- (e,Right x) -> return $ tm & tmStatus . tiText .~ e --- (e,Left ss) -> return $ tm --- & tmStatus .~ TerminalLineRead --- & tmFutureLines .~ (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput e]) -- damageCodeCommand :: TerminalCommand -- damageCodeCommand = @@ -267,7 +281,25 @@ simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs -- list available arguments on function input? terminalReturnEffect :: Int -> World -> World -terminalReturnEffect tmid w = w +terminalReturnEffect tmid w = w + & cWorld . lWorld . terminals . ix tmid %~ terminalReturnLocal w + +terminalReturnLocal :: World -> Terminal -> Terminal +terminalReturnLocal w tm = fromMaybe tm $ do + s <- tm ^? tmStatus . tiText + return $ tm + & tmFutureLines .~ [TLine 0 [TerminalLineConst (getPromptTM <> s) termTextColor] TmWdId] + & case recTabComplete s $ getCommands w tm of + TabMatch x -> (tmStatus .~ TerminalLineRead ) + . (tmFutureLines <>~ (x<>tlSetStatus (TerminalTextInput ""))) + TabComplete e -> tmStatus . tiText <>~ e + TabMultiComplete ss -> + (tmStatus .~ TerminalLineRead) + . ( tmFutureLines <>~ + (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s]) + ) + TabFail -> id + -- fromMaybe w $ do -- tm' <- w ^? cWorld . lWorld . terminals . ix tmid -- let tm = tabComplete w tm' diff --git a/src/Dodge/Update/Scroll.hs b/src/Dodge/Update/Scroll.hs index f451c0b9f..649c5bab2 100644 --- a/src/Dodge/Update/Scroll.hs +++ b/src/Dodge/Update/Scroll.hs @@ -131,19 +131,20 @@ terminalWheelEvent yi tmid w -- | w & has (input . mouseButtons . ix ButtonRight) -- , Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus = -- w & cWorld . lWorld . terminals . ix tmid %~ f --- | Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus = --- w & cWorld . lWorld . terminals . ix tmid %~ f + | Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus = + w & cWorld . lWorld . terminals . ix tmid %~ f | otherwise = w where --- dowrap = if yi > 0 then wrapup else wrapdown --- wrapup s coms = recComFindSuccessor (words s) coms <|> recComFindMin coms --- wrapdown s coms = recComFindPredecessor (words s) coms <|> recComFindMax coms --- f tm = fromMaybe tm $ do --- let coms = getCommands w tm --- x <- tm ^? tmStatus . tiText --- let s = fromMaybe "" $ x ^? to words . ix 0 --- (s', _) <- dowrap s coms --- return $ tm & tmStatus . tiText .~ unwords s' + dowrap = if yi > 0 then wrapup else wrapdown + wrapup s coms = recComFindSuccessor (words s) coms -- <|> recComFindMin coms + wrapdown s coms = recComFindPredecessor (words s) coms -- <|> recComFindMax coms + f tm = fromMaybe tm $ do + let coms = getCommands w tm + x <- tm ^? tmStatus . tiText + let s = fromMaybe "" $ x ^? to words . ix 0 + --(s', _) <- dowrap s coms + (s', _) <- dowrap x coms + return $ tm & tmStatus . tiText .~ unwords s' ---- g tm = fromMaybe tm $ do ---- let coms = getCommands w tm ---- x <- tm ^? tmStatus . tiText diff --git a/tags b/tags index 962b3af82..1f903142f 100644 --- a/tags +++ b/tags @@ -3253,7 +3253,7 @@ doScopeZoom src/Dodge/Update/Scroll.hs 89;" f doSectionSize src/Dodge/DisplayInventory.hs 215;" f doSideEffects appDodge/Main.hs 117;" f doStrategyActions src/Dodge/Creature/ReaderUpdate.hs 172;" f -doTabComplete src/Dodge/Terminal.hs 221;" f +doTabComplete src/Dodge/Terminal.hs 226;" f doTestDrawing src/Dodge/Render.hs 40;" f doTextInputOver src/Dodge/Update/Input/Text.hs 15;" f doTextInputOverUniverse src/Dodge/Update/Input/Text.hs 12;" f @@ -4958,7 +4958,7 @@ shuffleRoomPos src/Dodge/Layout.hs 82;" f shuffleTail src/RandomHelp.hs 59;" f sigmoid src/Dodge/Base.hs 151;" f simpleCrSprings src/Dodge/Update.hs 876;" f -simpleTermMessage src/Dodge/Terminal.hs 260;" f +simpleTermMessage src/Dodge/Terminal.hs 259;" f sineRaisePitchOneSecS src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs 716;" f sineRaisePitchTwoSecS src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs 752;" f singleAmmo src/Dodge/Item/AmmoSlots.hs 64;" f @@ -5145,7 +5145,8 @@ termScreenColor src/Dodge/Terminal/Color.hs 8;" f termSoundLine src/Dodge/Terminal.hs 50;" f termTextColor src/Dodge/Terminal.hs 53;" f terminalLDP src/Dodge/ListDisplayParams.hs 44;" f -terminalReturnEffect src/Dodge/Terminal.hs 264;" f +terminalReturnEffect src/Dodge/Terminal.hs 263;" f +terminalReturnLocal src/Dodge/Terminal.hs 267;" f terminalSPic src/Dodge/Machine/Draw.hs 47;" f terminalScreenGlow src/Dodge/Machine/Update.hs 44;" f terminalShape src/Dodge/Machine/Draw.hs 50;" f