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

Refactor text input

Browse Source
This commit is contained in:
justin
2022-10-30 11:57:53 +00:00
parent 9779b6fa39
commit 6123795c7a
7 changed files with 49 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Input.hs
+1 -5
View File
@@ -28,11 +28,8 @@ data Input = Input
, _lSelect :: Point2
, _rSelect :: Point2
, _clickMousePos :: Point2
, _backspaceTimer :: Int
, _textInput :: TextInput
, _textInput :: T.Text
}
data TextInput = RejectTextInput
| AcceptTextInput {_textInputText :: T.Text}
data WorldHammer
= SubInvHam
@@ -40,4 +37,3 @@ data WorldHammer
deriving (Eq, Ord, Show, Read, Enum, Bounded)
makeLenses ''Input
makeLenses ''TextInput
src/Dodge/Default/World.hs
+1 -2
View File
@@ -12,7 +12,7 @@ import System.Random
defaultInput :: Input
defaultInput = Input
{ _clickMousePos = V2 0 0
, _textInput = RejectTextInput
, _textInput = mempty
, _pressedKeys = mempty
, _mouseButtons = mempty
, _mousePos = V2 0 0
@@ -24,7 +24,6 @@ defaultInput = Input
, _rLine = (0, 0)
, _lSelect = 0
, _rSelect = 0
, _backspaceTimer = 0
}
defaultWorld :: World
src/Dodge/Event.hs
+1 -1
View File
@@ -23,7 +23,7 @@ import SDL
handleEvent :: Event -> Universe -> IO (Maybe Universe)
handleEvent e = case eventPayload e of
TextInputEvent tev -> return . Just . (handleTextInput (textInputEventText tev))
TextInputEvent tev -> return . Just . handleTextInput (textInputEventText tev)
KeyboardEvent kev -> handleKeyboardEvent kev
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev)
src/Dodge/Event/Keyboard.hs
+20 -58
View File
@@ -5,23 +5,14 @@ module Dodge.Event.Keyboard (
guardDisconnectedID,
) where
import Data.Maybe
--import Data.Maybe
--import Data.Text (unpack)
import qualified Data.Text as T
import Dodge.Base
import Dodge.Button.Event
import Dodge.Combine
import Dodge.Creature.Action
import Dodge.Data.Universe
import Dodge.Event.Menu
import Dodge.Event.Test
import Dodge.InputFocus
import Dodge.Inventory
import Dodge.Menu
import Dodge.Reloading
import Dodge.Save
import Dodge.Terminal.LeftButton
import Dodge.WorldPos
import LensHelp
import SDL
--import qualified Data.Map.Strict as M
@@ -31,20 +22,20 @@ import SDL
-- also, note that this currently "doubles" the inputs to both terminals if both
-- are open
handleTextInput :: T.Text -> Universe -> Universe
--handleTextInput text = input . textInput . textInputText %~ T.append (T.toUpper text)
handleTextInput text u = u
& uvScreenLayers . ix 0 . scInput %~ updateText
& updateTerminalText
where
updateTerminalText = case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid)
| hasfocus tmid ->
uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . lWorld . terminals . ix tmid . tmInput . tiText %~ updateText)
_ -> id
hasfocus tmid = fromMaybe False $ u ^? uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus
updateText s = case T.unpack text of
";" -> s
_ -> s `T.append` T.toUpper text
handleTextInput text = uvWorld . input . textInput %~ T.append text
--handleTextInput text u = u
-- & uvScreenLayers . ix 0 . scInput %~ updateText
-- & updateTerminalText
-- where
-- updateTerminalText = case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
-- Just (DisplayTerminal tmid)
-- | hasfocus tmid ->
-- uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . lWorld . terminals . ix tmid . tmInput . tiText %~ updateText)
-- _ -> id
-- hasfocus tmid = fromMaybe False $ u ^? uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus
-- updateText s = case T.unpack text of
-- ";" -> s
-- _ -> s `T.append` T.toUpper text
guardDisconnectedID :: Int -> World -> World -> World
guardDisconnectedID tmid w w' = case w ^? cWorld . lWorld . terminals . ix tmid . tmStatus of
@@ -71,15 +62,8 @@ handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
scode = (keysymScancode . keyboardEventKeysym) kev
handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe)
handlePressedKey True ScancodeBackspace u
| _backspaceTimer (_input $ _uvWorld u) <= 0 =
handlePressedKey False ScancodeBackspace u
<&> _Just . uvWorld . input . backspaceTimer .~ 0
| otherwise = return $ Just $ u & uvWorld . input . backspaceTimer -~ 1
handlePressedKey True _ u = return $ Just u
handlePressedKey _ scode u = case scode of
-- ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u)
-- ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u
ScancodeF5 -> return . Just $ doQuicksave u
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
ScancodeSemicolon -> return . Just $ gotoTerminal u
@@ -87,43 +71,21 @@ handlePressedKey _ scode u = case scode of
Just (DisplayTerminal tmid)
| inTermFocus (_uvWorld u) ->
return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
_ -> return $ (Just . handlePressedKeyInGame scode) u
_ -> return $ Just u
_ -> handlePressedKeyInMenu (head $ _uvScreenLayers u) scode u
handlePressedKeyInGame :: Scancode -> Universe -> Universe
handlePressedKeyInGame scode uv = case scode of
_ -> uv
--doBackspace :: T.Text -> T.Text
--doBackspace t = case T.unsnoc t of
-- Nothing -> t
-- Just (t', _) -> t'
handlePressedKeyTerminal :: Int -> Scancode -> World -> World
handlePressedKeyTerminal tmid scode w = case scode of
ScancodeEscape -> w & cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const False
ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . lWorld . terminals . ix tmid)
ScancodeBackspace ->
w
& cWorld . lWorld . terminals . ix tmid . tmInput . tiText %~ doBackspace
& input . backspaceTimer .~ 5
_ -> w
where
doBackspace t = case T.unsnoc t of
Nothing -> t
Just (t', _) -> t'
gotoTerminal :: Universe -> Universe
gotoTerminal w = case _uvScreenLayers w of
(InputScreen{} : _) -> w
_ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
pauseGame :: Universe -> Universe
pauseGame = uvScreenLayers .~ [pauseMenu]
toggleMap :: World -> World
toggleMap w = case w ^?! cWorld . lWorld . hud . hudElement of
DisplayCarte -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
_ -> w & cWorld . lWorld . hud . hudElement .~ DisplayCarte
escapeMap :: World -> World
escapeMap w = case w ^?! cWorld . lWorld . hud . hudElement of
DisplayCarte -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
_ -> w
src/Dodge/Event/Menu.hs
-6
View File
@@ -22,13 +22,7 @@ handlePressedKeyInMenu mState scode = case mState of
ScancodeEscape -> popScreen
ScancodeReturn -> popScreen . applyTerminalString (words $ T.unpack s)
ScancodeTab -> autoCompleteTerminal (T.unpack s) help
ScancodeBackspace -> return . Just . (uvScreenLayers . ix 0 . scInput %~ doBackspace)
-- text input handled by handleTextInput
_ -> return . Just
where
doBackspace t = case T.unsnoc t of
Nothing -> t
Just (t', _) -> t'
optionListToEffects ::
(Universe -> IO (Maybe Universe)) ->
src/Dodge/Update.hs
+7 -2
View File
@@ -63,7 +63,10 @@ import Sound.Data
import StrictHelp
updateUniverse :: Universe -> Universe
updateUniverse u = updateUniverseLast . updateUniverseMid
updateUniverse u =
updateUniverseLast
. over (uvWorld . input . textInput) (const mempty)
. updateUniverseMid
. updateUseInput
. over uvWorld (updateCamera cfig)
. over (uvWorld . cWorld . cClock) ( + 1)
@@ -72,7 +75,9 @@ updateUniverse u = updateUniverseLast . updateUniverseMid
cfig = u ^. uvConfig
updateUseInput :: Universe -> Universe
updateUseInput u = M.foldlWithKey' updateKeyInGame u (u ^. uvWorld . input . pressedKeys)
updateUseInput u = case u ^? uvScreenLayers . _head of
Just InputScreen{} -> doInputScreenInput u
_ -> M.foldlWithKey' updateKeyInGame u (u ^. uvWorld . input . pressedKeys)
updateUniverseLast :: Universe -> Universe
src/Dodge/Update/Input.hs
+19
View File
@@ -1,5 +1,6 @@
module Dodge.Update.Input
( updateKeyInGame
, doInputScreenInput
) where
import Dodge.WorldPos
@@ -14,6 +15,24 @@ import Dodge.Menu
import Dodge.Data.Universe
import SDL
import LensHelp
import qualified Data.Text as T
doInputScreenInput :: Universe -> Universe
doInputScreenInput u = u & uvScreenLayers . _head . scInput %~ (`T.append` thetext)
& checkBackspace
where
thetext = u ^. uvWorld . input . textInput
checkBackspace = case u ^. uvWorld . input . pressedKeys . at ScancodeBackspace of
Just InitialPress -> f
Just LongPress -> f
_ -> id
f = uvScreenLayers . _head . scInput %~ doBackspace
doBackspace :: T.Text -> T.Text
doBackspace t = case T.unsnoc t of
Nothing -> t
Just (t', _) -> t'
updateKeyInGame :: Universe -> Scancode -> PressType -> Universe
updateKeyInGame uv sc InitialPress = case sc of