biomes

data/scenarios/Testing/00-ORDER.txt

@@ -62,3 +62,4 @@ Achievements
 1747-volume-command.yaml
 1777-capability-cost.yaml
 1775-custom-terrain.yaml
+1642-biomes.yaml

data/scenarios/Testing/1642-biomes.yaml

@@ -0,0 +1,97 @@
+version: 1
+name: Demo sow command
+description: |
+  Demonstrate growth restrictions.
+objectives:
+  - id: harvested
+    goal:
+      - |
+        `harvest` both `wheat`{=entity}.
+        Only one should grow back.
+    condition: |
+      as base {
+        c <- count "wheat";
+        return $ c == 2;
+      }
+  - id: western_wheat_regrew
+    optional: true
+    goal:
+      - |
+        Wheat in grass must not regrow
+    condition: |
+      observer <- robotnamed "observer";
+      as observer {
+        ishere "wheat";
+      }
+    prerequisite: harvested
+  - goal:
+      - |
+        Go to the stone patch.
+        This takes at least 10 ticks,
+        by which time the
+        `wheat`{=entity} would have grown back.
+        Fails if the western wheat does grow back.
+    condition: |
+      goalbot <- robotnamed "goalbot";
+      baseLoc <- as base {whereami};
+      as goalbot {
+        goalLoc <- whereami;
+        return $ baseLoc == goalLoc;
+      }
+    prerequisite: 
+      logic:
+        and:
+          - harvested
+          - not: western_wheat_regrew
+solution: |
+  move; harvest;
+  move; harvest;
+  move;
+  move; move; move; move; move;
+  move; move; move; move; move;
+robots:
+  - name: base
+    dir: east
+    devices:
+      - treads
+      - scythe
+  - name: observer
+    dir: east
+    system: true
+  - name: goalbot
+    dir: east
+    system: true
+entities:
+  - name: wheat
+    display:
+      char: 'w'
+      attr: gold
+    description:
+      - Grain
+    properties: [known, pickable, growable]
+    growth: [2, 4]
+    biomes: [dirt]
+  - name: scythe
+    display:
+      char: 'y'
+    description:
+      - Curved blade on a long handle
+    properties: [known]
+    capabilities:
+      - harvest
+    biomes: [dirt]
+known: [flower]
+world:
+  default: [blank]
+  palette:
+    '.': [grass]
+    'd': [dirt]
+    's': [stone, null, goalbot]
+    'w': [grass, wheat, observer]
+    'W': [dirt, wheat]
+    'B': [grass, null, base]
+  upperleft: [-1, 1]
+  map: |
+    ..dd..........
+    BwWd.........s
+    ..............

data/schema/entity.json

@@ -73,6 +73,17 @@
             "$ref": "combustion.json",
             "description": "Properties of combustion."
         },
+        "biomes": {
+            "default": [],
+            "type": "array",
+            "items": {
+                "type": "string",
+                "examples": [
+                    "dirt"
+                ]
+            },
+            "description": "A list of properties of this entity."
+        },
         "yields": {
             "default": null,
             "type": "string",

src/swarm-engine/Swarm/Game/State.hs

@@ -64,10 +64,12 @@ module Swarm.Game.State (
   genMultiWorld,
   genRobotTemplates,
   entityAt,
+  contentAt,
   zoomWorld,
   zoomRobots,
 ) where
 
+import Swarm.Game.Terrain
 import Control.Arrow (Arrow ((&&&)))
 import Control.Carrier.State.Lazy qualified as Fused
 import Control.Effect.Lens
@@ -479,6 +481,18 @@ entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity)
 entityAt (Cosmic subworldName loc) =
   join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc))
 
+contentAt ::
+  (Has (State GameState) sig m) =>
+  Cosmic Location ->
+  m (TerrainType, Maybe Entity)
+contentAt (Cosmic subworldName loc) = do
+  tm <- use $ landscape . terrainAndEntities . terrainMap
+  val <- zoomWorld subworldName $ do
+    (terrIdx, maybeEnt) <- W.lookupContentM (W.locToCoords loc)
+    let terrObj = terrIdx `IM.lookup` terrainByIndex tm
+    return (maybe BlankT terrainName terrObj, maybeEnt)
+  return $ fromMaybe (BlankT, Nothing) val
+
 -- | Perform an action requiring a 'Robots' state component in a
 --   larger context with a 'GameState'.
 zoomRobots ::

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -1724,9 +1724,8 @@ execConst runChildProg c vs s k = do
 
     -- Ensure there is an entity here.
     loc <- use robotLocation
-    e <-
-      entityAt loc
-        >>= (`isJustOrFail` ["There is nothing here to", verb <> "."])
+    (terrainHere, maybeEntityHere) <- contentAt loc
+    e <- return maybeEntityHere >>= (`isJustOrFail` ["There is nothing here to", verb <> "."])
 
     -- Ensure it can be picked up.
     omni <- isPrivilegedBot
@@ -1741,7 +1740,11 @@ execConst runChildProg c vs s k = do
 
     -- Possibly regrow the entity, if it is growable and the 'harvest'
     -- command was used.
-    when ((e `hasProperty` Growable) && cmd == Harvest') $ do
+    let biomeRestrictions = e ^. entityBiomes
+        isAllowedInBiome = null biomeRestrictions
+          || terrainHere `S.member` biomeRestrictions
+
+    when ((e `hasProperty` Growable) && cmd == Harvest' && isAllowedInBiome) $ do
       let GrowthTime (minT, maxT) = (e ^. entityGrowth) ? defaultGrowthTime
 
       createdAt <- getNow
@@ -1751,10 +1754,13 @@ execConst runChildProg c vs s k = do
 
     -- Add the picked up item to the robot's inventory.  If the
     -- entity yields something different, add that instead.
-    let yieldName = e ^. entityYields
-    e' <- case yieldName of
+    e' <- case e ^. entityYields of
       Nothing -> return e
-      Just n -> fromMaybe e <$> uses (landscape . terrainAndEntities . entityMap) (lookupEntityName n)
+      Just yielded ->
+        -- NOTE: Using 'fromMaybe' here is a consequence of the inability
+        -- to validate the lookup at parse time. Compare to 'entityCapabilities'
+        -- (see summary of #1777).
+        fromMaybe e <$> uses (landscape . terrainAndEntities . entityMap) (lookupEntityName yielded)
 
     robotInventory %= insert e'
     updateDiscoveredEntities e'

src/swarm-scenario/Swarm/Game/Entity.hs

@@ -41,6 +41,7 @@ module Swarm.Game.Entity (
   entityProperties,
   hasProperty,
   entityCapabilities,
+  entityBiomes,
   entityInventory,
   entityHash,
 
@@ -91,6 +92,7 @@ import Control.Arrow ((&&&))
 import Control.Carrier.Throw.Either (liftEither)
 import Control.Effect.Lift (Lift, sendIO)
 import Control.Effect.Throw (Throw, throwError)
+import Swarm.Game.Terrain (TerrainType)
 import Control.Lens (Getter, Lens', lens, to, view, (^.))
 import Control.Monad (forM_, unless, (<=<))
 import Data.Bifunctor (first)
@@ -280,6 +282,8 @@ data Entity = Entity
   -- grabbed.
   , _entityProperties :: Set EntityProperty
   -- ^ Properties of the entity.
+  , _entityBiomes :: Set TerrainType
+  -- ^ Terrain in which growth may occur. Empty means no restrictions.
   , _entityCapabilities :: SingleEntityCapabilities EntityName
   -- ^ Capabilities provided by this entity.
   , _entityInventory :: Inventory
@@ -294,7 +298,7 @@ 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 tags orient grow combust yld props caps inv) =
+  hashWithSalt s (Entity _ disp nm pl descr tags orient grow combust yld props biomes caps inv) =
     s
       `hashWithSalt` disp
       `hashWithSalt` nm
@@ -306,6 +310,7 @@ instance Hashable Entity where
       `hashWithSalt` combust
       `hashWithSalt` yld
       `hashWithSalt` props
+      `hashWithSalt` biomes
       `hashWithSalt` caps
       `hashWithSalt` inv
 
@@ -350,6 +355,7 @@ mkEntity disp nm descr props caps =
       Nothing
       Nothing
       (Set.fromList props)
+      mempty
       (zeroCostCapabilities caps)
       empty
 
@@ -493,6 +499,7 @@ instance FromJSON Entity where
               <*> v .:? "combustion"
               <*> v .:? "yields"
               <*> v .:? "properties" .!= mempty
+              <*> v .:? "biomes" .!= mempty
               <*> v .:? "capabilities" .!= Capabilities mempty
               <*> pure empty
           )
@@ -619,6 +626,10 @@ hasProperty e p = p `elem` (e ^. entityProperties)
 entityCapabilities :: Lens' Entity (SingleEntityCapabilities EntityName)
 entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x})
 
+-- | The inventory of other entities carried by this entity.
+entityBiomes :: Lens' Entity (Set TerrainType)
+entityBiomes = hashedLens _entityBiomes (\e x -> e {_entityBiomes = x})
+
 -- | The inventory of other entities carried by this entity.
 entityInventory :: Lens' Entity Inventory
 entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x})

src/swarm-scenario/Swarm/Game/Terrain.hs

@@ -40,9 +40,10 @@ import Swarm.Game.Failure
 import Swarm.Game.ResourceLoading (getDataFileNameSafe)
 import Swarm.Util (enumeratedMap, quote)
 import Swarm.Util.Effect (withThrow)
+import Data.Hashable (Hashable)
 
 data TerrainType = BlankT | TerrainType Text
-  deriving (Eq, Ord, Show, Generic, ToJSON)
+  deriving (Eq, Ord, Show, Generic, ToJSON, Hashable)
 
 blankTerrainIndex :: Int
 blankTerrainIndex = 0

src/swarm-scenario/Swarm/Game/World.hs

@@ -44,6 +44,7 @@ module Swarm.Game.World (
   -- ** Monadic variants
   lookupTerrainM,
   lookupEntityM,
+  lookupContentM,
   updateM,
 
   -- ** Runtime updates
@@ -234,6 +235,16 @@ lookupTerrainM c = do
   modify @(World t e) $ loadCell c
   lookupTerrain c <$> get @(World t e)
 
+lookupContentM ::
+  forall t e sig m.
+  (Has (State (World t e)) sig m, IArray U.UArray t) =>
+  Coords ->
+  m (t, Maybe e)
+lookupContentM c = do
+  modify @(World t e) $ loadCell c
+  w <- get @(World t e)
+  return (lookupTerrain c w, lookupEntity c w)
+
 lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e
 lookupCosmicEntity (Cosmic subworldName i) multiWorld =
   lookupEntity i =<< M.lookup subworldName multiWorld

test/integration/Main.hs

@@ -366,6 +366,7 @@ testScenarioSolutions rs ui =
         , testSolution Default "Testing/1747-volume-command"
         , testSolution Default "Testing/1775-custom-terrain"
         , testSolution Default "Testing/1777-capability-cost"
+        , testSolution Default "Testing/1642-biomes"
         , testGroup
             -- Note that the description of the classic world in
             -- data/worlds/classic.yaml (automatically tested to some