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

Work on terminals

Browse Source
This commit is contained in:
justin
2023-05-03 11:19:47 +01:00
parent 61f88aeb4a
commit ed8d8f0e93
8 changed files with 79 additions and 107 deletions
Download Patch File Download Diff File Expand all files Collapse all files
data/charMaps/charMapVert16Tall.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.7 KiB

After

Width:  |  Height:  |  Size: 4.7 KiB

src/Dodge/Render/HUD.hs
+5 -8
View File
@@ -3,8 +3,8 @@ module Dodge.Render.HUD (
drawHUD, drawHUD,
) where ) where
import Data.Foldable
import Control.Lens import Control.Lens
import Data.Foldable
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe import Data.Maybe
import qualified Data.Vector as V import qualified Data.Vector as V
@@ -203,14 +203,11 @@ displayTerminal :: Int -> Configuration -> LWorld -> Picture
displayTerminal tid cfig w = fromMaybe mempty $ do displayTerminal tid cfig w = fromMaybe mempty $ do
tm <- w ^? terminals . ix tid tm <- w ^? terminals . ix tid
return $ return $
pictures invHead cfig (_tmTitle tm ++ ":T" ++ show tid)
[ invHead cfig (_tmTitle tm ++ ":T" ++ show tid) <> drawSelectionList secondColumnParams cfig (thesellist tm)
, drawSelectionList secondColumnParams cfig (thesellist tm)
]
where where
toselitm (str, col) = SelectionItem [str] 1 True col 0 () toselitm (str, col) = SelectionItem [str] 1 True col 0 ()
thesellist tm = thesellist tm = defaultSelectionList & slItems .~ thelist tm
defaultSelectionList & slItems .~ thelist tm
thelist tm = thelist tm =
map toselitm . displayTermInput tm map toselitm . displayTermInput tm
. reverse . reverse
@@ -218,7 +215,7 @@ displayTerminal tid cfig w = fromMaybe mempty $ do
$ _tmDisplayedLines tm $ _tmDisplayedLines tm
displayTermInput tm = case _tmInput tm of displayTermInput tm = case _tmInput tm of
TerminalInput s hasfoc _ -> (++ [(displayInputText tm s ++ displayBlinkCursor hasfoc, white)]) TerminalInput s hasfoc _ -> (++ [(displayInputText tm s ++ displayBlinkCursor hasfoc, white)])
partcommand tm = fromMaybe "" $ tm ^? tmPartialCommand . _Just partcommand tm = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just
displayInputText tm s displayInputText tm s
| _tmStatus tm == TerminalReady = partcommand tm ++ "> " ++ s | _tmStatus tm == TerminalReady = partcommand tm ++ "> " ++ s
| otherwise = "" | otherwise = ""
src/Dodge/Terminal.hs
+39 -46
View File
@@ -1,6 +1,5 @@
module Dodge.Terminal ( module Dodge.Terminal (
doTerminalCommandEffect, doTerminalCommandEffect,
guardDisconnected,
makeTermLine, makeTermLine,
commandFutureLines, commandFutureLines,
quitCommand, quitCommand,
@@ -46,9 +45,9 @@ basicTerminal =
connectionBlurbLines :: [TerminalLine] -> [TerminalLine] connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
connectionBlurbLines tls = connectionBlurbLines tls =
[ termSoundLine computerBeepingS [ termSoundLine computerBeepingS
, TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) , TerminalLineDisplay 0 (TerminalLineConst "Connecting" termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) , TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) , TerminalLineDisplay 10 (TerminalLineConst "Connected" termTextColor)
] ]
++ tls ++ tls
++ [TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)] ++ [TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)]
@@ -56,18 +55,18 @@ connectionBlurbLines tls =
quitCommand :: TerminalCommand quitCommand :: TerminalCommand
quitCommand = quitCommand =
TerminalCommand TerminalCommand
{ _tcString = "QUIT" { _tcString = "quit"
, _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""] , _tcAlias = ["q", "exit", "x", "shutdown", ""]
, _tcHelp = "DISCONNECTS THE TERMINAL." , _tcHelp = "Disconnects the terminal."
, _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal] , _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal]
} }
helpCommand :: TerminalCommand helpCommand :: TerminalCommand
helpCommand = helpCommand =
TerminalCommand TerminalCommand
{ _tcString = "HELP" { _tcString = "help"
, _tcAlias = ["H", "MAN"] , _tcAlias = ["h", "man"]
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND." , _tcHelp = "Displays help for a specific command."
, _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm , _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm
} }
@@ -77,9 +76,9 @@ getCommandsHelp tm w = foldr f mempty $ getCommands tm
f tc = f tc =
M.insert M.insert
(_tcString tc) (_tcString tc)
( [ makeTermLine "COMMAND:" ( [ makeTermLine "Command:"
, makeColorTermLine commandColor (_tcString tc) , makeColorTermLine commandColor (_tcString tc)
, makeTermLine "ALIASES:" , makeTermLine "Aliases:"
, makeColorTermLine commandColor (unwords (_tcAlias tc)) , makeColorTermLine commandColor (unwords (_tcAlias tc))
] ]
++ case argumentHelp tc tm w of ++ case argumentHelp tc tm w of
@@ -92,18 +91,18 @@ getCommandsHelp tm w = foldr f mempty $ getCommands tm
commandsCommand :: TerminalCommand commandsCommand :: TerminalCommand
commandsCommand = commandsCommand =
TerminalCommand TerminalCommand
{ _tcString = "COMMANDS" { _tcString = "commands"
, _tcAlias = ["COMMAND", "COM"] , _tcAlias = ["command", "com"]
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS." , _tcHelp = "Displays available commands."
, _tcEffect = TerminalCommandEffectCommands , _tcEffect = TerminalCommandEffectCommands
} }
connectionBlurb :: [TerminalLine] connectionBlurb :: [TerminalLine]
connectionBlurb = connectionBlurb =
[ termSoundLine computerBeepingS [ termSoundLine computerBeepingS
, TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) , TerminalLineDisplay 0 (TerminalLineConst "Connecting" termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) , TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor)
, TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) , TerminalLineDisplay 10 (TerminalLineConst "Connected" termTextColor)
, TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady) , TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)
] ]
@@ -173,12 +172,6 @@ argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
-- , _tcEffect = TerminalCommandEffectSingleCommand eff followingLines -- , _tcEffect = TerminalCommandEffectSingleCommand eff followingLines
-- } -- }
guardDisconnected :: Terminal -> World -> World -> World
guardDisconnected tm w w' = case _tmStatus tm of
TerminalOff -> w
TerminalBusy -> w
TerminalReady -> w'
getDamageCoding :: World -> M.Map String [TerminalLine] getDamageCoding :: World -> M.Map String [TerminalLine]
getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld
@@ -195,15 +188,15 @@ getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine]
getSensor f tm w = getSensor f tm w =
maybe maybe
[] []
(makeTermPara . map toUpper . show . f) (makeTermPara . map toLower . show . f)
(w ^? cWorld . lWorld . machines . ix (_tmMachineID tm) . mcType . _McSensor) (w ^? cWorld . lWorld . machines . ix (_tmMachineID tm) . mcType . _McSensor)
toggleCommand :: TerminalCommand toggleCommand :: TerminalCommand
toggleCommand = toggleCommand =
TerminalCommand TerminalCommand
{ _tcString = "TOGGLE" { _tcString = "toggle"
, _tcAlias = ["TOG"] , _tcAlias = ["tog"]
, _tcHelp = "PERFORMS A REVERSABLE EFFECT." , _tcHelp = "Performs a reversable effect."
, _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) , _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
} }
@@ -213,19 +206,19 @@ decodedtmap = M.mapKeys show . M.map ((: []) . makeTermLine . show)
sensorCommand :: TerminalCommand sensorCommand :: TerminalCommand
sensorCommand = sensorCommand =
TerminalCommand TerminalCommand
{ _tcString = "SENSOR" { _tcString = "sensor"
, _tcAlias = ["SEN"] , _tcAlias = ["sen"]
, _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR." , _tcHelp = "Access information concerning the connected sensor."
, _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm , _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm
} }
disconnectTerminal :: Terminal -> World -> World disconnectTerminal :: Terminal -> World -> World
disconnectTerminal tm w = disconnectTerminal tm =
w (cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
& cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff . exitTerminalSubInv
& exitTerminalSubInv . ( cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines
& cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines .~ [TerminalLineTerminalEffect 0 TmTmClearDisplayedLines]
.~ [TerminalLineTerminalEffect 0 TmTmClearDisplayedLines] )
exitTerminalSubInv :: World -> World exitTerminalSubInv :: World -> World
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
@@ -235,9 +228,9 @@ exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
damageCodeCommand :: TerminalCommand damageCodeCommand :: TerminalCommand
damageCodeCommand = damageCodeCommand =
TerminalCommand TerminalCommand
{ _tcString = "DAMAGECODE" { _tcString = "damagecode"
, _tcAlias = ["DCODE", "DC"] , _tcAlias = ["dcode", "dc"]
, _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE." , _tcHelp = "Displays the shape and color associated with a given damage type."
, _tcEffect = TerminalCommandEffectDamageCoding -- \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding , _tcEffect = TerminalCommandEffectDamageCoding -- \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding
} }
@@ -253,21 +246,21 @@ togglesToEffects = fmap f . _tmToggles
where where
f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)] f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
-- \_ -> triggers . ix (_ttTriggerID tt) %~ not]
simpleTermMessage :: [String] -> Terminal simpleTermMessage :: [String] -> Terminal
simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs
commandFutureLines :: String -> Terminal -> World -> [TerminalLine] commandFutureLines :: String -> Terminal -> World -> [TerminalLine]
commandFutureLines s tm w = fromMaybe [errline "^ INVALID COMMAND"] $ do commandFutureLines s tm w = fromMaybe [errline "^ Invalid command"] $ do
(str, args) <- safeUncons $ words s (str, args) <- safeUncons $ words s
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm) command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm)
case doTerminalCommandEffect (_tcEffect command) tm w of case doTerminalCommandEffect (_tcEffect command) tm w of
NoArguments tls -> Just tls NoArguments tls -> Just tls
OneArgument argtype m -> OneArgument argtype m ->
let setpartial = TerminalLineTerminalEffect 0 (TmTmSetPartialCommand (Just str)) let setpartial =
: makeTermPara ("expects " ++ argtype ++ " as an argument") TerminalLineTerminalEffect 0 (TmTmSetPartialCommand (Just str)) :
in Just $ makeTermPara ("expects " ++ argtype ++ " as an argument")
fromMaybe setpartial $ in Just $
safeHead args >>= (m M.!?) fromMaybe setpartial $
safeHead args >>= (m M.!?)
where where
errline = makeColorTermLine red errline = makeColorTermLine red
src/Dodge/Terminal/LeftButton.hs
+12 -25
View File
@@ -1,36 +1,23 @@
module Dodge.Terminal.LeftButton where module Dodge.Terminal.LeftButton (
doTerminalEffectLB,
terminalReturnEffect,
) where
import Control.Monad
import Data.Maybe import Data.Maybe
import Dodge.Data.World import Dodge.Data.World
import Dodge.Terminal--oops import Dodge.Terminal.ReturnEffect
import LensHelp import LensHelp
doTerminalEffectLB :: Terminal -> World -> World doTerminalEffectLB :: Terminal -> World -> World
doTerminalEffectLB tm w = guardDisconnected tm w $ doTerminalEffectLB tm w = fromMaybe w $ do
fromMaybe w $ do guard (_tmStatus tm == TerminalReady)
s <- w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmInput . tiText s <- w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmInput . tiText
if null (words s) if null (words s)
then Just $ defocusTerminalInput w then Just $ defocusTerminalInput w
else return $ terminalReturnEffect tm w else return $ terminalReturnEffect tm w
terminalReturnEffect :: Terminal -> World -> World
terminalReturnEffect tm w = guardDisconnected tm w $
fromMaybe w $ do
s <- w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmInput . tiText
return $
runTerminalString s tm $
w
& cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>' : s)]
defocusTerminalInput :: World -> World defocusTerminalInput :: World -> World
defocusTerminalInput w = fromMaybe w $ do defocusTerminalInput w = fromMaybe w $ do
tmid <- w ^? hud . hudElement . subInventory . termID tmid <- w ^? hud . hudElement . subInventory . termID
return $ w & cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const False return $ w & cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const False
runTerminalString :: String -> Terminal -> World -> World
runTerminalString s tm w =
w & cWorld . lWorld . terminals . ix (_tmID tm)
%~ ( (tmInput .~ TerminalInput mempty True (0, 0))
. (tmFutureLines ++.~ commandFutureLines s tm w)
. (tmCommandHistory %~ take 10 . (s :))
)
src/Dodge/Update/Input/InGame.hs
+2 -4
View File
@@ -90,10 +90,9 @@ updatePressedButtonsCarte' pkeys w
updateKeysInTerminal :: Int -> Universe -> Universe updateKeysInTerminal :: Int -> Universe -> Universe
updateKeysInTerminal tmid u = updateKeysInTerminal tmid u =
u & doTextInputOver tmpoint u & doTextInputOver (uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText)
& checkEndStatus & checkEndStatus
where where
tmpoint = uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText
pkeys = u ^. uvWorld . input . pressedKeys pkeys = u ^. uvWorld . input . pressedKeys
checkEndStatus checkEndStatus
| pkeys ^. at ScancodeReturn == Just InitialPress = | pkeys ^. at ScancodeReturn == Just InitialPress =
@@ -110,7 +109,6 @@ updateInitialPressInGame :: Universe -> Scancode -> Universe
updateInitialPressInGame uv sc = case sc of updateInitialPressInGame uv sc = case sc of
ScancodeF1 -> useNormalCamera uv ScancodeF1 -> useNormalCamera uv
ScancodeF2 -> pauseAndFloatCam uv ScancodeF2 -> pauseAndFloatCam uv
-- ScancodeF3 -> pauseAndPanCam uv
ScancodeF5 -> doQuicksave uv ScancodeF5 -> doQuicksave uv
ScancodeF9 -> doQuickload uv ScancodeF9 -> doQuickload uv
ScancodeEscape -> pauseGame uv ScancodeEscape -> pauseGame uv
@@ -152,7 +150,7 @@ doRegexInput u i sss
any any
((== Just InitialPress) . (`M.lookup` pkeys)) ((== Just InitialPress) . (`M.lookup` pkeys))
[ScancodeReturn, ScancodeSlash] [ScancodeReturn, ScancodeSlash]
endmouse = (Just 0 == ) $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft endmouse = (Just 0 ==) $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft
backspacetonothing = backspacetonothing =
sss ^? sssExtra . sssFilters . ix i . _Just == Just "" sss ^? sssExtra . sssFilters . ix i . _Just == Just ""
&& ScancodeBackspace `M.lookup` pkeys == Just InitialPress && ScancodeBackspace `M.lookup` pkeys == Just InitialPress
src/Dodge/Update/Input/Text.hs
+3 -2
View File
@@ -4,7 +4,7 @@ module Dodge.Update.Input.Text (
) where ) where
import Data.Either import Data.Either
import Data.Char --import Data.Char
import Dodge.Data.Universe import Dodge.Data.Universe
import LensHelp import LensHelp
import SDL import SDL
@@ -14,7 +14,8 @@ doTextInputOver p u = doTextInputOver' u p u
doTextInputOver' :: Universe -> ASetter' a String -> a -> a doTextInputOver' :: Universe -> ASetter' a String -> a -> a
doTextInputOver' u p x = doTextInputOver' u p x =
x & p %~ (++ map toUpper (rights str)) --x & p %~ (++ map toUpper (rights str))
x & p %~ (++ rights str)
& checkBackspace & checkBackspace
where where
str = u ^. uvWorld . input . textInput str = u ^. uvWorld . input . textInput
src/Dodge/WorldEffect.hs
+18 -20
View File
@@ -1,9 +1,9 @@
module Dodge.WorldEffect module Dodge.WorldEffect (
( doWdWd doWdWd,
, accessTerminal accessTerminal,
, doTmWdWd doTmWdWd,
, lineOutputTerminal lineOutputTerminal,
) where ) where
import Data.Foldable import Data.Foldable
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@@ -46,20 +46,20 @@ doItCrWdWd icww = case icww of
ItCrWdItemEffect -> flip itemEffect ItCrWdItemEffect -> flip itemEffect
accessTerminal :: Maybe Int -> World -> World accessTerminal :: Maybe Int -> World -> World
accessTerminal mtmid w = case mtmid of accessTerminal mtmid w = fromMaybe w $ do
Nothing -> w tmid <- mtmid
Just tmid -> return $
w & hud . hudElement . subInventory .~ DisplayTerminal tmid w & hud . hudElement . subInventory .~ DisplayTerminal tmid
& cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus .~ True & cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus .~ True
& cWorld . lWorld . terminals . ix tmid %~ tryToBoot & cWorld . lWorld . terminals . ix tmid %~ tryToBoot
where where
tryToBoot tm = case _tmStatus tm of tryToBoot tm = case _tmStatus tm of
TerminalReady -> tm TerminalReady -> tm
TerminalBusy -> tm TerminalBusy -> tm
TerminalOff -> TerminalOff ->
tm tm
& tmFutureLines .~ doTerminalBootProgram (_tmBootProgram tm) tm w & tmFutureLines .~ doTerminalBootProgram (_tmBootProgram tm) tm w
& tmStatus .~ TerminalBusy & tmStatus .~ TerminalBusy
torqueCr :: Float -> Int -> World -> World torqueCr :: Float -> Int -> World -> World
torqueCr x cid w torqueCr x cid w
@@ -82,9 +82,7 @@ lineOutputTerminal tls =
} }
doDeathTriggers :: Terminal -> World -> World doDeathTriggers :: Terminal -> World -> World
doDeathTriggers tm w = doDeathTriggers tm = cWorld . lWorld . triggers %~ flip (foldl' $ flip doDeathToggle) xs
w
& cWorld . lWorld . triggers %~ flip (foldl' $ flip doDeathToggle) xs
where where
xs = M.elems $ _tmToggles tm xs = M.elems $ _tmToggles tm
src/Picture/Base.hs
-2
View File
@@ -201,7 +201,6 @@ stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..]
text :: String -> Picture text :: String -> Picture
{-# INLINE text #-} {-# INLINE text #-}
--text = translate (-50) (-100) . drawText (10)
text = translate (-50) (-100) . drawText (-10) text = translate (-50) (-100) . drawText (-10)
drawText :: Float -> String -> [Verx] drawText :: Float -> String -> [Verx]
@@ -209,7 +208,6 @@ drawText gap = map f . stringToList gap
where where
f (pos, col, V3 a b c) = Verx pos col [a, b, c, 1] BottomLayer textNum f (pos, col, V3 a b c) = Verx pos col [a, b, c, 1] BottomLayer textNum
line :: [Point2] -> Picture line :: [Point2] -> Picture
{-# INLINE line #-} {-# INLINE line #-}
line = thickLine 1 line = thickLine 1