diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index d9488f88a..f93106700 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -62,4 +62,5 @@ Achievements 1747-volume-command.yaml 1777-capability-cost.yaml 1775-custom-terrain.yaml -1642-biomes.yaml \ No newline at end of file +1642-biomes.yaml +1533-sow-command.yaml \ No newline at end of file diff --git a/data/scenarios/Testing/1533-sow-command.yaml b/data/scenarios/Testing/1533-sow-command.yaml new file mode 100644 index 000000000..ae45f8df9 --- /dev/null +++ b/data/scenarios/Testing/1533-sow-command.yaml @@ -0,0 +1,73 @@ +version: 1 +name: Demo sow command +description: | + Demonstrate growth restrictions. +creative: true +attrs: + - name: clay + bg: "#c2b280" +terrains: + - name: clay + attr: clay + description: | + Sandy soil +objectives: + - id: harvested + goal: + - | + `harvest` both `wheat`{=entity}. + Only one should grow back. + condition: | + as base { + c <- count "wheat"; + return $ c == 2; + } +solution: | + move; harvest; + move; harvest; + move; + move; move; move; move; move; +robots: + - name: base + dir: east + devices: + - treads + - harvester + - name: observer + dir: east + system: true +entities: + - name: wheat + display: + char: 'w' + attr: gold + description: + - Grain + properties: [known, pickable, growable] + growth: + duration: [2, 4] + spread: + radius: 2 + density: 0.6 + biomes: [dirt, clay] + - name: seed spreader + display: + char: 's' + description: + - A handheld pouch with a manual crank to broadcast seeds evenly within a small radius + properties: [known] +known: [flower] +world: + default: [blank] + palette: + '.': [grass] + 'd': [dirt] + 'c': [clay] + 'w': [grass, wheat, observer] + 'W': [dirt, wheat] + 'B': [grass, null, base] + upperleft: [-1, 1] + map: | + ..dddccc...... + BwWddccc...... + ..dddccc...... diff --git a/data/schema/entity.json b/data/schema/entity.json index 5cacdf427..f81a6aca1 100644 --- a/data/schema/entity.json +++ b/data/schema/entity.json @@ -55,18 +55,44 @@ }, "growth": { "default": null, - "type": "array", - "items": [ + + "oneOf": [ { - "name": "minimum", - "type": "number" + "$ref": "range.json", + "description": "For growable entities, a 2-tuple of integers specifying the minimum and maximum amount of time taken for one growth stage. The actual time for one growth stage will be chosen uniformly at random from this range; it takes two growth stages for an entity to be fully grown." }, { - "name": "maximum", - "type": "number" + "type": "object", + "additionalProperties": false, + "properties": { + "mature": { + "default": null, + "type": "string", + "description": "The name of the entity which will be planted by the `sow` command." + }, + "spread": { + "default": null, + "type": "object", + "additionalProperties": false, + "properties": { + "radius": { + "default": 1, + "type": "number", + "description": "Manhattan distance within which the entity may spread" + }, + "density": { + "default": 0, + "type": "number", + "description": "Density within the range to seed" + } + } + }, + "duration": { + "$ref": "range.json" + } + } } - ], - "description": "For growable entities, a 2-tuple of integers specifying the minimum and maximum amount of time taken for one growth stage. The actual time for one growth stage will be chosen uniformly at random from this range; it takes two growth stages for an entity to be fully grown." + ] }, "combustion": { "type": "object", diff --git a/editors/emacs/swarm-mode.el b/editors/emacs/swarm-mode.el index b7629a91d..05266dd02 100644 --- a/editors/emacs/swarm-mode.el +++ b/editors/emacs/swarm-mode.el @@ -62,6 +62,7 @@ "turn" "grab" "harvest" + "sow" "ignite" "place" "ping" diff --git a/editors/vim/swarm.vim b/editors/vim/swarm.vim index af3ed61b6..0eed27088 100644 --- a/editors/vim/swarm.vim +++ b/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 volume 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 Command noop wait selfdestruct move backup volume path push stride turn grab harvest sow 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 diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.json b/editors/vscode/syntaxes/swarm.tmLanguage.json index 96a0381ec..e57883bfb 100644 --- a/editors/vscode/syntaxes/swarm.tmLanguage.json +++ b/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|volume|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" + "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|volume|path|push|stride|turn|grab|harvest|sow|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" } ] }, diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs index 106ffce46..313e17443 100644 --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -120,18 +120,6 @@ addCombustionBot inputEntity combustibility ts loc = do where Combustibility _ durationRange maybeCombustionProduct = combustibility --- Triggers the ignition of the entity underfoot with some delay. -ignitionProgram :: Integer -> ProcessedTerm -ignitionProgram waitTime = - [tmQ| - wait $int:waitTime; - try { - ignite down; - noop; - } {}; - selfdestruct - |] - -- | A system program for a "combustion robot", to burn an entity -- after it is ignited. -- @@ -228,3 +216,15 @@ addIgnitionBot ignitionDelay inputEntity ts loc = False emptyExceptions ts + +-- Triggers the ignition of the entity underfoot with some delay. +ignitionProgram :: Integer -> ProcessedTerm +ignitionProgram waitTime = + [tmQ| + wait $int:waitTime; + try { + ignite down; + noop; + } {}; + selfdestruct + |] diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 162ec9290..2885af48e 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -83,6 +83,7 @@ import Swarm.Game.Step.RobotStepState import Swarm.Game.Step.Util import Swarm.Game.Step.Util.Command import Swarm.Game.Step.Util.Inspect +import Swarm.Game.Terrain (TerrainType) import Swarm.Game.Tick import Swarm.Game.Universe import Swarm.Game.Value @@ -304,6 +305,22 @@ execConst runChildProg c vs s k = do _ -> badConst Grab -> mkReturn <$> doGrab Grab' PerformRemoval Harvest -> mkReturn <$> doGrab Harvest' PerformRemoval + Sow -> case vs of + [VText name] -> do + loc <- use robotLocation + + -- Make sure there's nothing already here + nothingHere <- isNothing <$> entityAt loc + nothingHere `holdsOrFail` ["There is already an entity here."] + + -- Make sure the robot has the thing in its inventory + e <- hasInInventoryOrFail name + + (terrainHere, _) <- contentAt loc + doPlantSeed terrainHere loc e + + return $ mkReturn () + _ -> badConst Ignite -> case vs of [VDir d] -> do Combustion.igniteCommand c d @@ -1714,6 +1731,42 @@ execConst runChildProg c vs s k = do mkReturn :: Valuable a => a -> CESK mkReturn x = Out (asValue x) s k + doPlantSeed :: + (HasRobotStepState sig m, Has Effect.Time sig m) => + TerrainType -> + Cosmic Location -> + Entity -> + m () + doPlantSeed terrainHere loc e = do + when ((e `hasProperty` Growable) && isAllowedInBiome terrainHere e) $ do + let Growth maybeMaturesTo maybeSpread (GrowthTime (minT, maxT)) = + (e ^. entityGrowth) ? defaultGrowth + + em <- use $ landscape . terrainAndEntities . entityMap + let seedEntity = fromMaybe e $ (`lookupEntityName` em) =<< maybeMaturesTo + + createdAt <- getNow + let radius = maybe 1 spreadRadius maybeSpread + let seedlingDensity = maybe 0 spreadDensity maybeSpread + + let seedlingArea = 1 + 2 * (radius * (radius + 1)) + let seedlingCount = floor $ seedlingDensity * fromIntegral seedlingArea + + -- Grow a new entity from a seed. + addSeedBot + seedEntity + (minT, maxT) + seedlingCount + (fromIntegral radius) + loc + createdAt + where + isAllowedInBiome terr ent = + null biomeRestrictions + || terr `S.member` biomeRestrictions + where + biomeRestrictions = ent ^. entityBiomes + -- The code for grab and harvest is almost identical, hence factored -- out here. -- Optionally defer removal from the world, for the case of the Swap command. @@ -1740,18 +1793,8 @@ execConst runChildProg c vs s k = do -- Possibly regrow the entity, if it is growable and the 'harvest' -- command was used. - 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 - - -- Grow a new entity from a seed. - addSeedBot e (minT, maxT) loc createdAt + when (cmd == Harvest') $ + doPlantSeed terrainHere loc e -- Add the picked up item to the robot's inventory. If the -- entity yields something different, add that instead. diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index 136696331..ade06530f 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -469,12 +469,14 @@ addSeedBot :: Has (State GameState) sig m => Entity -> (Integer, Integer) -> + Integer -> + Integer -> Cosmic Location -> TimeSpec -> m () -addSeedBot e (minT, maxT) loc ts = +addSeedBot e (minT, maxT) seedlingCount seedlingRadius loc ts = zoomRobots - . addTRobot (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore) + . addTRobot (initMachine seedProg empty emptyStore) $ mkRobot Nothing "seed" @@ -492,12 +494,32 @@ addSeedBot e (minT, maxT) loc ts = False emptyExceptions ts + where + seedProg = seedProgram + minT + (maxT - minT) + seedlingCount + seedlingRadius + (e ^. entityName) -- | A system program for a "seed robot", to regrow a growable entity -- after it is harvested. -seedProgram :: Integer -> Integer -> Text -> ProcessedTerm -seedProgram minTime randTime thing = +seedProgram :: + Integer -> + -- ^ min time + Integer -> + -- ^ rand time + Integer -> + -- ^ seedling count + Integer -> + -- ^ seedling radius + EntityName -> + -- ^ entity to place + ProcessedTerm +seedProgram minTime randTime seedlingCount seedlingRadius thing = [tmQ| + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + try { r <- random (1 + $int:randTime); wait (r + $int:minTime); @@ -505,6 +527,16 @@ seedProgram minTime randTime thing = r <- random (1 + $int:randTime); wait (r + $int:minTime); place $str:thing; + + doN $int:seedlingCount ( + _robo <- build { + x <- random (1 + $int:seedlingRadius); + y <- random (1 + $int:seedlingRadius); + teleport self (x, y); + sow $str:thing; + selfdestruct; + }; + ); } {}; selfdestruct |] diff --git a/src/swarm-lang/Swarm/Language/Capability.hs b/src/swarm-lang/Swarm/Language/Capability.hs index 3fb4e3abe..101055eb3 100644 --- a/src/swarm-lang/Swarm/Language/Capability.hs +++ b/src/swarm-lang/Swarm/Language/Capability.hs @@ -62,6 +62,8 @@ data Capability CGrab | -- | Execute the 'Harvest' command CHarvest + | -- | Execute the 'Sow' command + CSow | -- | Execute the 'Ignite' command CIgnite | -- | Execute the 'Place' command @@ -239,6 +241,7 @@ constCaps = \case Turn -> Just CTurn Grab -> Just CGrab Harvest -> Just CHarvest + Sow -> Just CSow Ignite -> Just CIgnite Place -> Just CPlace Ping -> Just CPing diff --git a/src/swarm-lang/Swarm/Language/Syntax.hs b/src/swarm-lang/Swarm/Language/Syntax.hs index a80a33bd5..a45dbca0c 100644 --- a/src/swarm-lang/Swarm/Language/Syntax.hs +++ b/src/swarm-lang/Swarm/Language/Syntax.hs @@ -184,6 +184,8 @@ data Const Grab | -- | Harvest an item from the current location. Harvest + | -- | Scatter seeds of a plant + Sow | -- | Ignite a combustible item Ignite | -- | Try to place an item at the current location. @@ -630,6 +632,11 @@ constInfo c = case c of [ "Leaves behind a growing seed if the harvested item is growable." , "Otherwise it works exactly like `grab`." ] + Sow -> + command 1 short . doc (Set.singleton $ Mutation EntityChange) "Distribute seeds for a plant at current location" $ + [ "Spread plant seeds nearby." + , "The success, range, and density of child growth depends on the 'spread' attributes." + ] Ignite -> command 1 short . doc diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs index 2fe991826..dd24ea356 100644 --- a/src/swarm-lang/Swarm/Language/Typecheck.hs +++ b/src/swarm-lang/Swarm/Language/Typecheck.hs @@ -792,6 +792,7 @@ inferConst c = case c of Turn -> [tyQ| dir -> cmd unit |] Grab -> [tyQ| cmd text |] Harvest -> [tyQ| cmd text |] + Sow -> [tyQ| text -> cmd text |] Ignite -> [tyQ| dir -> cmd unit |] Place -> [tyQ| text -> cmd unit |] Ping -> [tyQ| actor -> cmd (unit + (int * int)) |] diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 76ac6f07e..0334595db 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -18,7 +18,9 @@ module Swarm.Game.Entity ( EntityName, EntityProperty (..), GrowthTime (..), - defaultGrowthTime, + GrowthSpread (..), + Growth (..), + defaultGrowth, Combustibility (..), defaultCombustibility, @@ -88,6 +90,7 @@ module Swarm.Game.Entity ( ) where import Control.Algebra (Has) +import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Carrier.Throw.Either (liftEither) import Control.Effect.Lift (Lift, sendIO) @@ -176,6 +179,42 @@ instance FromJSON EntityProperty where Just c -> return c Nothing -> failT ["Unknown entity property", t] +data GrowthSpread = GrowthSpread + { spreadRadius :: Int + -- ^ in terms of manhattan distance + , spreadDensity :: Float + -- ^ average number of tiles within the + -- radius that will be seeded per + -- growth cycle + } + deriving (Eq, Ord, Show, Read, Generic, Hashable, ToJSON) + +instance FromJSON GrowthSpread where + parseJSON = withObject "Growth" $ \v -> + GrowthSpread + <$> v .: "radius" + <*> v .: "density" + +data Growth = Growth + { maturesTo :: Maybe EntityName + -- ^ Entity this turns into after growth is complete, + -- if something different than self + , growthSpread :: Maybe GrowthSpread + , growthTime :: GrowthTime + } + deriving (Eq, Ord, Show, Read, Generic, Hashable, ToJSON) + +instance FromJSON Growth where + parseJSON x = + (Growth Nothing Nothing <$> parseJSON x) + <|> parseFullGrowth x + where + parseFullGrowth = withObject "Growth" $ \v -> + Growth + <$> v .:? "mature" + <*> v .:? "spread" + <*> v .: "duration" + -- | How long an entity takes to regrow. This represents the minimum -- and maximum amount of time taken by one growth stage (there are -- two stages). The actual time for each stage will be chosen @@ -188,6 +227,9 @@ newtype GrowthTime = GrowthTime (Integer, Integer) defaultGrowthTime :: GrowthTime defaultGrowthTime = GrowthTime (100, 200) +defaultGrowth :: Growth +defaultGrowth = Growth Nothing Nothing defaultGrowthTime + -- | Properties of combustion. data Combustibility = Combustibility { ignition :: Double @@ -273,7 +315,7 @@ data Entity = Entity , _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. - , _entityGrowth :: Maybe GrowthTime + , _entityGrowth :: Maybe Growth -- ^ If this entity grows, how long does it take? , _entityCombustion :: Maybe Combustibility -- ^ If this entity is combustible, how spreadable is it? @@ -602,7 +644,7 @@ entityOrientation :: Lens' Entity (Maybe Heading) entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x}) -- | How long this entity takes to grow, if it regrows. -entityGrowth :: Lens' Entity (Maybe GrowthTime) +entityGrowth :: Lens' Entity (Maybe Growth) entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x}) -- | Susceptibility to and duration of combustion diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 17cea6f43..6429059b3 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -367,6 +367,7 @@ testScenarioSolutions rs ui = , testSolution Default "Testing/1775-custom-terrain" , testSolution Default "Testing/1777-capability-cost" , testSolution Default "Testing/1642-biomes" + , testSolution Default "Testing/1533-sow-command" , testGroup -- Note that the description of the classic world in -- data/worlds/classic.yaml (automatically tested to some