From e3038e75ff01f0b0a179e2c0ff60ed1b1324869a Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Thu, 2 May 2024 12:50:45 -0700 Subject: [PATCH] sow command --- data/scenarios/Testing/00-ORDER.txt | 3 +- data/scenarios/Testing/1533-sow-command.yaml | 186 ++++++++++++++++++ data/schema/display.json | 5 + data/schema/entity.json | 42 +++- editors/emacs/swarm-mode.el | 1 + editors/vim/swarm.vim | 2 +- editors/vscode/syntaxes/swarm.tmLanguage.json | 2 +- .../Swarm/Game/Step/Combustion.hs | 24 +-- src/swarm-engine/Swarm/Game/Step/Const.hs | 75 +++++-- .../Swarm/Game/Step/Util/Command.hs | 65 +++++- src/swarm-lang/Swarm/Language/Capability.hs | 3 + src/swarm-lang/Swarm/Language/Syntax.hs | 7 + src/swarm-lang/Swarm/Language/Typecheck.hs | 1 + src/swarm-scenario/Swarm/Game/Display.hs | 15 ++ src/swarm-scenario/Swarm/Game/Entity.hs | 48 ++++- test/integration/Main.hs | 1 + 16 files changed, 435 insertions(+), 45 deletions(-) create mode 100644 data/scenarios/Testing/1533-sow-command.yaml diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index d9488f88ac..f931067005 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 0000000000..5e4d39c0eb --- /dev/null +++ b/data/scenarios/Testing/1533-sow-command.yaml @@ -0,0 +1,186 @@ +version: 1 +name: Sow command and spread +seed: 0 +description: | + Demonstrate `sow` command and spreading growth with biome restrictions. +creative: false +attrs: + - name: clay + fg: "#444444" + bg: "#c2b280" + - name: wheat + fg: "#444444" + bg: "#F5DEB3" + - name: barley + fg: "#444444" + bg: "#F6E9B1" + - name: maize + fg: "#444444" + bg: "#FBEC5D" + - name: mint + bg: "#3EB489" +terrains: + - name: clay + attr: clay + description: | + Sandy soil +objectives: + - id: harvested + goal: + - | + Plant and harvest crops + condition: | + return false +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 6 move; + harvest; + + doN 13 move; + turn right; + harvest; + doN 6 move; + + sow "mint"; + turn right; + doN 13 move; + + sow "barley"; + turn left; + doN 7 move; + sow "barley"; + turn left; + + doN 13 move; + sow "kudzu"; + doN 6 move; +robots: + - name: base + dir: east + devices: + - branch predictor + - calculator + - comparator + - dictionary + - harvester + - logger + - seed spreader + - treads + inventory: + - [1, mint] + - [1, barley] + - [1, kudzu] +entities: + - name: wheat + display: + char: 'w' + attr: wheat + description: + - Grain + properties: [known, pickable, growable] + growth: + duration: [20, 30] + spread: + radius: 2 + density: 0.3 + biomes: [dirt, clay] + - name: barley + display: + char: 'b' + attr: barley + description: + - Grain + properties: [known, pickable, growable] + growth: + duration: [30, 50] + spread: + radius: 2 + density: 0.3 + biomes: [dirt, clay] + - name: corn + display: + char: 'c' + attr: maize + description: + - Animal feed + properties: [known, pickable, growable] + growth: + duration: [30, 60] + spread: + radius: 3 + density: 0.1 + biomes: [dirt, clay] + - name: kudzu + display: + char: 'k' + attr: plant + description: + - Dense, impassable plant. + properties: [known, unwalkable, growable] + growth: + duration: [30, 50] + spread: + radius: 1 + density: 3 + biomes: [dirt, clay] + - name: mint + display: + char: 'm' + attr: mint + description: + - Invasive + properties: [known, pickable, growable] + growth: + duration: [10, 50] + 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] + capabilities: [sow] +known: [flower] +world: + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 'd': [dirt] + 'c': [clay] + 'C': [dirt, corn] + 'W': [clay, wheat] + upperleft: [-1, 1] + map: | + .......................... + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + BdddddCddddd..cccccWccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .......................... + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .......................... + .......................... + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .......................... + .......................... + .......................... + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .......................... diff --git a/data/schema/display.json b/data/schema/display.json index 3052148554..4b4de8fdc9 100644 --- a/data/schema/display.json +++ b/data/schema/display.json @@ -57,6 +57,11 @@ "default": false, "type": "boolean", "description": "Whether the entity or robot should be invisible. Invisible entities and robots are not drawn, but can still be interacted with in otherwise normal ways. System robots are by default invisible." + }, + "inheritable": { + "default": true, + "type": "boolean", + "description": "Whether robot children inherit this display." } } } diff --git a/data/schema/entity.json b/data/schema/entity.json index 5cacdf4273..f81a6aca1e 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 b7629a91d5..05266dd022 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 af3ed61b63..0eed270881 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 96a0381ec9..e57883bfba 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 106ffce464..313e174431 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 2874817e10..fdb0528451 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 @@ -1103,6 +1120,10 @@ execConst runChildProg c vs s k = do -- Construct the new robot and add it to the world. parentCtx <- use robotContext + let newDisplay = case r ^. robotDisplay . childInheritance of + Invisible -> defaultRobotDisplay & invisible .~ True + Inherit -> defaultRobotDisplay & inherit displayAttr (r ^. robotDisplay) + DefaultDisplay -> defaultRobotDisplay newRobot <- zoomRobots . addTRobotWithContext parentCtx (In cmd e s [FExec]) $ mkRobot @@ -1113,9 +1134,7 @@ execConst runChildProg c vs s k = do ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir) ? north ) - ( defaultRobotDisplay - & inherit displayAttr (r ^. robotDisplay) - ) + newDisplay Nothing [] [] @@ -1714,6 +1733,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 + seedlingDensity = maybe 0 spreadDensity maybeSpread + -- See https://en.wikipedia.org/wiki/Triangular_number#Formula + seedlingArea = 1 + 2 * (radius * (radius + 1)) + 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 +1795,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 1366963318..9c006f5cca 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" @@ -484,6 +486,7 @@ addSeedBot e (minT, maxT) loc ts = ( defaultEntityDisplay '.' & displayAttr .~ (e ^. entityDisplay . displayAttr) & displayPriority .~ 0 + & childInheritance .~ Invisible ) Nothing [] @@ -492,12 +495,36 @@ 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 = +-- +-- NOTE: Seedling propagation delay (spreadable growth) +-- re-uses the growth timing parameters. +seedProgram :: + -- | min time + Integer -> + -- | rand time + Integer -> + -- | seedling count + Integer -> + -- | seedling radius + Integer -> + -- | entity to place + EntityName -> + 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 +532,36 @@ seedProgram minTime randTime thing = r <- random (1 + $int:randTime); wait (r + $int:minTime); place $str:thing; + + doN $int:seedlingCount ( + _robo <- build { + propagationDelay <- random (1 + $int:randTime); + wait (propagationDelay + $int:minTime); + + totalDist <- random (1 + $int:seedlingRadius); + horizontalDist <- random (1 + totalDist); + let verticalDist = totalDist - horizontalDist in + + shouldReverse <- random 2; + if (shouldReverse == 0) { + turn back; + } {}; + stride horizontalDist; + turn left; + shouldReverse2 <- random 2; + if (shouldReverse2 == 0) { + turn back; + } {}; + stride verticalDist; + + create $str:thing; + try { + sow $str:thing; + } {}; + + selfdestruct + }; + ); } {}; selfdestruct |] diff --git a/src/swarm-lang/Swarm/Language/Capability.hs b/src/swarm-lang/Swarm/Language/Capability.hs index 3fb4e3abe1..101055eb33 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 a80a33bd53..a45dbca0c0 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 2fe9918269..929f96d4c7 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 unit |] 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/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs index 35f04a8ccf..72fce71ea5 100644 --- a/src/swarm-scenario/Swarm/Game/Display.hs +++ b/src/swarm-scenario/Swarm/Game/Display.hs @@ -15,6 +15,7 @@ module Swarm.Game.Display ( Attribute (..), readAttribute, Display, + ChildInheritance (..), -- ** Fields defaultChar, @@ -23,6 +24,7 @@ module Swarm.Game.Display ( displayAttr, displayPriority, invisible, + childInheritance, -- ** Rendering displayChar, @@ -75,6 +77,12 @@ instance ToJSON Attribute where AEntity -> String "entity" AWorld w -> String w +data ChildInheritance + = Invisible + | Inherit + | DefaultDisplay + deriving (Eq, Ord, Show, Generic, Hashable) + -- | A record explaining how to display an entity in the TUI. data Display = Display { _defaultChar :: Char @@ -83,6 +91,7 @@ data Display = Display , _displayAttr :: Attribute , _displayPriority :: Priority , _invisible :: Bool + , _childInheritance :: ChildInheritance } deriving (Eq, Ord, Show, Generic, Hashable) @@ -117,6 +126,9 @@ displayPriority :: Lens' Display Priority -- | Whether the entity is currently invisible. invisible :: Lens' Display Bool +-- | For robots, whether children of this inherit the parent's display +childInheritance :: Lens' Display ChildInheritance + instance FromJSON Display where parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ') @@ -138,6 +150,7 @@ instance FromJSONE Display Display where <*> (v .:? "attr") .!= (defD ^. displayAttr) <*> v .:? "priority" .!= (defD ^. displayPriority) <*> v .:? "invisible" .!= (defD ^. invisible) + <*> pure Inherit where validateChar c = when (charWidth > 1) @@ -192,6 +205,7 @@ defaultEntityDisplay c = , _displayAttr = AEntity , _displayPriority = 1 , _invisible = False + , _childInheritance = Inherit } -- | Construct a default robot display for a given orientation, with @@ -215,6 +229,7 @@ defaultRobotDisplay = , _displayAttr = ARobot , _displayPriority = 10 , _invisible = False + , _childInheritance = Inherit } instance Monoid Display where diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 76ac6f07ed..0334595dba 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 c9c889c00b..64bff7980c 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -366,6 +366,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