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

Move towards inputs in terminal

Browse Source
This commit is contained in:
justin
2022-06-01 14:34:16 +01:00
parent b54864bbda
commit 2cedc1b968
13 changed files with 90 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+8 -2
View File
@@ -57,6 +57,7 @@ import qualified Data.Set as S
import qualified Data.IntSet as IS
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import SDL (Scancode, MouseButton)
type CRUpdate = Creature -> World -> (World -> World, Maybe Creature)
type CRUpdate' = Creature -> World -> (World -> World, Creature)
@@ -225,7 +226,7 @@ data ScreenLayer
, _scColumns :: [(String,String)]
}
| InputScreen
{ _scInput :: String
{ _scInput :: T.Text
, _scFooter :: String
}
| WaitScreen
@@ -378,7 +379,7 @@ data Button = Button
, _btID :: Int
, _btText :: String
, _btState :: ButtonState
, _btTerminalParams :: TerminalParams
, _btTerminalParams :: World -> TerminalParams
}
data TerminalParams = NoTerminalParams | TerminalParams
{ _termDisplayedLines :: [World -> (String,Color)]
@@ -387,6 +388,7 @@ data TerminalParams = NoTerminalParams | TerminalParams
, _termTitle :: String
, _termSel :: Maybe Int
, _termOptions :: [(String, World -> World)]
, _termInput :: Maybe (String, String -> World -> World)
}
data TerminalLine
= TerminalLineDisplay
@@ -397,6 +399,10 @@ data TerminalLine
{_tlPause :: Int
,_tlOptions :: [(String,World -> World)]
}
| TerminalLineInput
{_tlPause :: Int
,_tlInputFunction :: String -> World -> World
}
| TerminalLineEffect
{_tlPause :: Int
,_tlEffect :: SubInventory -> World -> World
src/Dodge/Debug/Terminal.hs
+3 -2
View File
@@ -13,6 +13,7 @@ import Text.Read (readMaybe)
import Data.List --(isPrefixOf, isInfixOf, intercalate)
import Data.Maybe
import LensHelp
import qualified Data.Text as T
--import qualified Debug.Trace
--import Graphics.Rendering.OpenGL.GL.Shaders (validateProgram)
--import Dodge.Data (Universe(Universe))
@@ -52,7 +53,7 @@ applyTerminalString ('s': 'p': 'a': 'w': 'n': ' ': var)
applyTerminalString _ = id
showTerminalError :: String -> String -> Universe -> Universe
showTerminalError cmd s = menuLayers .:~ InputScreen cmd s
showTerminalError cmd s = menuLayers .:~ InputScreen (T.pack cmd) s
applySetTerminalString :: String -> Universe -> Universe
applySetTerminalString [] = id
@@ -71,7 +72,7 @@ applySetTerminalString var = case key' of
autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
autoCompleteTerminal s _ = return .
(popScreen' >=> pushScreen' (InputScreen input_str valid_commands))
(popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
where
(key, val) = getSplitString $ tail s
command_options = case val of
src/Dodge/Default.hs
+1 -1
View File
@@ -247,7 +247,7 @@ defaultButton = Button
, _btID = 0
, _btText = "Button"
, _btState = BtOff
, _btTerminalParams = NoTerminalParams
, _btTerminalParams = const NoTerminalParams
}
defaultPT :: Prop
defaultPT = Projectile
src/Dodge/Event.hs
+2 -2
View File
@@ -41,7 +41,7 @@ import SDL
handleEvent :: Event -> Universe -> IO (Maybe Universe)
handleEvent e = case eventPayload e of
TextInputEvent tev -> handleTextInputEvent tev
TextInputEvent tev -> handleTextInput (textInputEventText tev)
KeyboardEvent kev -> handleKeyboardEvent kev
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
MouseButtonEvent mbev -> return . handleMouseButtonEvent mbev
@@ -98,7 +98,7 @@ handlePressedMouseButton but w = case (_hudElement (_hud $ _uvWorld w), but) of
i <- _termSel tp
f <- _termOptions tp !? i
return $ w & uvWorld %~ snd f
& uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory
-- & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory
( DisplayInventory (CombineInventory mi) , ButtonLeft)
-> Just $ fromMaybe (w & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory)
$ do -- ugly
src/Dodge/Event/Keyboard.hs
+15 -9
View File
@@ -1,7 +1,7 @@
{- | Deals with keyboard events. -}
module Dodge.Event.Keyboard
( handleKeyboardEvent
, handleTextInputEvent
, handleTextInput
) where
import qualified Data.IntMap.Strict as IM
import Dodge.Base
@@ -19,15 +19,21 @@ import LensHelp
import Data.Maybe
import qualified Data.Set as S
import SDL
import Data.Text (unpack)
--import Data.Text (unpack)
import qualified Data.Text as T
handleTextInputEvent :: TextInputEventData -> Universe -> IO (Maybe Universe)
handleTextInputEvent = handleTextInput . unpack . textInputEventText
handleTextInput :: T.Text -> Universe -> IO (Maybe Universe)
handleTextInput text = return . Just . -- case mState of
-- InputScreen {} ->
(menuLayers . ix 0 . scInput %~ updateText)
-- _ -> id
where
updateText s = case T.unpack text of
"\b" -> undefined
_ -> s `T.append` text
handleTextInput :: String -> Universe -> IO (Maybe Universe)
handleTextInput text w
| null (_menuLayers w) = return $ Just w
| otherwise = handleTextInMenu (head $ _menuLayers w) text w
-- | null (_menuLayers w) = return $ Just w
-- | otherwise = handleTextInMenu (head $ _menuLayers w) text w
{- | Handles keyboard press and release.
On release, remove scancode from the 'Set' of pressed keys.
@@ -78,7 +84,7 @@ toggleInspectInv he = case he of
gotoTerminal :: Universe -> Universe
gotoTerminal w = case _menuLayers w of
(InputScreen {} : _) -> w
_ -> w & menuLayers .:~ InputScreen [] "Enter command"
_ -> w & menuLayers .:~ InputScreen T.empty "Enter command"
spaceAction :: World -> World
spaceAction w = case _hudElement $ _hud w of
src/Dodge/Event/Menu.hs
+18 -15
View File
@@ -1,6 +1,6 @@
module Dodge.Event.Menu
( handlePressedKeyInMenu
, handleTextInMenu
-- , handleTextInMenu
) where
import Dodge.Data
import Dodge.Debug.Terminal
@@ -9,17 +9,20 @@ import Dodge.Menu.PushPop
import Data.Maybe
--import Control.Monad
import Control.Lens
--import Control.Lens
import SDL
--import qualified Debug.Trace
import qualified Data.Text as T
handleTextInMenu :: ScreenLayer -> [Char] -> Universe -> IO (Maybe Universe)
handleTextInMenu mState text = return . Just . case mState of
InputScreen {} -> menuLayers . ix 0 . scInput %~ updateText
_ -> id
where
updateText "" = ">"
updateText s = s ++ text
--handleTextInMenu :: ScreenLayer -> T.Text -> Universe -> IO (Maybe Universe)
--handleTextInMenu mState text = return . Just . -- case mState of
---- InputScreen {} ->
-- (menuLayers . ix 0 . scInput %~ updateText)
---- _ -> id
-- where
-- updateText s = case T.unpack text of
-- "\b" -> undefined
-- _ -> s `T.append` text
handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe)
handlePressedKeyInMenu mState scode = case mState of
@@ -30,15 +33,15 @@ handlePressedKeyInMenu mState scode = case mState of
WaitScreen {} -> return . Just
InputScreen s help -> case scode of
ScancodeEscape -> popScreen
ScancodeReturn -> popScreen . applyTerminalString (tail s)
ScancodeTab -> autoCompleteTerminal s help
ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
ScancodeReturn -> popScreen . applyTerminalString (T.unpack s)
ScancodeTab -> autoCompleteTerminal (T.unpack s) help
-- ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
-- text input handled by handleText
_ -> return . Just
where
doBackspace [_] = ['>']
doBackspace (x:xs) = init (x:xs)
doBackspace _ = ['>']
-- doBackspace [_] = ['>']
-- doBackspace (x:xs) = init (x:xs)
-- doBackspace _ = ['>']
optionListToEffects
:: (Universe -> IO (Maybe Universe))
src/Dodge/Inventory.hs
+3
View File
@@ -168,6 +168,9 @@ updateTerminalLine w = case w ^? hud . hudElement . subInventory . termParams .
& hud . hudElement . subInventory . termParams . termFutureLines %~ tail
& hud . hudElement . subInventory . termParams . termOptions .~ ops
& hud . hudElement . subInventory . termParams . termSel ?~ 0
Just (TerminalLineInput _ func) -> w
& hud . hudElement . subInventory . termParams . termFutureLines %~ tail
& hud . hudElement . subInventory . termParams . termInput ?~ ("",func)
-- this looks ugly...
updateCloseObjects :: World -> World
src/Dodge/LevelGen/Switch.hs
+3 -3
View File
@@ -28,7 +28,7 @@ makeButton col eff = Button
, _btID = 0
, _btText = "Button"
, _btState = BtOff
, _btTerminalParams = NoTerminalParams
, _btTerminalParams = const NoTerminalParams
}
where
turnOn bt = bt {_btState = BtNoLabel, _btEvent = const id}
@@ -69,7 +69,7 @@ makeSwitchSPic dswitch effOn effOff = Button
, _btID = 0
, _btText = "SWITCH/"
, _btState = BtOff
, _btTerminalParams = NoTerminalParams
, _btTerminalParams = const NoTerminalParams
}
where
flipSwitch b w = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) click1S Nothing $ w
@@ -104,7 +104,7 @@ makeSwitch col1 col2 effOn effOff = Button
, _btID = 0
, _btText = "SWITCH/"
, _btState = BtOff
, _btTerminalParams = NoTerminalParams
, _btTerminalParams = const NoTerminalParams
}
where
flipSwitch b w = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) click1S Nothing $ w
src/Dodge/Placement/Instance/Analyser.hs
+3 -2
View File
@@ -62,7 +62,7 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t
where
termupdate tp btid = initMCUpdate
(\mc -> buttons . ix btid . btTerminalParams .~
TerminalParams
const (TerminalParams
{ _termDisplayedLines = []
, _termFutureLines =
map simpleline (topFlushStrings allstrings)
@@ -73,7 +73,8 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t
, _termTitle = "ANALYSER"
, _termSel = Nothing
, _termOptions = []
}
, _termInput = Nothing
})
)
(\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
)
src/Dodge/Placement/Instance/Terminal.hs
+12 -20
View File
@@ -25,7 +25,7 @@ putTerminal'
:: Color
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
-> Placement
putTerminal' col mcf = ps0PushPS (PutButton thebutton)
putTerminal' col mcf = ps0PushPS (PutButton termButton)
$ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
{ _mcDraw = noPic . terminalShape col
, _mcHP = 100
@@ -33,20 +33,9 @@ putTerminal' col mcf = ps0PushPS (PutButton thebutton)
, _mcSensor = SensorCloseToggle NotClose False
})
$ const Nothing
where
thebutton = Button
{ _btPict = const mempty
, _btPos = 0
, _btRot = 0
, _btEvent = displayTerminalMessage . _btID
, _btID = 0
, _btText = "TERMINAL"
, _btState = BtOff
, _btTerminalParams = TerminalParams [] [] 10 "TERMINAL" Nothing []
}
putTerminal :: (GenParams -> TerminalParams) -> Placement
putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
putTerminal :: (GenParams -> World -> TerminalParams) -> Placement
putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton termButton)
$ \pl -> Just $ pt0 (PutMachine terminalColor (reverse $ square 10) defaultMachine
{ _mcDraw = noPic . terminalShape terminalColor
, _mcHP = 100
@@ -60,7 +49,8 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
pl & plType . putButton . btTerminalParams .~ f gp
& plGenUpdate .~ Nothing
)
thebutton = Button
termButton :: Button
termButton = Button
{ _btPict = const mempty
, _btPos = 0
, _btRot = 0
@@ -68,9 +58,10 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
, _btID = 0
, _btText = "TERMINAL"
, _btState = BtOff
, _btTerminalParams = TerminalParams [] [] 10 "TERMINAL" Nothing []
, _btTerminalParams = const $ TerminalParams [] [] 10 "TERMINAL" Nothing [] Nothing
}
terminalColor :: Color
terminalColor = dark magenta
@@ -90,10 +81,10 @@ terminalShape col _ = colorSH col (prismPoly
displayTerminalMessage :: Int -> World -> World
displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory DisplayTerminal
{ _termID = btid
, _termParams = fromMaybe NoTerminalParams $ w ^? buttons . ix btid . btTerminalParams
, _termParams = fromMaybe NoTerminalParams $ (w ^? buttons . ix btid . btTerminalParams) <&> ($ w)
}
simpleTermMessage :: [String] -> (GenParams -> TerminalParams)
simpleTermMessage :: [String] -> (GenParams -> World -> TerminalParams)
simpleTermMessage = genTermMessage . const
--simpleTermMessage ss = const $ TerminalParams
-- {_termDisplayedLines = []
@@ -116,8 +107,8 @@ topFlushStrings = topFlush . maximum . map length
topFlush :: Int -> [String]
topFlush twidth = [replicate i ' ' ++ "*" | i <- [0, max 1 $ twidth `div` 5 .. twidth]]
genTermMessage :: (GenParams -> [String]) -> (GenParams -> TerminalParams)
genTermMessage f = \gp -> TerminalParams
genTermMessage :: (GenParams -> [String]) -> (GenParams -> World -> TerminalParams)
genTermMessage f = \gp _ -> TerminalParams
{_termDisplayedLines = []
,_termFutureLines = termSoundLine computerBeepingS
: map totermline (topFlushStrings (f gp) ++ f gp)
@@ -125,6 +116,7 @@ genTermMessage f = \gp -> TerminalParams
,_termTitle = "TERMINAL"
,_termSel = Nothing
,_termOptions = []
,_termInput = Nothing
}
where
totermline s = TerminalLineDisplay 0 (const (s,white))
src/Dodge/Render/HUD.hs
+8 -2
View File
@@ -4,6 +4,7 @@ module Dodge.Render.HUD
) where
import Dodge.Data
import Dodge.Combine
import Dodge.Clock
import Dodge.Base
--import Dodge.Combine.Combinations
import Dodge.Inventory
@@ -15,6 +16,7 @@ import Geometry
import Padding
import ListHelp
import qualified Data.Vector as V
--import Data.Foldable
import Data.Maybe
import qualified Data.IntMap.Strict as IM
@@ -81,9 +83,10 @@ subInventoryDisplay subinv cfig w = case subinv of
, invHead cfig "TWEAK"
, listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
]
DisplayTerminal {_termParams = tp} -> pictures
[ invHead cfig (_termTitle tp)
DisplayTerminal {_termParams = tp,_termID = tid} -> pictures
[ invHead cfig (_termTitle tp ++ ":T" ++ show tid)
, renderListAt subInvX 60 cfig
. displayTermInput tp
. (++ (map (\(str,_) -> (str,white)) (_termOptions tp)))
. reverse
. take (_termMaxLines tp)
@@ -118,6 +121,9 @@ subInventoryDisplay subinv cfig w = case subinv of
]
InspectInventory -> invHead cfig "INSPECT"
where
displayTermInput tp = case _termInput tp of
Nothing -> id
Just (s,_) -> (++ [('>':s++clockCycle 10 (V.fromList ["_",""]) w,white)])
closeobjectcursor = case selectedCloseObject w of
Nothing -> mempty
Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w)
src/Dodge/Render/MenuScreen.hs
+3 -1
View File
@@ -8,12 +8,14 @@ import Picture
import Dodge.Menu
import Padding
import qualified Data.Text as T
menuScreen :: Universe -> ScreenLayer -> Picture
menuScreen w screen = case screen of
OptionScreen {_scTitle = titf, _scOptions = mos}
-> drawOptions w (titf w) mos "Use keys to navigate the menu"
(WaitScreen sf _) -> drawOptions w (sf w) [] ""
(InputScreen inputstr help) -> drawOptions w inputstr [] help
(InputScreen inputstr help) -> drawOptions w ('>':T.unpack inputstr) [] help
(DisplayScreen sd ) -> sd w
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_config w) (titf w) pairs
src/Dodge/Room/Warning.hs
+11 -5
View File
@@ -66,9 +66,15 @@ addWarningTerminal outplid = (rmName .++~ "warningTerm-")
then Just (rtpos, rpdir)
else Just (ltpos, rpdir)
_ -> Nothing
termMessages trid = (genTermMessage $ const ["A","TEST"])
<&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)])
ops trid = [ ("OPEN", triggers . ix (fromJust $ _plMID trid) .~ const True)
, ("LEAVE", id)
]
termMessages trid = ops trid (genTermMessage $ const ["AVAILABLE COMMANDS:"
, " QUIT TOGGLE"
, replicate 50 'M'
])
-- <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)])
ops _ f gw w = f gw w & termFutureLines %~
(++ [ TerminalLineInput 0 (const id) ])
-- (++ [ TerminalLineChoice 0 [ ("TOGGLE", toggledoor trid)
-- , ("EXIT", id)
-- ]])
--toggledoor trid w' = w' & triggers . ix (fromJust $ _plMID trid) .~ const True