Fix terminal scrolling
This commit is contained in:
+54
-22
@@ -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'
|
||||
|
||||
+12
-11
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user