Move towards inputs in terminal

src/Dodge/Data.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)
+handleTextInput :: T.Text -> Universe -> IO (Maybe Universe)
-handleTextInputEvent = handleTextInput . unpack . textInputEventText
+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)
+--    | null (_menuLayers w) = return $ Just w
-handleTextInput text 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

@@ -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 :: ScreenLayer -> T.Text -> Universe -> IO (Maybe Universe)
-handleTextInMenu mState text = return . Just . case mState of
+--handleTextInMenu mState text = return . Just . -- case mState of
-    InputScreen {}  -> menuLayers . ix 0 . scInput %~ updateText
+----    InputScreen {}  -> 
-    _               -> id
+--        (menuLayers . ix 0 . scInput %~ updateText)
-  where
+----    _               -> id
-    updateText "" = ">"
+--  where
-    updateText s = s ++ text
+--    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)
+        ScancodeReturn      -> popScreen . applyTerminalString (T.unpack s)
-        ScancodeTab         -> autoCompleteTerminal s help
+        ScancodeTab         -> autoCompleteTerminal (T.unpack s) help
-        ScancodeBackspace   -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
+--        ScancodeBackspace   -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
         -- text input handled by handleText
         _                   -> return . Just
   where
-    doBackspace [_]     = ['>']
+--    doBackspace [_]     = ['>']
-    doBackspace (x:xs)  = init (x:xs)
+--    doBackspace (x:xs)  = init (x:xs)
-    doBackspace _       = ['>']
+--    doBackspace _       = ['>']
 
 optionListToEffects 
     :: (Universe -> IO (Maybe Universe)) 

src/Dodge/Inventory.hs

@@ -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

@@ -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

@@ -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

@@ -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 :: (GenParams -> World -> TerminalParams) -> Placement
-putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
+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 :: (GenParams -> [String]) -> (GenParams -> World -> TerminalParams)
-genTermMessage f = \gp -> 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

@@ -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
+    DisplayTerminal {_termParams = tp,_termID = tid} -> pictures
-        [ invHead cfig (_termTitle tp)
+        [ 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

@@ -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

@@ -66,9 +66,15 @@ addWarningTerminal outplid = (rmName .++~ "warningTerm-")
                 then Just (rtpos, rpdir)
                 else Just (ltpos, rpdir)
         _ -> Nothing
-    termMessages trid = (genTermMessage $ const ["A","TEST"]) 
+    termMessages trid = ops trid (genTermMessage $ const ["AVAILABLE COMMANDS:"
-        <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)])
+        , "  QUIT  TOGGLE"
-    ops trid = [ ("OPEN", triggers . ix (fromJust $ _plMID trid) .~ const True)
+        , replicate 50 'M'
-        , ("LEAVE", id)
+        ]) 
-        ]
+--        <&> 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