Key input handler

app/Main.hs

@@ -70,6 +70,7 @@ cliParser =
     subparser . mconcat $
       [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")
       , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords")
+      , command "keys" (info (pure SpecialKeyNames) $ progDesc "Output list of recognized special key names")
       , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables")
       , command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage")
       ]

data/entities.yaml

@@ -1223,3 +1223,28 @@
     A nanoscale semiconductor particle with a wide range of
     applications.
   properties: [portable]
+
+- name: 'key'
+  display:
+    attr: gold
+    char: 'k'
+  description:
+  - A versatile item, with uses such as opening
+    locked doors, entering input, and retrieving stored values.
+  properties: [portable]
+
+- name: keyboard
+  display:
+    attr: device
+    char: 'K'
+  description:
+  - A small device with multiple keys, adapted for your unique anatomy.
+  - |
+    `installKeyHandler : text -> (key -> cmd unit) -> cmd unit`
+    installs a custom handler function that can be activated to
+    respond to keyboard inputs typed at the REPL.
+  - |
+    `key : text -> key` constructs values of type `key`, for
+    example `key "Down"` or `key "C-S-x"`.
+  properties: [portable]
+  capabilities: [handleinput]

data/recipes.yaml

@@ -829,3 +829,14 @@
   - [1, iron plate]
   out:
   - [1, victrola]
+
+- in:
+  - [1, iron plate]
+  out:
+  - [4, key]
+
+- in:
+  - [1, board]
+  - [16, key]
+  out:
+  - [1, keyboard]

data/scenarios/Challenges/bridge-building.yaml

@@ -157,6 +157,7 @@ robots:
       - counter
       - dictionary
       - grabber
+      - keyboard
       - lambda
       - logger
       - mirror
@@ -689,4 +690,4 @@ world:
     ................../\.....bbbbbbBBBBBBBBBBBBBBBBBBBBBBB.@..@.@
     ........ccc....../--\......bbbbbbbbBBBBBBBBBBBBBBBq@BB.@.@@.@
     ......cccccccc..t|ΩMd........bbbbbbbbbbBBBBBBBBBBB@.@.@.@@...
-    ........cccc.....----........................................
+    ........cccc.....----........................................

editors/emacs/swarm-mode.el

@@ -47,6 +47,7 @@
                "split"
                "charat"
                "tochar"
+               "key"
              ))
              (x-commands '(
                "noop"
@@ -99,6 +100,7 @@
                "try"
                "swap"
                "atomic"
+               "installkeyhandler"
                "teleport"
                "as"
                "robotnamed"

editors/vscode/syntaxes/swarm.tmLanguage.json

@@ -58,7 +58,7 @@
 				},
 				{
 				"name": "keyword.other",
-				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|noop|wait|selfdestruct|move|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|scout|whereami|detect|resonate|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|teleport|as|robotnamed|robotnumbered|knows)\\b"
+				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|scout|whereami|detect|resonate|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
 				}
 			]
 			},

example/multi-key-handler.sw

@@ -0,0 +1,20 @@
+// Proof of concept illustrating the possibility of key
+// handlers that process multi-key sequences.
+
+def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a.
+  if (a == fst p) {snd p} {k a}
+end
+
+def nil : a -> cmd unit = \a. return () end
+
+// The delay around the first argument is necessary to prevent
+// infinite recursion
+def handlerB : {key -> cmd unit} -> key -> cmd unit = \hA. \k.
+  cons (key "b", move) nil k;
+  installKeyHandler "" (force hA)
+end
+
+// Typing 'a' then 'b' in sequence will cause the robot to move.
+def handlerA : key -> cmd unit =
+  cons (key "a", installKeyHandler "" (handlerB {handlerA})) nil
+end

example/pilotmode.sw

@@ -0,0 +1,26 @@
+def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a.
+  if (a == fst p) {snd p} {k a}
+end
+
+def nil : a -> cmd unit = \a. return () end
+
+// Suitable to use as e.g.
+//   installKeyHandler "(S-)←↓↑→ [Del] [g]rab [h]arvest [d]rill [s]can [b]locked [u]pload" pilot
+def pilot : key -> cmd unit =
+  cons (key "Up",      move) $
+  cons (key "Down",    turn back) $
+  cons (key "Left",    turn left) $
+  cons (key "Right",   turn right) $
+  cons (key "S-Up",    turn north) $
+  cons (key "S-Down",  turn south) $
+  cons (key "S-Left",  turn west) $
+  cons (key "S-Right", turn east) $
+  cons (key "Del",     selfdestruct) $
+  cons (key "g",       res <- grab; log res) $
+  cons (key "h",       res <- harvest; log res) $
+  cons (key "d",       res <- drill forward; case res (\_. return ()) log) $
+  cons (key "s",       res <- scan forward; case res (\_. return ()) log) $
+  cons (key "b",       b <- blocked; if b {log "blocked"} {log "not blocked"}) $
+  cons (key "u",       upload base) $
+  nil
+end

src/Swarm/Doc/Gen.hs

@@ -56,6 +56,7 @@ import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
 import Swarm.Game.WorldGen (testWorld2Entites)
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Capability qualified as Capability
+import Swarm.Language.Key (specialKeyNames)
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax (Const (..))
 import Swarm.Language.Syntax qualified as Syntax
@@ -78,6 +79,8 @@ data GenerateDocs where
   RecipeGraph :: GenerateDocs
   -- | Keyword lists for editors.
   EditorKeywords :: Maybe EditorType -> GenerateDocs
+  -- | List of special key names recognized by 'key' command
+  SpecialKeyNames :: GenerateDocs
   CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs
   -- | List command introductions by tutorial
   TutorialCoverage :: GenerateDocs
@@ -114,6 +117,7 @@ generateDocs = \case
               putStrLn $ replicate 40 '-'
               generateEditorKeywords et
         mapM_ editorGen listEnums
+  SpecialKeyNames -> generateSpecialKeyNames
   CheatSheet address s -> case s of
     Nothing -> error "Not implemented for all Wikis"
     Just st -> case st of
@@ -193,6 +197,14 @@ operatorNames = T.intercalate "|" $ map (escape . constSyntax) operators
     c -> T.singleton c
   escape = T.concatMap (\c -> if c `elem` special then T.snoc "\\\\" c else slashNotComment c)
 
+-- ----------------------------------------------------------------------------
+-- GENERATE SPECIAL KEY NAMES
+-- ----------------------------------------------------------------------------
+
+generateSpecialKeyNames :: IO ()
+generateSpecialKeyNames =
+  T.putStr . T.unlines . Set.toList $ specialKeyNames
+
 -- ----------------------------------------------------------------------------
 -- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE
 -- ----------------------------------------------------------------------------

src/Swarm/Game/State.hs

@@ -69,6 +69,7 @@ module Swarm.Game.State (
   replNextValueIndex,
   replWorking,
   replActiveType,
+  inputHandler,
   messageQueue,
   lastSeenMessageTime,
   focusedRobotID,
@@ -400,6 +401,7 @@ data GameState = GameState
   , _needsRedraw :: Bool
   , _replStatus :: REPLStatus
   , _replNextValueIndex :: Integer
+  , _inputHandler :: Maybe (Text, Value)
   , _messageQueue :: Seq LogEntry
   , _lastSeenMessageTime :: TickNumber
   , _focusedRobotID :: RID
@@ -584,6 +586,9 @@ replStatus :: Lens' GameState REPLStatus
 -- | The index of the next it{index} value
 replNextValueIndex :: Lens' GameState Integer
 
+-- | The currently installed input handler and hint text.
+inputHandler :: Lens' GameState (Maybe (Text, Value))
+
 -- | A queue of global messages.
 --
 -- Note that we put the newest entry to the right.
@@ -1001,6 +1006,7 @@ initGameState = do
         , _needsRedraw = False
         , _replStatus = REPLDone Nothing
         , _replNextValueIndex = 0
+        , _inputHandler = Nothing
         , _messageQueue = Empty
         , _lastSeenMessageTime = -1
         , _focusedRobotID = 0
@@ -1055,6 +1061,7 @@ scenarioToGameState scenario userSeed toRun g = do
           False -> REPLDone Nothing
           True -> REPLWorking (Typed Nothing PolyUnit mempty)
       , _replNextValueIndex = 0
+      , _inputHandler = Nothing
       , _messageQueue = Empty
       , _focusedRobotID = baseID
       , _ticks = 0

src/Swarm/Game/Step.hs

@@ -79,6 +79,8 @@ import Swarm.Game.Value
 import Swarm.Game.World qualified as W
 import Swarm.Language.Capability
 import Swarm.Language.Context hiding (delete)
+import Swarm.Language.Key (parseKeyComboFull)
+import Swarm.Language.Parse (runParser)
 import Swarm.Language.Pipeline
 import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)
@@ -1715,6 +1717,16 @@ execConst c vs s k = do
     Fail -> case vs of
       [VText msg] -> return $ Up (User msg) s k
       _ -> badConst
+    Key -> case vs of
+      [VText ktxt] -> case runParser parseKeyComboFull ktxt of
+        Right kc -> return $ Out (VKey kc) s k
+        Left _ -> return $ Up (CmdFailed Key (T.unwords ["Unknown key", quote ktxt]) Nothing) s k
+      _ -> badConst
+    InstallKeyHandler -> case vs of
+      [VText hint, handler] -> do
+        inputHandler .= Just (hint, handler)
+        return $ Out VUnit s k
+      _ -> badConst
     Reprogram -> case vs of
       [VRobot childRobotID, VDelay cmd e] -> do
         r <- get
@@ -2539,6 +2551,9 @@ compareValues v1 = case v1 of
   VRcd m1 -> \case
     VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2
     v2 -> incompatCmp v1 v2
+  VKey kc1 -> \case
+    VKey kc2 -> return (compare kc1 kc2)
+    v2 -> incompatCmp v1 v2
   VClo {} -> incomparable v1
   VCApp {} -> incomparable v1
   VDef {} -> incomparable v1

src/Swarm/Language/Capability.hs

@@ -143,6 +143,8 @@ data Capability
     CRecord
   | -- | Debug capability.
     CDebug
+  | -- | Capability to handle keyboard input.
+    CHandleinput
   | -- | God-like capabilities.  For e.g. commands intended only for
     --   checking challenge mode win conditions, and not for use by
     --   players.
@@ -232,6 +234,8 @@ constCaps = \case
   Chirp -> Just CDetectdirection
   Watch -> Just CWakeself
   Heading -> Just COrient
+  Key -> Just CHandleinput
+  InstallKeyHandler -> Just CHandleinput
   -- ----------------------------------------------------------------
   -- Text operations
   Format -> Just CText