Implement entity tags and commands (#1635)

Closes #1631

## Design

* Entities have a new property: a `Set` of textual tags.
* Two new commands are introduced:
    * `HasTag` checks whether a single entity has a given tag
    * `TagMembers` allows cycling through all members with a given tag
* `TagMembers` may be considered more powerful than `HasTag`, so has its own separate capability (`CTagmembers`).
* A map is computed at scenario initialization to facilitate `TagMembers` lookups.
* Tag names are highlighted in yellow in markdown.

## Demo

    scripts/play.sh -i scenarios/Testing/1631-tags.yaml --autoplay

## Other changes

* Incidentally, changed `knownEntities` from a list to a `Set` so that `Set.member` can be used instead of `elem`.

data/scenarios/Testing/00-ORDER.txt

@@ -51,4 +51,5 @@ Achievements
 1536-custom-unwalkable-entities.yaml
 1535-ping
 1575-structure-recognizer
+1631-tags.yaml
 1634-message-colors.yaml

data/scenarios/Testing/1631-tags.yaml

@@ -0,0 +1,130 @@
+version: 1
+name: Test tag commands
+description: |
+  Test the `hastag` and `tagmembers` command.
+objectives:
+  - condition: |
+      as base {has "mushroom"}
+    prerequisite:
+      not: got_fruit
+    goal:
+      - |
+        Pick up something `edible`{=tag} that is not a `fruit`{=tag}.
+  - teaser: "No fruit!"
+    id: got_fruit
+    optional: true
+    condition: |
+      // Returns true if prohibited item is in inventory.
+      def checkFruit = \idx.
+        result <- tagmembers "fruit" idx;
+        let totalCount = fst result in
+        let member = snd result in
+        let nextIdx = idx + 1 in
+
+        hasProhibited <- as base {has member};
+        if hasProhibited {
+          return true;
+        } {
+          if (nextIdx < totalCount) {
+            checkFruit nextIdx;
+          } {
+            return false;
+          }
+        }
+        end;
+
+      checkFruit 0;
+    goal:
+      - |
+        Do not pick up any fruit.
+solution: |
+  def findTarget =
+    result <- scan down;
+    isTarget <- case result (\_. return false) (\item.
+      isEdible <- hastag item "edible";
+      isFruit <- hastag item "fruit";
+      return $ isEdible && not isFruit;
+    );
+
+    if isTarget {
+      grab;
+      return ();
+    } {
+      move;
+      findTarget;
+    }
+    end;
+  
+  findTarget;
+robots:
+  - name: base
+    dir: [1,0]
+    devices:
+      - ADT calculator
+      - branch predictor
+      - barcode scanner
+      - dictionary
+      - grabber
+      - lambda
+      - lodestone
+      - logger
+      - scanner
+      - solar panel
+      - strange loop
+      - treads
+entities:
+  - name: barcode scanner
+    display:
+      attr: red
+      char: 'S'
+    description:
+    - Reads the 'tag' of an item
+    properties: [portable]
+    capabilities: [hastag, tagmembers]
+  - name: canteloupe
+    display:
+      char: 'c'
+    description:
+    - Melon
+    tags: [edible, fruit]
+    properties: [portable]
+  - name: mushroom
+    display:
+      char: 'm'
+    description:
+    - Nature's tiny umbrella.
+    tags: [edible, fungus]
+    properties: [portable]
+  - name: gravel
+    display:
+      char: 'g'
+    description:
+    - Crushed rock
+    properties: [portable]
+  - name: strawberry
+    display:
+      char: 's'
+    description:
+    - Just ripe
+    tags: [edible, fruit]
+  - name: peach
+    display:
+      char: 'g'
+    description:
+    - Just ripe
+    tags: [edible, fruit]
+    properties: [portable]
+world:
+  palette:
+    '.': [grass]
+    'B': [grass, null, base]
+    'a': [grass, canteloupe]
+    'b': [grass, gravel]
+    'c': [grass, strawberry]
+    'd': [grass, mushroom]
+    'e': [grass, peach]
+  upperleft: [-5, 5]
+  map: |
+    .......
+    B.abcde
+    .......

data/schema/entity.json

@@ -31,6 +31,13 @@
             },
             "description": "A description of the entity, as a list of paragraphs."
         },
+        "tags": {
+            "type": "array",
+            "items": {
+                "type": "string"
+            },
+            "description": "A list of categories this entity belongs to."
+        },
         "orientation": {
             "default": null,
             "type": "array",

editors/emacs/swarm-mode.el

@@ -89,6 +89,8 @@
                "waypoint"
                "structure"
                "floorplan"
+               "hastag"
+               "tagmembers"
                "detect"
                "resonate"
                "density"

editors/vim/swarm.vim

@@ -1,6 +1,6 @@
 syn keyword Keyword def end let in require
 syn keyword Builtins self parent base if inl inr case fst snd force undefined fail not format chars split charat tochar key
-syn keyword Command noop wait selfdestruct move backup path push stride turn grab harvest ignite place ping give equip unequip make has equipped count drill use build salvage reprogram say listen log view appear create halt time scout whereami waypoint structure floorplan detect resonate density sniff chirp watch surveil heading blocked scan upload ishere isempty meet meetall whoami setname random run return try swap atomic instant installkeyhandler teleport as robotnamed robotnumbered knows
+syn keyword Command noop wait selfdestruct move backup path push stride turn grab harvest ignite place ping give equip unequip make has equipped count drill use build salvage reprogram say listen log view appear create halt time scout whereami waypoint structure floorplan hastag tagmembers detect resonate density sniff chirp watch surveil heading blocked scan upload ishere isempty meet meetall whoami setname random run return try swap atomic instant installkeyhandler teleport as robotnamed robotnumbered knows
 syn keyword Direction east north west south down forward left back right
 syn keyword Type int text dir bool cmd void unit actor
 

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|key|noop|wait|selfdestruct|move|backup|path|push|stride|turn|grab|harvest|ignite|place|ping|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|structure|floorplan|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|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|backup|path|push|stride|turn|grab|harvest|ignite|place|ping|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|structure|floorplan|hastag|tagmembers|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
 				}
 			]
 			},

src/Swarm/Game/Entity.hs

@@ -32,6 +32,7 @@ module Swarm.Game.Entity (
   entityPlural,
   entityNameFor,
   entityDescription,
+  entityTags,
   entityOrientation,
   entityGrowth,
   entityCombustion,
@@ -255,6 +256,8 @@ data Entity = Entity
   , _entityDescription :: Document Syntax
   -- ^ A longer-form description. Each 'Text' value is one
   --   paragraph.
+  , _entityTags :: Set Text
+  -- ^ A set of categories to which the entity belongs
   , _entityOrientation :: Maybe Heading
   -- ^ The entity's orientation (if it has one).  For example, when
   --   a robot moves, it moves in the direction of its orientation.
@@ -281,12 +284,13 @@ data Entity = Entity
 -- | The @Hashable@ instance for @Entity@ ignores the cached hash
 --   value and simply combines the other fields.
 instance Hashable Entity where
-  hashWithSalt s (Entity _ disp nm pl descr orient grow combust yld props caps inv) =
+  hashWithSalt s (Entity _ disp nm pl descr tags orient grow combust yld props caps inv) =
     s
       `hashWithSalt` disp
       `hashWithSalt` nm
       `hashWithSalt` pl
       `hashWithSalt` docToText descr
+      `hashWithSalt` tags
       `hashWithSalt` orient
       `hashWithSalt` grow
       `hashWithSalt` combust
@@ -330,6 +334,7 @@ mkEntity disp nm descr props caps =
       nm
       Nothing
       descr
+      mempty
       Nothing
       Nothing
       Nothing
@@ -394,7 +399,8 @@ instance FromJSON Entity where
               <$> v .: "display"
               <*> v .: "name"
               <*> v .:? "plural"
-              <*> (v .: "description")
+              <*> v .: "description"
+              <*> v .:? "tags" .!= mempty
               <*> v .:? "orientation"
               <*> v .:? "growth"
               <*> v .:? "combustion"
@@ -418,6 +424,7 @@ instance ToJSON Entity where
       [ "display" .= (e ^. entityDisplay)
       , "name" .= (e ^. entityName)
       , "description" .= (e ^. entityDescription)
+      , "tags" .= (e ^. entityTags)
       ]
         ++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)]
         ++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)]
@@ -490,6 +497,10 @@ entityNameFor _ = to $ \e ->
 entityDescription :: Lens' Entity (Document Syntax)
 entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x})
 
+-- | A set of categories to which the entity belongs
+entityTags :: Lens' Entity (Set Text)
+entityTags = hashedLens _entityTags (\e x -> e {_entityTags = x})
+
 -- | The direction this entity is facing (if it has one).
 entityOrientation :: Lens' Entity (Maybe Heading)
 entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x})

src/Swarm/Game/Scenario.hs

@@ -63,6 +63,8 @@ import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Maybe (catMaybes, isNothing, listToMaybe)
 import Data.Sequence (Seq)
+import Data.Set (Set)
+import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
 import Swarm.Game.Entity
@@ -126,7 +128,7 @@ data Scenario = Scenario
   , _scenarioAttrs :: [CustomAttr]
   , _scenarioEntities :: EntityMap
   , _scenarioRecipes :: [Recipe Entity]
-  , _scenarioKnown :: [Text]
+  , _scenarioKnown :: Set EntityName
   , _scenarioWorlds :: NonEmpty WorldDescription
   , _scenarioNavigation :: Navigation (M.Map SubworldName) Location
   , _scenarioStructures :: StaticStructureInfo
@@ -154,7 +156,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
     -- with any custom entities parsed above
     localE fst $ withE em $ do
       -- parse 'known' entity names and make sure they exist
-      known <- liftE (v .:? "known" .!= [])
+      known <- liftE (v .:? "known" .!= mempty)
       em' <- getE
       case filter (isNothing . (`lookupEntityName` em')) known of
         [] -> return ()
@@ -227,7 +229,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
         <*> liftE (v .:? "attrs" .!= [])
         <*> pure em
         <*> v ..:? "recipes" ..!= []
-        <*> pure known
+        <*> pure (Set.fromList known)
         <*> pure allWorlds
         <*> pure mergedNavigation
         <*> pure structureInfo
@@ -273,7 +275,7 @@ scenarioRecipes :: Lens' Scenario [Recipe Entity]
 
 -- | List of entities that should be considered "known", so robots do
 --   not have to scan them.
-scenarioKnown :: Lens' Scenario [Text]
+scenarioKnown :: Lens' Scenario (Set EntityName)
 
 -- | The subworlds of the scenario.
 -- The "root" subworld shall always be at the head of the list, by construction.

src/Swarm/Game/State.hs

@@ -102,6 +102,7 @@ module Swarm.Game.State (
   knownEntities,
   gameAchievements,
   structureRecognition,
+  tagMembers,
 
   -- *** Landscape
   Landscape,
@@ -525,9 +526,10 @@ data Discovery = Discovery
   { _allDiscoveredEntities :: Inventory
   , _availableRecipes :: Notifications (Recipe Entity)
   , _availableCommands :: Notifications Const
-  , _knownEntities :: [Text]
+  , _knownEntities :: S.Set EntityName
   , _gameAchievements :: Map GameplayAchievement Attainment
   , _structureRecognition :: StructureRecognizer
+  , _tagMembers :: Map Text (NonEmpty EntityName)
   }
 
 makeLensesNoSigs ''Discovery
@@ -543,7 +545,7 @@ availableCommands :: Lens' Discovery (Notifications Const)
 
 -- | The names of entities that should be considered \"known\", that is,
 --   robots know what they are without having to scan them.
-knownEntities :: Lens' Discovery [Text]
+knownEntities :: Lens' Discovery (S.Set EntityName)
 
 -- | Map of in-game achievements that were obtained
 gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment)
@@ -551,6 +553,9 @@ gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment)
 -- | Recognizer for robot-constructed structures
 structureRecognition :: Lens' Discovery StructureRecognizer
 
+-- | Map from tags to entities that possess that tag
+tagMembers :: Lens' Discovery (Map Text (NonEmpty EntityName))
+
 data Landscape = Landscape
   { _worldNavigation :: Navigation (M.Map SubworldName) Location
   , _multiWorld :: W.MultiWorld Int Entity
@@ -1185,11 +1190,12 @@ initGameState gsc =
           { _availableRecipes = mempty
           , _availableCommands = mempty
           , _allDiscoveredEntities = empty
-          , _knownEntities = []
+          , _knownEntities = mempty
           , -- This does not need to be initialized with anything,
             -- since the master list of achievements is stored in UIState
             _gameAchievements = mempty
           , _structureRecognition = StructureRecognizer (RecognizerAutomatons mempty mempty) emptyFoundStructures []
+          , _tagMembers = mempty
           }
     , _activeRobots = IS.empty
     , _waitingRobots = M.empty
@@ -1349,6 +1355,13 @@ mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
  where
   allPlaced = lookupStaticPlacements structInfo
 
+buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName)
+buildTagMap em =
+  binTuples expanded
+ where
+  expanded = concatMap (\(k, vs) -> [(v, k) | v <- S.toList vs]) $ M.toList tagsByEntity
+  tagsByEntity = M.map (view entityTags) $ entitiesByName em
+
 pureScenarioToGameState ::
   Scenario ->
   Seed ->
@@ -1377,6 +1390,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc =
       & internalActiveRobots .~ setOf (traverse . robotID) robotList'
       & discovery . availableCommands .~ Notifications 0 initialCommands
       & discovery . knownEntities .~ scenario ^. scenarioKnown
+      & discovery . tagMembers .~ buildTagMap em
       & robotNaming . gensym .~ initGensym
       & seed .~ theSeed
       & randGen .~ mkStdGen theSeed

src/Swarm/Game/Step.hs

@@ -1443,6 +1443,21 @@ execConst c vs s k = do
             `isJustOr` cmdExn Floorplan (pure $ T.unwords ["Unknown structure", quote name])
         return . mkReturn . getAreaDimensions . entityGrid $ withGrid structureDef
       _ -> badConst
+    HasTag -> case vs of
+      [VText eName, VText tName] -> do
+        em <- use $ landscape . entityMap
+        e <-
+          lookupEntityName eName em
+            `isJustOrFail` ["I've never heard of", indefiniteQ eName <> "."]
+        return $ mkReturn $ tName `S.member` (e ^. entityTags)
+      _ -> badConst
+    TagMembers -> case vs of
+      [VText tagName, VInt idx] -> do
+        tm <- use $ discovery . tagMembers
+        case M.lookup tagName tm of
+          Nothing -> throwError $ CmdFailed TagMembers (T.unwords ["No tag named", tagName]) Nothing
+          Just theMembers -> return $ mkReturn (NE.length theMembers, indexWrapNonEmpty theMembers idx)
+      _ -> badConst
     Detect -> case vs of
       [VText name, VRect x1 y1 x2 y2] -> do
         loc <- use robotLocation

src/Swarm/Language/Capability.hs

@@ -82,6 +82,10 @@ data Capability
     CWaypoint
   | -- | Execute the 'Structure' and 'Floorplan' commands
     CStructure
+  | -- | Execute the 'HasTag' command
+    CHastag
+  | -- | Execute the 'TagMembers' command
+    CTagmembers
   | -- | Execute the 'Whereami' command
     CSenseloc
   | -- | Execute the 'Blocked' command
@@ -265,6 +269,8 @@ constCaps = \case
   Waypoint -> Just CWaypoint
   Structure -> Just CStructure
   Floorplan -> Just CStructure
+  HasTag -> Just CHastag
+  TagMembers -> Just CTagmembers
   Detect -> Just CDetectloc
   Resonate -> Just CDetectcount
   Density -> Just CDetectcount

src/Swarm/Language/Syntax.hs

@@ -228,6 +228,10 @@ data Const
     Structure
   | -- | Get the width and height of a structure template
     Floorplan
+  | -- | Answer whether a given entity has the given tag
+    HasTag
+  | -- | Cycle through the entity names that are labeled with a given tag
+    TagMembers
   | -- | Locate the closest instance of a given entity within the rectangle
     -- specified by opposite corners, relative to the current location.
     Detect
@@ -659,6 +663,17 @@ constInfo c = case c of
       [ "Returns a tuple of (width, height) for the structure of the requested name."
       , "Yields an error if the supplied string is not the name of a structure."
       ]
+  HasTag ->
+    command 2 Intangible . doc "Check whether the given entity has the given tag" $
+      [ "Returns true if the first argument is an entity that is labeled by the tag in the second argument."
+      , "Yields an error if the first argument is not a valid entity."
+      ]
+  TagMembers ->
+    command 2 Intangible . doc "Get the entities labeled by a tag, by alphabetical index" $
+      [ "Returns a tuple of (member count, entity)."
+      , "The supplied index will be wrapped automatically, modulo the member count."
+      , "A robot can use the count to know whether they have iterated over the full list."
+      ]
   Detect ->
     command 2 Intangible . doc "Detect an entity within a rectangle." $
       ["Locate the closest instance of a given entity within the rectangle specified by opposite corners, relative to the current location."]

src/Swarm/Language/Typecheck.hs

@@ -776,6 +776,8 @@ inferConst c = case c of
   Waypoint -> [tyQ| text -> int -> cmd (int * (int * int)) |]
   Structure -> [tyQ| text -> int -> cmd (unit + (int * (int * int))) |]
   Floorplan -> [tyQ| text -> cmd (int * int) |]
+  HasTag -> [tyQ| text -> text -> cmd bool |]
+  TagMembers -> [tyQ| text -> int -> cmd (int * text) |]
   Detect -> [tyQ| text -> ((int * int) * (int * int)) -> cmd (unit + (int * int)) |]
   Resonate -> [tyQ| text -> ((int * int) * (int * int)) -> cmd int |]
   Density -> [tyQ| ((int * int) * (int * int)) -> cmd int |]

src/Swarm/TUI/View/CellDisplay.hs

@@ -14,8 +14,9 @@ import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Maybe (maybeToList)
 import Data.Semigroup (sconcat)
+import Data.Set (Set)
+import Data.Set qualified as S
 import Data.Tagged (unTagged)
-import Data.Text (Text)
 import Data.Word (Word32)
 import Linear.Affine ((.-.))
 import Swarm.Game.CESK (TickNumber (..))
@@ -96,7 +97,7 @@ mkEntityKnowledge gs =
 -- normally vs as a question mark.
 data EntityKnowledgeDependencies = EntityKnowledgeDependencies
   { isCreativeMode :: Bool
-  , globallyKnownEntities :: [Text]
+  , globallyKnownEntities :: Set EntityName
   , theFocusedRobot :: Maybe Robot
   }
 
@@ -110,7 +111,7 @@ getEntityIsKnown knowledge ep = case ep of
     reasonsToShow =
       [ isCreativeMode knowledge
       , e `hasProperty` Known
-      , (e ^. entityName) `elem` globallyKnownEntities knowledge
+      , (e ^. entityName) `S.member` globallyKnownEntities knowledge
       , showBasedOnRobotKnowledge
       ]
     showBasedOnRobotKnowledge = maybe False (`robotKnows` e) $ theFocusedRobot knowledge

src/Swarm/TUI/View/Util.hs

@@ -145,6 +145,7 @@ drawMarkdown d = do
   rawAttr = \case
     "entity" -> greenAttr
     "structure" -> redAttr
+    "tag" -> yellowAttr
     "type" -> magentaAttr
     _snippet -> highlightAttr -- same as plain code
 

test/integration/Main.hs

@@ -340,6 +340,7 @@ testScenarioSolutions rs ui =
         , testSolution Default "Testing/1379-single-world-portal-reorientation"
         , testSolution Default "Testing/1399-backup-command"
         , testSolution Default "Testing/1536-custom-unwalkable-entities"
+        , testSolution Default "Testing/1631-tags"
         , testGroup
             -- Note that the description of the classic world in
             -- data/worlds/classic.yaml (automatically tested to some