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

Partial rethink of terminal text input

Browse Source
This commit is contained in:
justin
2025-08-14 21:48:02 +01:00
parent 5b720cb82c
commit 91d19e7c42
12 changed files with 142 additions and 167 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Terminal.hs
+5 -12
View File
@@ -13,32 +13,25 @@ import qualified Data.Map.Strict as M
import Dodge.Data.WorldEffect
import Dodge.Data.BlBl
data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
data TerminalStatus = TerminalOff | TerminalBusy | TerminalTextInput {_tiText :: String}
-- | TerminalArgumentInput TerminalCommand
deriving Eq
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data TerminalInput = TerminalInput
{ _tiText :: String
, _tiSel :: (Int, Int)
{ --_tiText :: String
_tiSel :: (Int, Int)
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data TerminalBootProgram
= TerminalBootMempty
| TerminalBootLines [TerminalLine]
--deriving (Eq, Show, Read) --, Generic)
--h--deriving (Eq, Show, Read) --Generic, Flat)
data Terminal = Terminal
{ _tmID :: Int
, _tmBootLines :: [TerminalLine]
, _tmButtonID :: Int
, _tmMachineID :: Int
, _tmName :: String
, _tmExternalColor :: Color
, _tmDisplayedLines :: [(String, Color)]
, _tmFutureLines :: [TerminalLine]
, _tmTitle :: String
, _tmInput :: TerminalInput
, _tmScrollCommands :: [TerminalCommand]
, _tmWriteCommands :: [TerminalCommand]
@@ -124,13 +117,13 @@ makeLenses ''TerminalLine
makeLenses ''TerminalToggle
makeLenses ''EffectArguments
makeLenses ''TerminalCommand
makeLenses ''TerminalStatus
concat <$> mapM (deriveJSON defaultOptions)
[ ''TerminalStatus
, ''TerminalInput
, ''TerminalLineString
, ''TmTm
, ''TerminalLine
, ''TerminalBootProgram
, ''TerminalToggle
, ''EffectArguments
, ''TerminalCommandEffect
src/Dodge/Default/Terminal.hs
+2 -4
View File
@@ -13,10 +13,8 @@ defaultTerminal =
, _tmBootLines = []
, _tmButtonID = 0
, _tmMachineID = 0
, _tmName = "TESTTERMINAL"
, _tmDisplayedLines = []
, _tmFutureLines = []
, _tmTitle = "TERMINAL IN LOCATION"
, _tmInput = defaultTerminalInput
, _tmScrollCommands = []
, _tmWriteCommands = []
@@ -31,6 +29,6 @@ defaultTerminal =
defaultTerminalInput :: TerminalInput
defaultTerminalInput =
TerminalInput
{ _tiText = ""
, _tiSel = (0, 0)
{ -- _tiText = ""
_tiSel = (0, 0)
}
src/Dodge/InputFocus.hs
+2 -2
View File
@@ -27,8 +27,8 @@ textInputFocus w = case w ^? hud . hudElement . subInventory of
_ -> Nothing
Just DisplayTerminal{_termID = tmid} -> do
connectionstatus <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus
guard $ connectionstatus == TerminalReady
return $ cWorld . lWorld . terminals . ix tmid . tmInput . tiText
-- guard $ connectionstatus == TerminalTextInput
return $ cWorld . lWorld . terminals . ix tmid . tmStatus . tiText
_ -> Nothing
where
he = w ^. hud . hudElement
src/Dodge/Render/HUD.hs
+10 -7
View File
@@ -365,7 +365,7 @@ drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
tm <- w ^? terminals . ix tid
let tsize = getMaxLinesTM + 1
return $
invHead cfig (_tmTitle tm ++ ":T" ++ show tid)
invHead cfig ("T-" ++ show tid)
<> drawSelectionList secondColumnParams cfig (thesellist tm)
<> color
(withAlpha 0.5 green) -- consider integrating termScreenColor somehow
@@ -380,13 +380,16 @@ drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
. reverse
. take getMaxLinesTM
$ _tmDisplayedLines tm
displayTermInput tm = case _tmInput tm of
TerminalInput{_tiText = s} ->
(++ [(displayInputText tm s ++ [cFilledRect], white)])
displayTermInput tm = case _tmStatus tm of
TerminalOff -> id
TerminalBusy -> (++ [([cFilledRect], white)])
TerminalTextInput s ->
(++ [(getPromptTM ++ s ++ [cFilledRect], white)])
partcommand tm = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
displayInputText tm s
| _tmStatus tm == TerminalReady = partcommand tm ++ getPromptTM ++ s
| otherwise = ""
-- displayInputText tm s
-- | TerminalTextInput <- _tmStatus tm = getPromptTM ++ s
---- | _tmStatus tm == TerminalReady = partcommand tm ++ getPromptTM ++ s
-- | otherwise = ""
-- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w
src/Dodge/Terminal.hs
+9 -16
View File
@@ -18,7 +18,7 @@ module Dodge.Terminal (
) where
import Color
import Control.Monad
--import Control.Monad
import Data.Char
import Data.Foldable
import qualified Data.Map.Strict as M
@@ -37,7 +37,7 @@ basicTerminal =
defaultTerminal
{ _tmDisplayedLines = []
, _tmFutureLines = []
, _tmTitle = "TERMINAL"
-- , _tmTitle = "TERMINAL"
, _tmScrollCommands = [quitCommand]
, _tmWriteCommands = [helpCommand, commandsCommand]
, _tmBootLines = connectionBlurb
@@ -47,12 +47,11 @@ basicTerminal =
connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
connectionBlurbLines tls =
[ termSoundLine computerBeepingS
, TerminalLineDisplay 0 (TerminalLineConst "Connecting" termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "Connected" termTextColor)
, TerminalLineDisplay 0 (TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor)
]
++ tls
++ [TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)]
++ [ TerminalLineDisplay 10 (TerminalLineConst "READY FOR INPUT" termTextColor)]
++ [TerminalLineTerminalEffect 0 (TmTmSetStatus (TerminalTextInput ""))]
quitCommand :: TerminalCommand
quitCommand =
@@ -100,13 +99,7 @@ commandsCommand =
}
connectionBlurb :: [TerminalLine]
connectionBlurb =
[ termSoundLine computerBeepingS
, TerminalLineDisplay 0 (TerminalLineConst "Connecting" termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "Connected" termTextColor)
, TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)
]
connectionBlurb = connectionBlurbLines []
termSoundLine :: SoundID -> TerminalLine
termSoundLine sid = TerminalLineEffect 0 (TmWdWdTermSound sid)
@@ -276,8 +269,8 @@ commandFutureLines s tm w = fromMaybe [errline "^ Invalid command"] $ do
terminalReturnEffect :: Int -> World -> World
terminalReturnEffect tmid w = fromMaybe w $ do
tm <- w ^? cWorld . lWorld . terminals. ix tmid
guard $ _tmStatus tm == TerminalReady
s <- tm ^? tmInput . tiText
-- guard $ _tmStatus tm == TerminalTextInput
s <- tm ^? tmStatus . tiText
let pc = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
return $
runTerminalString (pc ++ s) tm $
@@ -289,7 +282,7 @@ terminalReturnEffect tmid w = fromMaybe w $ do
runTerminalString :: String -> Terminal -> World -> World
runTerminalString s tm w =
w & cWorld . lWorld . terminals . ix (_tmID tm)
%~ ( (tmInput .~ TerminalInput{_tiText = mempty, _tiSel = (0, 0)})
%~ ( (tmInput .~ TerminalInput{ _tiSel = (0, 0)})
. (tmFutureLines ++.~ commandFutureLines s tm w)
. (tmCommandHistory %~ take 10 . (s :))
)
src/Dodge/Terminal/Color.hs
+1 -1
View File
@@ -9,5 +9,5 @@ import Control.Lens
termScreenColor :: Terminal -> Maybe Color
termScreenColor tm = case tm ^. tmStatus of
TerminalOff -> Nothing
TerminalReady -> Just green
TerminalTextInput _ -> Just green
TerminalBusy -> Just white
src/Dodge/Update.hs
+2 -2
View File
@@ -399,8 +399,8 @@ updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of
return $
if isOverTerminalScreen cfig mpos
then fromMaybe NoMouseContext $ do
let s = tm ^. tmInput . tiText
guard $ not (null s) && _tmStatus tm == TerminalReady
let s = tm ^. tmStatus . tiText
guard $ not (null s) -- && _tmStatus tm == TerminalTextInput
return $ OverTerminalReturn tmid
else OverTerminalEscape
src/Dodge/Update/Input/InGame.hs
+1 -1
View File
@@ -383,7 +383,7 @@ updateKeysInTerminal :: Int -> Universe -> Universe
updateKeysInTerminal tmid u =
u
& doTextInputOverUniverse
(uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText)
(uvWorld . cWorld . lWorld . terminals . ix tmid . tmStatus . tiText)
& checkEndStatus
where
checkEndStatus
src/Dodge/Update/Scroll.hs
+3 -3
View File
@@ -124,9 +124,9 @@ moveCombineSel yi =
terminalWheelEvent :: Int -> Int -> World -> World
terminalWheelEvent yi tmid w
| w & has (input . mouseButtons . ix ButtonRight)
, Just TerminalReady <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
, Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
w & cWorld . lWorld . terminals . ix tmid %~ updatetermsubsel
| Just TerminalReady <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
| Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
w & cWorld . lWorld . terminals . ix tmid %~ updatetermsel
| otherwise = w
where
@@ -143,7 +143,7 @@ terminalWheelEvent yi tmid w
setInput i j tm =
tm
& tmInput . tiSel .~ (i, j)
& tmInput . tiText .~ comstr ++ arg
& tmStatus . tiText .~ comstr ++ arg
where
comstr = scrollCommandStrings w tm !! i
tc = scrollCommands tm !! i
src/Dodge/WorldEffect.hs
+2 -7
View File
@@ -57,7 +57,7 @@ accessTerminal mtmid w = fromMaybe w $ do
& cWorld . lWorld . terminals . ix tmid %~ tryToBoot
where
tryToBoot tm = case _tmStatus tm of
TerminalReady -> tm
TerminalTextInput {} -> tm
TerminalBusy -> tm
TerminalOff ->
tm
@@ -76,7 +76,7 @@ lineOutputTerminal tls =
defaultTerminal
{ _tmDisplayedLines = []
, _tmFutureLines = []
, _tmTitle = "TERMINAL"
-- , _tmTitle = "TERMINAL"
, _tmScrollCommands = [quitCommand]
, _tmWriteCommands = [helpCommand, commandsCommand]
, _tmBootLines = connectionBlurbLines tls
@@ -91,11 +91,6 @@ doDeathTriggers tm = cWorld . lWorld . triggers %~ flip (foldl' $ flip doDeathTo
doDeathToggle :: TerminalToggle -> IM.IntMap Bool -> IM.IntMap Bool
doDeathToggle (TerminalToggle trid f) = ix trid %~ doBlBl f
--doTerminalBootProgram :: TerminalBootProgram -> Terminal -> World -> [TerminalLine]
--doTerminalBootProgram tbp = case tbp of
-- TerminalBootMempty -> \_ _ -> []
-- TerminalBootLines ls -> \_ _ -> ls
doTmWdWd :: TmWdWd -> Terminal -> World -> World
doTmWdWd tmwdwd = case tmwdwd of
TmWdId -> const id