Work on terminals: allow scrolling to get default inputs

This commit is contained in:
2022-06-01 22:22:46 +01:00
parent 0585236a01
commit 0da298bde9
10 changed files with 140 additions and 95 deletions
+20 -8
View File
@@ -137,6 +137,7 @@ data World = World
, _timeFlow :: TimeFlowStatus , _timeFlow :: TimeFlowStatus
, _worldClock :: Int , _worldClock :: Int
, _doubleMouseHammer :: HammerPosition , _doubleMouseHammer :: HammerPosition
, _backspaceTimer :: Int
} }
data HUDElement data HUDElement
@@ -386,22 +387,23 @@ data TerminalParams = NoTerminalParams | TerminalParams
, _termFutureLines :: [TerminalLine] , _termFutureLines :: [TerminalLine]
, _termMaxLines :: Int , _termMaxLines :: Int
, _termTitle :: String , _termTitle :: String
, _termSel :: Maybe Int , _termSel :: Maybe (Int,Int)
, _termOptions :: [(String, World -> World)] -- , _termOptions :: [(String, World -> World)]
, _termInput :: Maybe (T.Text, String -> World -> World) , _termInput :: Maybe T.Text
, _termCommands :: [TerminalCommand]
} }
data TerminalLine data TerminalLine
= TerminalLineDisplay = TerminalLineDisplay
{_tlPause :: Int {_tlPause :: Int
,_tlString :: World -> (String, Color) ,_tlString :: World -> (String, Color)
} }
| TerminalLineChoice -- | TerminalLineChoice
{_tlPause :: Int -- {_tlPause :: Int
,_tlOptions :: [(String,World -> World)] -- ,_tlOptions :: [(String,World -> World)]
} -- }
| TerminalLineInput | TerminalLineInput
{_tlPause :: Int {_tlPause :: Int
,_tlInputFunction :: String -> World -> World ,_tlCommands :: [TerminalCommand]
} }
| TerminalLineEffect | TerminalLineEffect
{_tlPause :: Int {_tlPause :: Int
@@ -1316,6 +1318,15 @@ data CreatureState = CrSt
, _crDropsOnDeath :: CreatureDropType , _crDropsOnDeath :: CreatureDropType
} }
data TerminalCommand = TerminalCommand
{ _tcString :: String
, _tcAlias :: [String]
, _tcHelp :: String
, _tcArgumentType :: Maybe String
, _tcArguments :: World -> [String]
, _tcEffect :: [String] -> World -> Either String World
}
makeLenses ''CreatureState makeLenses ''CreatureState
makeLenses ''Damage makeLenses ''Damage
makeLenses ''DamageEffect makeLenses ''DamageEffect
@@ -1381,3 +1392,4 @@ makeLenses ''RightButtonOptions
makeLenses ''AllocateEquipment makeLenses ''AllocateEquipment
makeLenses ''ActivateEquipment makeLenses ''ActivateEquipment
makeLenses ''EquipParams makeLenses ''EquipParams
makeLenses ''TerminalCommand
+1
View File
@@ -96,6 +96,7 @@ defaultWorld = World
, _rewindWorlds = [] , _rewindWorlds = []
, _timeFlow = NormalTimeFlow , _timeFlow = NormalTimeFlow
, _doubleMouseHammer = HammerUp , _doubleMouseHammer = HammerUp
, _backspaceTimer = 0
} }
youLight :: TempLightSource youLight :: TempLightSource
youLight = youLight =
+32 -10
View File
@@ -12,6 +12,7 @@ Instead we store the events in a set, and deal with the combinations in
module Dodge.Event module Dodge.Event
( handleEvent ( handleEvent
) where ) where
import Dodge.Terminal
import Dodge.Combine import Dodge.Combine
import Dodge.Event.Keyboard import Dodge.Event.Keyboard
--import Dodge.Event.Menu --import Dodge.Event.Menu
@@ -37,6 +38,7 @@ import Data.Maybe
--import Data.List --import Data.List
--import Data.Function (on) --import Data.Function (on)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Text as T
import SDL import SDL
handleEvent :: Event -> Universe -> IO (Maybe Universe) handleEvent :: Event -> Universe -> IO (Maybe Universe)
@@ -92,13 +94,14 @@ handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe
handlePressedMouseButton but w = case (_hudElement (_hud $ _uvWorld w), but) of handlePressedMouseButton but w = case (_hudElement (_hud $ _uvWorld w), but) of
(DisplayCarte,_) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w) (DisplayCarte,_) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
(_,ButtonMiddle) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w) (_,ButtonMiddle) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
( DisplayInventory (DisplayTerminal tp _) , ButtonLeft) ( DisplayInventory (DisplayTerminal _ _) , ButtonLeft)
-> Just $ fromMaybe w -> Just $ over uvWorld doTerminalEffect w
$ do -- ugly -- -> Just $ fromMaybe w
i <- _termSel tp -- $ do -- ugly
f <- _termOptions tp !? i -- i <- _termSel tp
return $ w & uvWorld %~ snd f -- f <- _termOptions tp !? i
-- & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory -- return $ w & uvWorld %~ snd f
---- & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory
( DisplayInventory (CombineInventory mi) , ButtonLeft) ( DisplayInventory (CombineInventory mi) , ButtonLeft)
-> Just $ fromMaybe (w & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory) -> Just $ fromMaybe (w & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory)
$ do -- ugly $ do -- ugly
@@ -147,11 +150,30 @@ wheelEvent y w = case _hudElement $ _hud w of
| otherwise -> w & moveTweakSel yi | otherwise -> w & moveTweakSel yi
DisplayInventory (CombineInventory _) -> w DisplayInventory (CombineInventory _) -> w
& hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi) & hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
DisplayInventory (DisplayTerminal tp _) -> w DisplayInventory (DisplayTerminal tp _)
& hud . hudElement . subInventory . termParams . termSel . _Just | rbDown -> w
%~ ((`mod` length (_termOptions tp)) . subtract yi) & hud . hudElement . subInventory . termParams %~ updatetermsubsel
| otherwise -> w
& hud . hudElement . subInventory . termParams %~ updatetermsel
_ -> w _ -> w
where where
updatetermsel tp = case _termSel tp of
Nothing -> tp & termSel ?~ (0,0)
& termInput . _Just %~ replacewith tp 0
Just (i,_) -> let newi = ((`mod` length (_termCommands tp)) . subtract yi) i
in tp & termSel . _Just .~ (newi,0)
& termInput . _Just %~ replacewith tp newi
updatetermsubsel tp = case _termSel tp of
Nothing -> tp
Just (i,j) -> let newj = (j - yi) `mod` (1 + length (_tcArguments (_termCommands tp !! i) w))
in tp & termSel . _Just .~ (i,newj)
& termInput . _Just %~ replacewith' tp i newj w
replacewith tp newi _ = T.pack (_tcString (_termCommands tp !! newi))
replacewith' tp i j w _ = T.pack $ _tcString tc ++ " " ++ arg-- ++ ((_tcArguments tp) w !! j)
where
arg :: String
arg = (("":(_tcArguments tc w) )!! j)
tc = _termCommands tp !! i
numcombs = length $ combineItemListYou w numcombs = length $ combineItemListYou w
yi = round $ signum y yi = round $ signum y
numLocs = (fst . IM.findMax $ _seenLocations w) + 1 numLocs = (fst . IM.findMax $ _seenLocations w) + 1
+32 -28
View File
@@ -3,7 +3,7 @@ module Dodge.Event.Keyboard
( handleKeyboardEvent ( handleKeyboardEvent
, handleTextInput , handleTextInput
) where ) where
import qualified Data.IntMap.Strict as IM import Dodge.Terminal
import Dodge.Base import Dodge.Base
import Dodge.Combine import Dodge.Combine
import Dodge.Creature.Action import Dodge.Creature.Action
@@ -15,7 +15,10 @@ import Dodge.Menu
import Dodge.Reloading import Dodge.Reloading
import Dodge.Save import Dodge.Save
import LensHelp import LensHelp
--import Color
--import Data.List
import qualified Data.IntMap.Strict as IM
import Data.Maybe import Data.Maybe
import qualified Data.Set as S import qualified Data.Set as S
import SDL import SDL
@@ -26,7 +29,7 @@ import qualified Data.Text as T
-- dealt with elsewhere -- dealt with elsewhere
handleTextInput :: T.Text -> Universe -> IO (Maybe Universe) handleTextInput :: T.Text -> Universe -> IO (Maybe Universe)
handleTextInput text = return . Just . (menuLayers . ix 0 . scInput %~ updateText) handleTextInput text = return . Just . (menuLayers . ix 0 . scInput %~ updateText)
. (uvWorld . hud . hudElement . subInventory . termParams . termInput . _Just . _1 %~ updateText) . (uvWorld . hud . hudElement . subInventory . termParams . termInput . _Just %~ updateText)
where where
updateText s = case T.unpack text of updateText s = case T.unpack text of
";" -> s ";" -> s
@@ -46,29 +49,33 @@ handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
scode = (keysymScancode . keyboardEventKeysym) kev scode = (keysymScancode . keyboardEventKeysym) kev
handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe)
handlePressedKey True _ w = return $ Just w handlePressedKey True ScancodeBackspace u
handlePressedKey _ scode w = case scode of | _backspaceTimer (_uvWorld u) <= 0 = handlePressedKey False ScancodeBackspace u
ScancodeF5 -> return . Just $ doQuicksave w <&> _Just . uvWorld . backspaceTimer .~ 0
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot w | otherwise = return $ Just $ u & uvWorld . backspaceTimer -~ 1
ScancodeSemicolon -> return . Just $ gotoTerminal w handlePressedKey True _ u = return $ Just u
_ | null (_menuLayers w) -> case w ^? uvWorld . hud . hudElement . subInventory . termParams . termInput . _Just of handlePressedKey _ scode u = case scode of
Just {} -> return $ uvWorld (handlePressedKeyTerminal scode) w ScancodeF5 -> return . Just $ doQuicksave u
_ -> return $ uvWorld (handlePressedKeyInGame scode) w ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
_ -> handlePressedKeyInMenu (head $ _menuLayers w) scode w ScancodeSemicolon -> return . Just $ gotoTerminal u
_ | null (_menuLayers u) -> case u ^? uvWorld . hud . hudElement . subInventory . termParams . termInput . _Just of
Just {} -> return $ uvWorld (handlePressedKeyTerminal scode) u
_ -> return $ uvWorld (Just . handlePressedKeyInGame scode) u
_ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
handlePressedKeyInGame :: Scancode -> World -> Maybe World handlePressedKeyInGame :: Scancode -> World -> World
handlePressedKeyInGame scode w = case scode of handlePressedKeyInGame scode w = case scode of
ScancodeEscape -> Just $ pauseGame $ escapeMap w ScancodeEscape -> pauseGame $ escapeMap w
ScancodeSpace -> Just $ spaceAction w ScancodeSpace -> spaceAction w
ScancodeP -> Just $ pauseGame $ escapeMap w ScancodeP -> pauseGame $ escapeMap w
ScancodeF -> Just $ youDropItem w ScancodeF -> youDropItem w
ScancodeM -> Just $ toggleMap w ScancodeM -> toggleMap w
ScancodeR -> Just $ fromMaybe w $ startReloadingWeapon (you w) w ScancodeR -> fromMaybe w $ startReloadingWeapon (you w) w
ScancodeT -> Just $ testEvent w ScancodeT -> testEvent w
ScancodeX -> Just $ w & hud . hudElement %~ toggleTweakInv ScancodeX -> w & hud . hudElement %~ toggleTweakInv
ScancodeC -> Just $ toggleCombineInv w ScancodeC -> toggleCombineInv w
ScancodeI -> Just $ w & hud . hudElement %~ toggleInspectInv ScancodeI -> w & hud . hudElement %~ toggleInspectInv
_ -> Just w _ -> w
handlePressedKeyTerminal :: Scancode -> World -> Maybe World handlePressedKeyTerminal :: Scancode -> World -> Maybe World
@@ -76,16 +83,13 @@ handlePressedKeyTerminal scode w = case scode of
ScancodeEscape -> Just $ w & hud . hudElement . subInventory .~ NoSubInventory ScancodeEscape -> Just $ w & hud . hudElement . subInventory .~ NoSubInventory
ScancodeReturn -> Just $ w & doTerminalEffect ScancodeReturn -> Just $ w & doTerminalEffect
ScancodeBackspace -> Just $ w ScancodeBackspace -> Just $ w
& hud . hudElement . subInventory . termParams . termInput . _Just . _1 %~ doBackspace & hud . hudElement . subInventory . termParams . termInput . _Just %~ doBackspace
& backspaceTimer .~ 5
_ -> Just w _ -> Just w
where where
doBackspace t = case T.unsnoc t of doBackspace t = case T.unsnoc t of
Nothing -> t Nothing -> t
Just (t',_) -> t' Just (t',_) -> t'
doTerminalEffect w' = fromMaybe w' $ do
f <- w' ^? hud . hudElement . subInventory . termParams . termInput . _Just . _2
s <- w' ^? hud . hudElement . subInventory . termParams . termInput . _Just . _1
return $ f (T.unpack s) w'
toggleTweakInv :: HUDElement -> HUDElement toggleTweakInv :: HUDElement -> HUDElement
toggleTweakInv he = case he of toggleTweakInv he = case he of
+7 -6
View File
@@ -165,13 +165,14 @@ updateTerminalLine w = case w ^? hud . hudElement . subInventory . termParams .
Just (TerminalLineEffect _ eff) -> w Just (TerminalLineEffect _ eff) -> w
& hud . hudElement . subInventory . termParams . termFutureLines %~ tail & hud . hudElement . subInventory . termParams . termFutureLines %~ tail
& eff (_subInventory . _hudElement $ _hud w) & eff (_subInventory . _hudElement $ _hud w)
Just (TerminalLineChoice _ ops) -> w -- Just (TerminalLineChoice _ ops) -> w
-- & hud . hudElement . subInventory . termParams . termFutureLines %~ tail
-- & hud . hudElement . subInventory . termParams . termOptions .~ ops
-- & hud . hudElement . subInventory . termParams . termSel ?~ 0
Just (TerminalLineInput _ commands) -> w
& hud . hudElement . subInventory . termParams . termFutureLines %~ tail & hud . hudElement . subInventory . termParams . termFutureLines %~ tail
& hud . hudElement . subInventory . termParams . termOptions .~ ops & hud . hudElement . subInventory . termParams . termInput ?~ T.empty
& hud . hudElement . subInventory . termParams . termSel ?~ 0 & hud . hudElement . subInventory . termParams . termCommands .~ commands
Just (TerminalLineInput _ func) -> w
& hud . hudElement . subInventory . termParams . termFutureLines %~ tail
& hud . hudElement . subInventory . termParams . termInput ?~ (T.empty,func)
-- this looks ugly... -- this looks ugly...
updateCloseObjects :: World -> World updateCloseObjects :: World -> World
+2 -1
View File
@@ -72,8 +72,9 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t
, _termMaxLines = 7 , _termMaxLines = 7
, _termTitle = "ANALYSER" , _termTitle = "ANALYSER"
, _termSel = Nothing , _termSel = Nothing
, _termOptions = [] -- , _termOptions = []
, _termInput = Nothing , _termInput = Nothing
, _termCommands = []
}) })
) )
(\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)) (\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
+3 -2
View File
@@ -58,7 +58,7 @@ termButton = Button
, _btID = 0 , _btID = 0
, _btText = "TERMINAL" , _btText = "TERMINAL"
, _btState = BtOff , _btState = BtOff
, _btTerminalParams = const $ TerminalParams [] [] 10 "TERMINAL" Nothing [] Nothing , _btTerminalParams = const $ TerminalParams [] [] 10 "TERMINAL" Nothing Nothing []
} }
@@ -115,8 +115,9 @@ genTermMessage f = \gp _ -> TerminalParams
,_termMaxLines = 7 ,_termMaxLines = 7
,_termTitle = "TERMINAL" ,_termTitle = "TERMINAL"
,_termSel = Nothing ,_termSel = Nothing
,_termOptions = [] -- ,_termOptions = []
,_termInput = Nothing ,_termInput = Nothing
,_termCommands = []
} }
where where
totermline s = TerminalLineDisplay 0 (const (s,white)) totermline s = TerminalLineDisplay 0 (const (s,white))
+5 -5
View File
@@ -88,13 +88,13 @@ subInventoryDisplay subinv cfig w = case subinv of
[ invHead cfig (_termTitle tp ++ ":T" ++ show tid) [ invHead cfig (_termTitle tp ++ ":T" ++ show tid)
, renderListAt subInvX 60 cfig , renderListAt subInvX 60 cfig
. displayTermInput tp . displayTermInput tp
. (++ (map (\(str,_) -> (str,white)) (_termOptions tp))) -- . (++ map (\(str,_) -> (str,white)) (_termOptions tp))
. reverse . reverse
. take (_termMaxLines tp) . take (_termMaxLines tp)
$ _termDisplayedLines tp <&> ($ w) $ _termDisplayedLines tp <&> ($ w)
, fromMaybe mempty $ do -- , fromMaybe mempty $ do
cursori <- _termSel tp <&> (+ _termMaxLines tp) -- cursori <- _termSel tp <&> (+ _termMaxLines tp)
return $ listCursorNSW subInvX 60 cfig cursori white 15 1 -- return $ listCursorNSW subInvX 60 cfig cursori white 15 1
] ]
CombineInventory mi -> pictures CombineInventory mi -> pictures
[ invHead cfig "COMBINE" [ invHead cfig "COMBINE"
@@ -124,7 +124,7 @@ subInventoryDisplay subinv cfig w = case subinv of
where where
displayTermInput tp = case _termInput tp of displayTermInput tp = case _termInput tp of
Nothing -> id Nothing -> id
Just (s,_) -> (++ [('>':T.unpack s++clockCycle 10 (V.fromList ["_",""]) w,white)]) Just s -> (++ [('>':T.unpack s++clockCycle 10 (V.fromList ["_",""]) w,white)])
closeobjectcursor = case selectedCloseObject w of closeobjectcursor = case selectedCloseObject w of
Nothing -> mempty Nothing -> mempty
Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w) Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w)
+10 -10
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning where module Dodge.Room.Warning where
import Dodge.Terminal
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.Placement.Instance.Terminal import Dodge.Placement.Instance.Terminal
@@ -34,6 +35,7 @@ import Data.Maybe
--import Data.Tree --import Data.Tree
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
--import qualified Data.Text as T
warningRooms :: RandomGen g => Int -> State g (LabSubCompTree Room) warningRooms :: RandomGen g => Int -> State g (LabSubCompTree Room)
@@ -51,7 +53,7 @@ addWarningTerminal outplid = (rmName .++~ "warningTerm-")
where where
outplace = extTrigLitPos outplace = extTrigLitPos
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(\trid -> Just $ set plSpot (rprShift fps) $ putTerminal $ termMessages trid) (Just . set plSpot (rprShift fps) . putTerminal . termMessages)
--termspot = atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)) --termspot = atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))
fps rp rm = case rp ^? rpLinkStatus . rplsChildNum of fps rp rm = case rp ^? rpLinkStatus . rplsChildNum of
Just 0 -> Just 0 ->
@@ -66,15 +68,13 @@ addWarningTerminal outplid = (rmName .++~ "warningTerm-")
then Just (rtpos, rpdir) then Just (rtpos, rpdir)
else Just (ltpos, rpdir) else Just (ltpos, rpdir)
_ -> Nothing _ -> Nothing
termMessages trid = ops trid (genTermMessage $ const ["AVAILABLE COMMANDS:" termMessages trid = ops trid (genTermMessage $ const ["OPEN DOOR?"])
, " QUIT TOGGLE"
, replicate 50 'M'
])
-- <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)]) -- <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)])
ops _ f gw w = f gw w & termFutureLines %~ ops trid f gw w = f gw w & termFutureLines %~
(++ [ TerminalLineInput 0 (const id) ]) (++ [ TerminalLineInput 0 [quitCommand,helpCommand,infoCommand theinfo,commandsCommand,unlockCommand trid]])
unlockCommand trid = singleCommand "OPEN" ["YES","Y"] "OPEN THE CONNECTED DOOR." (toggledoor trid)
-- (++ [ TerminalLineChoice 0 [ ("TOGGLE", toggledoor trid) -- (++ [ TerminalLineChoice 0 [ ("TOGGLE", toggledoor trid)
-- , ("EXIT", id) -- , ("EXIT", id)
-- ]]) -- ]])
--toggledoor trid w' = w' & triggers . ix (fromJust $ _plMID trid) .~ const True toggledoor trid w' = w' & triggers . ix (fromJust $ _plMID trid) .~ const True
theinfo = "DOOR CONTROLABLE BY ENTERING \"OPEN\". THIS TERMINAL CANNOT CLOSE THE DOOR."
+5 -2
View File
@@ -131,8 +131,11 @@ rotateCamera cfig w
| keyr = rotateCameraBy (-0.025) w | keyr = rotateCameraBy (-0.025) w
| otherwise = ifConfigWallRotate cfig w | otherwise = ifConfigWallRotate cfig w
where where
keyl = SDL.ScancodeQ `S.member` _keys w keyl = SDL.ScancodeQ `S.member` _keys w && notAtTerminal w
keyr = SDL.ScancodeE `S.member` _keys w keyr = SDL.ScancodeE `S.member` _keys w && notAtTerminal w
notAtTerminal :: World -> Bool
notAtTerminal w = isNothing $ w ^? hud . hudElement . subInventory . termParams . termInput . _Just
--zoomCamBy :: Float -> World -> World --zoomCamBy :: Float -> World -> World
--zoomCamBy x w = w {_cameraZoom = max (_cameraZoom w + x) 0.01} --zoomCamBy x w = w {_cameraZoom = max (_cameraZoom w + x) 0.01}