mirror of
https://github.com/swarm-game/swarm.git
synced 2024-10-26 17:38:34 +03:00
Capability exercise cost (#1777)
Closes #1684 Closes #1262 # Demo A simple "puzzle" that makes use of consumables: scripts/play.sh -i data/scenarios/Testing/1777-capability-cost.yaml --autoplay Demo of enabled commands and costs display in left pane: scripts/play.sh -i data/scenarios/Testing/1262-display-device-commands.yaml  # In this PR * Supports specifying capabilities both as plain lists and as maps from capabilities to ingredients in YAML * JSON Schema support for both capability specification styles * New integration test * Removed redundant `tshow` implementation from `Swarm.Doc.Util` # Entity lookup approaches The cost of exercising a capability in terms of "ingredients" is specified by the `_entityCapabilities` field within an `Entity` definition. Each ingredient itself is an entity, specified by name. For many purposes, having ingredients just of type `EntityName` is sufficient. But for `Swarm.Game.Recipe.findLacking` in particular, the ingredients list must be actual `Entity` objects, not just names of entities. So at some point the names need to be looked up in the global entity map to be promoted to `Entity` objects. The full list of entities is not available at `Entity` parse time to look up an ingredient entity by name, so we cannot store ingredients lists of type `(Count, Entity)` within a parent `Entity` object. Approaches considered were: * Store a copy of the `entityMap` in `RobotR`, for use by the `equippedDevices` lens * Introduce a type parameter to `Entity` representing a "parse phase" * **Allow a redundant "entity lookup" (and validation) at command execution time** ## Store `entityMap` in `RobotR` One approach explored was to add a field to `RobotR`: ``` , _globalEntityMap :: EntityMap ``` This allowed the `equippedDevices` lens implementation to promote the `EntityName`s to `Entity`s when setting the value of the `_robotCapabilities` field. However, it was rather invasive as it entailed threading the `EntityMap` through many new code paths. ## `Entity` type parameter Currently, `Entity` has a field: ``` _entityCapabilities :: SingleEntityCapabilities EntityName ``` This would entail a huge refactoring, with: ``` data Entity e = Entity ... , _entityCapabilities :: SingleEntityCapabilities e ``` At initial parse time we would obtain a list of `Entity EntityName`, but somewhere later during `Scenario` parse time, we can do another pass to obtain `Entity Entity` objects. This would at least have the advantage of doing the entity lookup/validation on ingredient lists in exactly one place, at parse time. ## Defer `EntityName -> Entity` promotion to command execution time This is what is implemented in this PR. The global set of capability costs is validated at scenario parse time. But it is also redundantly validated in the `payExerciseCost` function, which is not ideal.
This commit is contained in:
Karl Ostmo
GitHub
parent
62375ebf2d
commit
f5ecd3fa53
@ -25,7 +25,6 @@ import Swarm.Doc.Schema.Arrangement
|
||||
import Swarm.Doc.Schema.Parse
|
||||
import Swarm.Doc.Schema.Refined
|
||||
import Swarm.Doc.Schema.SchemaType
|
||||
import Swarm.Doc.Util
|
||||
import Swarm.Doc.Wiki.Util
|
||||
import Swarm.Util (applyWhen, brackets, quote, showT)
|
||||
import System.Directory (listDirectory)
|
||||
@ -77,7 +76,7 @@ makePandocTable titleMap (SchemaData _ (ToplevelSchema theTitle theDescription _
|
||||
ItemList xs ->
|
||||
makePropsTable False listColumnHeadings titleMap
|
||||
. M.fromList
|
||||
$ zip (map tshow [0 :: Int ..]) xs
|
||||
$ zip (map showT [0 :: Int ..]) xs
|
||||
|
||||
mkTable x = doc $ case x of
|
||||
ObjectProperties props -> makePropsTable True propertyColumnHeadings titleMap props
|
||||
|
||||
@ -18,8 +18,8 @@ import Control.Lens.Combinators (to)
|
||||
import Data.Foldable (find, toList)
|
||||
import Data.List (transpose)
|
||||
import Data.Map.Lazy qualified as Map
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Set qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.IO qualified as T
|
||||
@ -27,6 +27,7 @@ import Swarm.Doc.Schema.Render
|
||||
import Swarm.Doc.Util
|
||||
import Swarm.Doc.Wiki.Matrix
|
||||
import Swarm.Doc.Wiki.Util
|
||||
import Swarm.Game.Device qualified as D
|
||||
import Swarm.Game.Display (displayChar)
|
||||
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
|
||||
import Swarm.Game.Entity qualified as E
|
||||
@ -110,7 +111,7 @@ commandToList :: Const -> [Text]
|
||||
commandToList c =
|
||||
map
|
||||
escapeTable
|
||||
[ addLink ("#" <> tshow c) . codeQuote $ constSyntax c
|
||||
[ addLink ("#" <> showT c) . codeQuote $ constSyntax c
|
||||
, codeQuote . prettyTextLine $ inferConst c
|
||||
, maybe "" Capability.capabilityName $ Capability.constCaps c
|
||||
, Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c
|
||||
@ -172,13 +173,13 @@ capabilityRow PageAddress {..} em cap =
|
||||
linkCommand c =
|
||||
( if T.null commandsAddress
|
||||
then id
|
||||
else addLink (commandsAddress <> "#" <> tshow c)
|
||||
else addLink (commandsAddress <> "#" <> showT c)
|
||||
)
|
||||
. codeQuote
|
||||
$ constSyntax c
|
||||
|
||||
cs = [c | c <- Syntax.allConst, let mcap = Capability.constCaps c, isJust $ find (== cap) mcap]
|
||||
es = fromMaybe [] $ E.entitiesByCap em Map.!? cap
|
||||
es = E.devicesForCap cap em
|
||||
|
||||
capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text
|
||||
capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRows
|
||||
@ -201,8 +202,8 @@ entityToList e =
|
||||
escapeTable
|
||||
[ codeQuote . T.singleton $ e ^. entityDisplay . to displayChar
|
||||
, addLink ("#" <> linkID) $ view entityName e
|
||||
, T.intercalate ", " $ Capability.capabilityName <$> Set.toList (view E.entityCapabilities e)
|
||||
, T.intercalate ", " . map tshow . filter (/= E.Pickable) $ toList props
|
||||
, T.intercalate ", " $ Capability.capabilityName <$> Map.keys (D.getMap $ view E.entityCapabilities e)
|
||||
, T.intercalate ", " . map showT . filter (/= E.Pickable) $ toList props
|
||||
, if E.Pickable `elem` props
|
||||
then ":heavy_check_mark:"
|
||||
else ":negative_squared_cross_mark:"
|
||||
@ -225,13 +226,13 @@ entityToSection e =
|
||||
, ""
|
||||
, " - Char: " <> (codeQuote . T.singleton $ e ^. entityDisplay . to displayChar)
|
||||
]
|
||||
<> [" - Properties: " <> T.intercalate ", " (map tshow $ toList props) | not $ null props]
|
||||
<> [" - Properties: " <> T.intercalate ", " (map showT $ toList props) | not $ null props]
|
||||
<> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps]
|
||||
<> ["\n"]
|
||||
<> [Markdown.docToMark $ view E.entityDescription e]
|
||||
where
|
||||
props = view E.entityProperties e
|
||||
caps = Set.toList $ view E.entityCapabilities e
|
||||
caps = S.toList $ D.getCapabilitySet $ view E.entityCapabilities e
|
||||
|
||||
entitiesPage :: PageAddress -> [Entity] -> Text
|
||||
entitiesPage _a es =
|
||||
@ -255,11 +256,11 @@ recipeRow PageAddress {..} r =
|
||||
[ T.intercalate ", " (map formatCE $ view recipeInputs r)
|
||||
, T.intercalate ", " (map formatCE $ view recipeOutputs r)
|
||||
, T.intercalate ", " (map formatCE $ view recipeCatalysts r)
|
||||
, tshow $ view recipeTime r
|
||||
, tshow $ view recipeWeight r
|
||||
, showT $ view recipeTime r
|
||||
, showT $ view recipeWeight r
|
||||
]
|
||||
where
|
||||
formatCE (c, e) = T.unwords [tshow c, linkEntity $ view entityName e]
|
||||
formatCE (c, e) = T.unwords [showT c, linkEntity $ view entityName e]
|
||||
linkEntity t =
|
||||
if T.null entityAddress
|
||||
then t
|
||||
|
||||
@ -36,6 +36,7 @@ Achievements
|
||||
1218-stride-command.yaml
|
||||
1234-push-command.yaml
|
||||
1256-halt-command.yaml
|
||||
1262-display-device-commands.yaml
|
||||
1295-density-command.yaml
|
||||
1138-structures
|
||||
1320-world-DSL
|
||||
@ -59,4 +60,5 @@ Achievements
|
||||
1634-message-colors.yaml
|
||||
1681-pushable-entity.yaml
|
||||
1747-volume-command.yaml
|
||||
1777-capability-cost.yaml
|
||||
1775-custom-terrain.yaml
|
||||
|
||||
54
data/scenarios/Testing/1262-display-device-commands.yaml
Normal file
54
data/scenarios/Testing/1262-display-device-commands.yaml
Normal file
@ -0,0 +1,54 @@
|
||||
version: 1
|
||||
name: Device commands
|
||||
description: |
|
||||
Demo display of commands offered by each device, along with their cost.
|
||||
creative: false
|
||||
robots:
|
||||
- name: base
|
||||
dir: east
|
||||
devices:
|
||||
- treads
|
||||
- logger
|
||||
- Fresnel lens
|
||||
- string
|
||||
inventory:
|
||||
- [1, flash bulb]
|
||||
- [1, photographic plate]
|
||||
entities:
|
||||
- name: flash bulb
|
||||
display:
|
||||
char: 'f'
|
||||
description:
|
||||
- Consumables for a `Fresnel lens`{=entity} that enable `ignite`ing
|
||||
properties: [known, pickable]
|
||||
- name: photographic plate
|
||||
display:
|
||||
char: 'p'
|
||||
description:
|
||||
- Consumables for a `Fresnel lens`{=entity} that enable `scan`ning
|
||||
properties: [known, pickable]
|
||||
- name: Fresnel lens
|
||||
display:
|
||||
char: 'z'
|
||||
description:
|
||||
- Ignites things with sufficiently powerful light source
|
||||
properties: [known, pickable]
|
||||
capabilities:
|
||||
- capability: ignite
|
||||
cost:
|
||||
- [1, "flash bulb"]
|
||||
- capability: scan
|
||||
cost:
|
||||
- [2, "photographic plate"]
|
||||
known: [water]
|
||||
world:
|
||||
dsl: |
|
||||
{water}
|
||||
palette:
|
||||
'B': [grass, erase, base]
|
||||
'.': [grass, erase]
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
...
|
||||
.B.
|
||||
...
|
||||
94
data/scenarios/Testing/1777-capability-cost.yaml
Normal file
94
data/scenarios/Testing/1777-capability-cost.yaml
Normal file
@ -0,0 +1,94 @@
|
||||
version: 1
|
||||
name: Capability cost
|
||||
description: |
|
||||
Consume inventory by exercising device capabilities
|
||||
creative: false
|
||||
seed: 0
|
||||
objectives:
|
||||
- goal:
|
||||
- |
|
||||
Eliminate the `packing peanut`{=entity}s
|
||||
condition: |
|
||||
hasLighterFluid <- as base {
|
||||
has "lighter fluid";
|
||||
};
|
||||
|
||||
if (not hasLighterFluid) {
|
||||
judge <- robotnamed "judge";
|
||||
as judge {
|
||||
maybePath <- path (inL ()) (inR "packing peanut");
|
||||
return $ case maybePath (\_. true) (\d. false);
|
||||
}
|
||||
} {
|
||||
return false;
|
||||
};
|
||||
solution: |
|
||||
move;
|
||||
turn right;
|
||||
move;
|
||||
place "packing peanut";
|
||||
ignite down;
|
||||
move;
|
||||
move;
|
||||
ignite forward;
|
||||
robots:
|
||||
- name: base
|
||||
dir: east
|
||||
devices:
|
||||
- treads
|
||||
- logger
|
||||
- Zippo
|
||||
- grabber
|
||||
inventory:
|
||||
- [2, lighter fluid]
|
||||
- [1, packing peanut]
|
||||
- name: judge
|
||||
dir: east
|
||||
system: true
|
||||
entities:
|
||||
- name: lighter fluid
|
||||
display:
|
||||
char: 'f'
|
||||
description:
|
||||
- Fuel for a `Zippo`{=entity}
|
||||
properties: [known, pickable]
|
||||
- name: Zippo
|
||||
display:
|
||||
char: 'z'
|
||||
description:
|
||||
- Ignites things
|
||||
properties: [known, pickable]
|
||||
capabilities:
|
||||
- capability: ignite
|
||||
cost:
|
||||
- [1, "lighter fluid"]
|
||||
- name: packing peanut
|
||||
display:
|
||||
attr: snow
|
||||
char: 's'
|
||||
description:
|
||||
- Easy to drop, but impossible to pick up.
|
||||
- Highly combustible.
|
||||
properties: [known, combustible]
|
||||
combustion:
|
||||
ignition: 0.5
|
||||
duration: [10, 20]
|
||||
product: ash
|
||||
known: [water, ash]
|
||||
world:
|
||||
dsl: |
|
||||
{water}
|
||||
palette:
|
||||
'B': [grass, erase, base]
|
||||
'j': [grass, erase, judge]
|
||||
'.': [grass, erase]
|
||||
'c': [grass, packing peanut]
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
......
|
||||
Bcccc.
|
||||
.j....
|
||||
.cccc.
|
||||
......
|
||||
.cccc.
|
||||
......
|
||||
@ -0,0 +1,39 @@
|
||||
version: 1
|
||||
name: Capability cost - bad entity reference
|
||||
description: |
|
||||
Capability cost recipe for 'ignite' in `Zippo`{=entity}
|
||||
references a non-existent entity
|
||||
creative: false
|
||||
robots:
|
||||
- name: base
|
||||
dir: east
|
||||
devices:
|
||||
- Zippo
|
||||
entities:
|
||||
- name: heavier fluid
|
||||
display:
|
||||
char: 'f'
|
||||
description:
|
||||
- Fuel for a Zippo
|
||||
properties: [known, pickable]
|
||||
- name: Zippo
|
||||
display:
|
||||
char: 'z'
|
||||
description:
|
||||
- Ignites things
|
||||
properties: [known, pickable]
|
||||
capabilities:
|
||||
- capability: ignite
|
||||
cost:
|
||||
- [1, "lighter fluid"]
|
||||
known: []
|
||||
world:
|
||||
dsl: |
|
||||
{grass}
|
||||
palette:
|
||||
'B': [grass, null, base]
|
||||
'.': [grass]
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
..
|
||||
B.
|
||||
@ -97,7 +97,25 @@
|
||||
"default": [],
|
||||
"type": "array",
|
||||
"items": {
|
||||
"type": "string"
|
||||
"oneOf": [
|
||||
{
|
||||
"type": "string"
|
||||
},
|
||||
{
|
||||
"type": "object",
|
||||
"additionalProperties": false,
|
||||
"properties": {
|
||||
"capability": {
|
||||
"description": "Capability name",
|
||||
"type": "string"
|
||||
},
|
||||
"cost": {
|
||||
"$ref": "inventory.json",
|
||||
"description": "A list of ingredients consumed by the command."
|
||||
}
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"description": "A list of capabilities provided by entity, when it is equipped as a device. See [Capabilities](https://github.com/swarm-game/swarm/wiki/Capabilities-cheat-sheet)."
|
||||
}
|
||||
|
||||
@ -30,9 +30,6 @@ codeQuote = wrap '`'
|
||||
addLink :: Text -> Text -> Text
|
||||
addLink l t = T.concat ["[", t, "](", l, ")"]
|
||||
|
||||
tshow :: (Show a) => a -> Text
|
||||
tshow = T.pack . show
|
||||
|
||||
-- * Common symbols
|
||||
|
||||
operators :: [Const]
|
||||
|
||||
@ -91,7 +91,7 @@ import Swarm.Game.State.Robot
|
||||
import Swarm.Game.State.Runtime
|
||||
import Swarm.Game.State.Substate
|
||||
import Swarm.Game.Step (finishGameTick, gameTick)
|
||||
import Swarm.Language.Capability (Capability (CDebug, CGod, CMake), constCaps)
|
||||
import Swarm.Language.Capability (Capability (CGod, CMake), constCaps)
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Key (KeyCombo, mkKeyCombo)
|
||||
import Swarm.Language.Module
|
||||
@ -309,7 +309,7 @@ handleMainEvent ev = do
|
||||
let isRunning = maybe True isRunningModal mt
|
||||
let isPaused = s ^. gameState . temporal . paused
|
||||
let isCreative = s ^. gameState . creativeMode
|
||||
let hasDebug = fromMaybe isCreative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug
|
||||
let hasDebug = hasDebugCapability isCreative s
|
||||
case ev of
|
||||
AppEvent ae -> case ae of
|
||||
Frame
|
||||
|
||||
@ -10,13 +10,17 @@ import Control.Lens
|
||||
import Control.Monad (forM_, unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Map qualified as M
|
||||
import Data.Set qualified as S
|
||||
import Graphics.Vty qualified as V
|
||||
import Swarm.Game.Device
|
||||
import Swarm.Game.Robot (robotCapabilities)
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.State.Landscape
|
||||
import Swarm.Game.State.Robot
|
||||
import Swarm.Game.State.Substate
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Language.Capability (Capability (CDebug))
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.TUI.Model.UI
|
||||
import Swarm.TUI.View.Util (generateModal)
|
||||
@ -97,3 +101,8 @@ mouseLocToWorldCoords (Brick.Location mouseLoc) = do
|
||||
mx = snd mouseLoc' + fst regionStart
|
||||
my = fst mouseLoc' + snd regionStart
|
||||
in pure . Just $ Cosmic (region ^. subworld) $ W.Coords (mx, my)
|
||||
|
||||
hasDebugCapability :: Bool -> AppState -> Bool
|
||||
hasDebugCapability isCreative s =
|
||||
maybe isCreative (S.member CDebug . getCapabilitySet) $
|
||||
s ^? gameState . to focusedRobot . _Just . robotCapabilities
|
||||
|
||||
@ -117,6 +117,7 @@ import GitHash (GitInfo)
|
||||
import Graphics.Vty (ColorMode (..))
|
||||
import Network.Wai.Handler.Warp (Port)
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Robot.Concrete
|
||||
import Swarm.Game.Robot.Context
|
||||
|
||||
@ -21,6 +21,7 @@ import Data.Text (Text)
|
||||
import Data.Vector qualified as V
|
||||
import Swarm.Game.Achievement.Definitions
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Game.ScenarioInfo (
|
||||
ScenarioCollection,
|
||||
ScenarioInfo (..),
|
||||
|
||||
@ -73,8 +73,10 @@ import Network.Wai.Handler.Warp (Port)
|
||||
import Numeric (showFFloat)
|
||||
import Swarm.Constant
|
||||
import Swarm.Game.CESK (CESK (..))
|
||||
import Swarm.Game.Device (commandCost, commandsForDeviceCaps, enabledCommands, getMap, ingredients)
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Recipe
|
||||
@ -122,6 +124,7 @@ import Swarm.Language.Typecheck (inferConst)
|
||||
import Swarm.Log
|
||||
import Swarm.TUI.Border
|
||||
import Swarm.TUI.Controller (ticksPerFrameCap)
|
||||
import Swarm.TUI.Controller.Util (hasDebugCapability)
|
||||
import Swarm.TUI.Editor.Model
|
||||
import Swarm.TUI.Editor.View qualified as EV
|
||||
import Swarm.TUI.Inventory.Sorting (renderSortMethod)
|
||||
@ -1003,7 +1006,7 @@ drawKeyMenu s =
|
||||
|
||||
isReplWorking = s ^. gameState . gameControls . replWorking
|
||||
isPaused = s ^. gameState . temporal . paused
|
||||
hasDebug = fromMaybe creative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug
|
||||
hasDebug = hasDebugCapability creative s
|
||||
viewingBase = (s ^. gameState . robotInfo . viewCenterRule) == VCRobot 0
|
||||
creative = s ^. gameState . creativeMode
|
||||
cheat = s ^. uiState . uiCheatMode
|
||||
@ -1207,10 +1210,11 @@ explainEntry s e =
|
||||
vBox $
|
||||
[ displayProperties $ Set.toList (e ^. entityProperties)
|
||||
, drawMarkdown (e ^. entityDescription)
|
||||
, explainCapabilities (s ^. gameState) e
|
||||
, explainRecipes s e
|
||||
]
|
||||
<> [drawRobotMachine s False | e ^. entityCapabilities . Lens.contains CDebug]
|
||||
<> [drawRobotLog s | e ^. entityCapabilities . Lens.contains CLog]
|
||||
<> [drawRobotMachine s False | CDebug `M.member` getMap (e ^. entityCapabilities)]
|
||||
<> [drawRobotLog s | CLog `M.member` getMap (e ^. entityCapabilities)]
|
||||
|
||||
displayProperties :: [EntityProperty] -> Widget Name
|
||||
displayProperties = displayList . mapMaybe showProperty
|
||||
@ -1236,6 +1240,66 @@ displayProperties = displayList . mapMaybe showProperty
|
||||
, txt " "
|
||||
]
|
||||
|
||||
-- | This widget can have potentially multiple "headings"
|
||||
-- (one per capability), each with multiple commands underneath.
|
||||
-- Directly below each heading there will be a "exercise cost"
|
||||
-- description, unless the capability is free-to-exercise.
|
||||
explainCapabilities :: GameState -> Entity -> Widget Name
|
||||
explainCapabilities gs e
|
||||
| null capabilitiesAndCommands = emptyWidget
|
||||
| otherwise =
|
||||
padBottom (Pad 1) $
|
||||
vBox
|
||||
[ hBorderWithLabel (txt "Enabled commands")
|
||||
, hCenter
|
||||
. vBox
|
||||
. L.intersperse (txt " ") -- Inserts an extra blank line between major "Cost" sections
|
||||
$ map drawSingleCapabilityWidget capabilitiesAndCommands
|
||||
]
|
||||
where
|
||||
eLookup = lookupEntityE $ entitiesByName $ gs ^. landscape . terrainAndEntities . entityMap
|
||||
eitherCosts = (traverse . traverse) eLookup $ e ^. entityCapabilities
|
||||
capabilitiesAndCommands = case eitherCosts of
|
||||
Right eCaps -> M.elems . getMap . commandsForDeviceCaps $ eCaps
|
||||
Left x ->
|
||||
error $
|
||||
unwords
|
||||
[ "Error: somehow an invalid entity reference escaped the parse-time check"
|
||||
, T.unpack x
|
||||
]
|
||||
|
||||
drawSingleCapabilityWidget cmdsAndCost =
|
||||
vBox
|
||||
[ costWidget cmdsAndCost
|
||||
, padLeft (Pad 1) . vBox . map renderCmdInfo . NE.toList $ enabledCommands cmdsAndCost
|
||||
]
|
||||
|
||||
renderCmdInfo c =
|
||||
padTop (Pad 1) $
|
||||
vBox
|
||||
[ hBox
|
||||
[ padRight (Pad 1) (txt . syntax $ constInfo c)
|
||||
, padRight (Pad 1) (txt ":")
|
||||
, withAttr magentaAttr . txt . prettyText $ inferConst c
|
||||
]
|
||||
, padTop (Pad 1) . padLeft (Pad 1) . txtWrap . briefDoc . constDoc $ constInfo c
|
||||
]
|
||||
|
||||
costWidget cmdsAndCost =
|
||||
if null ings
|
||||
then emptyWidget
|
||||
else padTop (Pad 1) $ vBox $ withAttr boldAttr (txt "Cost:") : map drawCost ings
|
||||
where
|
||||
ings = ingredients $ commandCost cmdsAndCost
|
||||
|
||||
drawCost (n, ingr) =
|
||||
padRight (Pad 1) (str (show n)) <+> eName
|
||||
where
|
||||
eName = applyEntityNameAttr Nothing missing ingr $ txt $ ingr ^. entityName
|
||||
missing = E.lookup ingr robotInv < n
|
||||
|
||||
robotInv = fromMaybe E.empty $ gs ^? to focusedRobot . _Just . robotInventory
|
||||
|
||||
explainRecipes :: AppState -> Entity -> Widget Name
|
||||
explainRecipes s e
|
||||
| null recipes = emptyWidget
|
||||
@ -1347,19 +1411,24 @@ drawRecipe me inv (Recipe ins outs reqs time _weight) =
|
||||
|
||||
-- If it's the focused entity, draw it highlighted.
|
||||
-- If the robot doesn't have any, draw it in red.
|
||||
fmtEntityName missing ingr
|
||||
| Just ingr == me = withAttr highlightAttr $ txtLines nm
|
||||
| ingr == timeE = withAttr yellowAttr $ txtLines nm
|
||||
| missing = withAttr invalidFormInputAttr $ txtLines nm
|
||||
| otherwise = txtLines nm
|
||||
fmtEntityName :: Bool -> Entity -> Widget n
|
||||
fmtEntityName missing ingr =
|
||||
applyEntityNameAttr me missing ingr $ txtLines nm
|
||||
where
|
||||
-- Split up multi-word names, one line per word
|
||||
nm = ingr ^. entityName
|
||||
txtLines = vBox . map txt . T.words
|
||||
|
||||
applyEntityNameAttr :: Maybe Entity -> Bool -> Entity -> (Widget n -> Widget n)
|
||||
applyEntityNameAttr me missing ingr
|
||||
| Just ingr == me = withAttr highlightAttr
|
||||
| ingr == timeE = withAttr yellowAttr
|
||||
| missing = withAttr invalidFormInputAttr
|
||||
| otherwise = id
|
||||
|
||||
-- | Ad-hoc entity to represent time - only used in recipe drawing
|
||||
timeE :: Entity
|
||||
timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] []
|
||||
timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] mempty
|
||||
|
||||
drawReqs :: IngredientList Entity -> Widget Name
|
||||
drawReqs = vBox . map (hCenter . drawReq)
|
||||
|
||||
@ -86,8 +86,9 @@ import Data.IntMap.Strict (IntMap)
|
||||
import Data.IntMap.Strict qualified as IM
|
||||
import GHC.Generics (Generic)
|
||||
import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>))
|
||||
import Swarm.Game.Entity (Count, Entity)
|
||||
import Swarm.Game.Entity (Entity)
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Ingredients (Count)
|
||||
import Swarm.Game.Tick
|
||||
import Swarm.Game.World (WorldUpdate (..))
|
||||
import Swarm.Language.Context
|
||||
|
||||
@ -9,6 +9,7 @@ module Swarm.Game.Exception (
|
||||
Exn (..),
|
||||
IncapableFix (..),
|
||||
formatExn,
|
||||
IncapableFixWords (..),
|
||||
|
||||
-- * Helper functions
|
||||
formatIncapable,
|
||||
@ -25,7 +26,7 @@ import Data.Text qualified as T
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Constant
|
||||
import Swarm.Game.Achievement.Definitions
|
||||
import Swarm.Game.Entity (EntityMap, deviceForCap, entityName)
|
||||
import Swarm.Game.Entity (EntityMap, devicesForCap, entityName)
|
||||
import Swarm.Language.Capability (Capability (CGod), capabilityName)
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Requirement (Requirements (..))
|
||||
@ -54,7 +55,9 @@ data IncapableFix
|
||||
= -- | 'Swarm.Language.Syntax.Equip' the missing device on yourself/target
|
||||
FixByEquip
|
||||
| -- | Add the missing device to your inventory
|
||||
FixByObtain
|
||||
FixByObtainDevice
|
||||
| -- | Add the missing consumables to your inventory
|
||||
FixByObtainConsumables
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
-- | The type of exceptions that can be thrown by robot programs.
|
||||
@ -99,11 +102,18 @@ formatExn em = \case
|
||||
-- INCAPABLE HELPERS
|
||||
-- ------------------------------------------------------------------
|
||||
|
||||
-- | Pretty-print an 'IncapableFix': either "equip" or "obtain".
|
||||
formatIncapableFix :: IncapableFix -> Text
|
||||
data IncapableFixWords = IncapableFixWords
|
||||
{ fixVerb :: Text
|
||||
, fixNoun :: Text
|
||||
}
|
||||
|
||||
-- | Pretty-print an 'IncapableFix': either "equip device",
|
||||
-- "obtain device", or "obtain consumables".
|
||||
formatIncapableFix :: IncapableFix -> IncapableFixWords
|
||||
formatIncapableFix = \case
|
||||
FixByEquip -> "equip"
|
||||
FixByObtain -> "obtain"
|
||||
FixByEquip -> IncapableFixWords "equip" "device"
|
||||
FixByObtainDevice -> IncapableFixWords "obtain" "device"
|
||||
FixByObtainConsumables -> IncapableFixWords "obtain" "consumables"
|
||||
|
||||
-- | Pretty print the incapable exception with an actionable suggestion
|
||||
-- on how to fix it.
|
||||
@ -156,12 +166,13 @@ formatIncapable em f (Requirements caps _ inv) tm
|
||||
, swarmRepoUrl <> "issues/26"
|
||||
]
|
||||
| not (S.null caps) =
|
||||
unlinesExText
|
||||
( "You do not have the devices required for:"
|
||||
:| squote (prettyText tm)
|
||||
: "Please " <> formatIncapableFix f <> ":"
|
||||
: (("- " <>) . formatDevices <$> filter (not . null) deviceSets)
|
||||
)
|
||||
let IncapableFixWords fVerb fNoun = formatIncapableFix f
|
||||
in unlinesExText
|
||||
( T.unwords ["You do not have the", fNoun, "required for:"]
|
||||
:| squote (prettyText tm)
|
||||
: "Please " <> fVerb <> ":"
|
||||
: (("- " <>) . formatDevices <$> filter (not . null) deviceSets)
|
||||
)
|
||||
| otherwise =
|
||||
unlinesExText
|
||||
( "You are missing required inventory for:"
|
||||
@ -171,7 +182,7 @@ formatIncapable em f (Requirements caps _ inv) tm
|
||||
)
|
||||
where
|
||||
capList = S.toList caps
|
||||
deviceSets = map (`deviceForCap` em) capList
|
||||
deviceSets = map (`devicesForCap` em) capList
|
||||
devicePerCap = zip capList deviceSets
|
||||
-- capabilities not provided by any device
|
||||
capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap
|
||||
|
||||
@ -101,6 +101,7 @@ import Data.Text.Lazy.Encoding qualified as TL
|
||||
import GHC.Generics (Generic)
|
||||
import Linear (V2 (..))
|
||||
import Swarm.Game.CESK (emptyStore, finalValue, initMachine)
|
||||
import Swarm.Game.Device (getCapabilitySet, getMap)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Failure (SystemFailure (..))
|
||||
import Swarm.Game.Land
|
||||
@ -599,7 +600,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc =
|
||||
|
||||
TerrainEntityMaps _ em = sLandscape ^. scenarioTerrainAndEntities
|
||||
baseID = 0
|
||||
(things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))
|
||||
(things, devices) = partition (M.null . getMap . view entityCapabilities) (M.elems (entitiesByName em))
|
||||
|
||||
getCodeToRun (CodeToRun _ s) = s
|
||||
|
||||
@ -644,7 +645,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc =
|
||||
allCapabilities r =
|
||||
inventoryCapabilities (r ^. equippedDevices)
|
||||
<> inventoryCapabilities (r ^. robotInventory)
|
||||
initialCaps = mconcat $ map allCapabilities robotList
|
||||
initialCaps = getCapabilitySet $ mconcat $ map allCapabilities robotList
|
||||
initialCommands =
|
||||
filter
|
||||
(maybe True (`S.member` initialCaps) . constCaps)
|
||||
|
||||
@ -684,7 +684,7 @@ stepCESK cesk = case cesk of
|
||||
|
||||
devicesForCaps, requiredDevices :: Set (Set Text)
|
||||
-- possible devices to provide each required capability
|
||||
devicesForCaps = S.map (S.fromList . map (^. entityName) . (`deviceForCap` em)) caps
|
||||
devicesForCaps = S.map (S.fromList . map (^. entityName) . (`devicesForCap` em)) caps
|
||||
-- outright required devices
|
||||
requiredDevices = S.map S.singleton devs
|
||||
|
||||
|
||||
@ -21,6 +21,7 @@ import Control.Carrier.State.Lazy
|
||||
import Control.Effect.Lens
|
||||
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
|
||||
import Control.Monad (forM_, when)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Linear (zero)
|
||||
import Swarm.Effect as Effect (Time, getNow)
|
||||
@ -90,11 +91,10 @@ addCombustionBot ::
|
||||
Cosmic Location ->
|
||||
m Integer
|
||||
addCombustionBot inputEntity combustibility ts loc = do
|
||||
botInventory <- case maybeCombustionProduct of
|
||||
Nothing -> return []
|
||||
Just n -> do
|
||||
maybeE <- uses (landscape . terrainAndEntities . entityMap) (lookupEntityName n)
|
||||
return $ maybe [] (pure . (1,)) maybeE
|
||||
em <- use $ landscape . terrainAndEntities . entityMap
|
||||
let botInventory = fromMaybe [] $ do
|
||||
e <- (`lookupEntityName` em) =<< maybeCombustionProduct
|
||||
return $ pure (1, e)
|
||||
combustionDurationRand <- uniform durationRange
|
||||
let combustionProg = combustionProgram combustionDurationRand combustibility
|
||||
zoomRobots
|
||||
|
||||
@ -1032,7 +1032,7 @@ execConst runChildProg c vs s k = do
|
||||
(childRobot ^. equippedDevices)
|
||||
cmd
|
||||
"The target robot"
|
||||
FixByObtain
|
||||
FixByObtainDevice
|
||||
|
||||
-- update other robot's CESK machine, environment and context
|
||||
-- the childRobot inherits the parent robot's environment
|
||||
@ -1079,7 +1079,7 @@ execConst runChildProg c vs s k = do
|
||||
pid <- use robotID
|
||||
|
||||
(toEquip, toGive) <-
|
||||
checkRequirements (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtain
|
||||
checkRequirements (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtainDevice
|
||||
|
||||
-- Pick a random display name.
|
||||
displayName <- randomName
|
||||
@ -1499,7 +1499,7 @@ execConst runChildProg c vs s k = do
|
||||
-- help with later error message generation.
|
||||
possibleDevices :: [(Maybe Capability, [Entity])]
|
||||
possibleDevices =
|
||||
map (Just &&& (`deviceForCap` em)) caps -- Possible devices for capabilities
|
||||
map (Just &&& (`devicesForCap` em)) caps -- Possible devices for capabilities
|
||||
++ map ((Nothing,) . (: [])) devs -- Outright required devices
|
||||
|
||||
-- A device is OK if it is available in the inventory of the
|
||||
@ -1550,10 +1550,11 @@ execConst runChildProg c vs s k = do
|
||||
-- Now, ensure there is at least one device available to be
|
||||
-- equipped for each requirement.
|
||||
let missingDevices = map snd . filter (null . fst) $ partitionedDevices
|
||||
let IncapableFixWords fVerb fNoun = formatIncapableFix fixI
|
||||
null missingDevices
|
||||
`holdsOrFail` ( singularSubjectVerb subject "do"
|
||||
: "not have required devices, please"
|
||||
: formatIncapableFix fixI <> ":"
|
||||
: "not have required " <> fNoun <> ", please"
|
||||
: fVerb <> ":"
|
||||
: (("\n - " <>) . formatDevices <$> missingDevices)
|
||||
)
|
||||
|
||||
|
||||
@ -22,6 +22,7 @@ import Data.Set qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Linear (zero)
|
||||
import Swarm.Game.Device
|
||||
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Location
|
||||
@ -92,7 +93,7 @@ hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capab
|
||||
hasCapability cap = do
|
||||
isPrivileged <- isPrivilegedBot
|
||||
caps <- use robotCapabilities
|
||||
return (isPrivileged || cap `S.member` caps)
|
||||
return (isPrivileged || cap `S.member` getCapabilitySet caps)
|
||||
|
||||
-- | Ensure that either a robot has a given capability, OR we are in creative
|
||||
-- mode.
|
||||
|
||||
@ -21,6 +21,8 @@ import Control.Effect.Lift
|
||||
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
|
||||
import Control.Monad (forM_, unless, when)
|
||||
import Data.IntSet qualified as IS
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map qualified as M
|
||||
import Data.Sequence qualified as Seq
|
||||
import Data.Set (Set)
|
||||
@ -28,15 +30,18 @@ import Data.Set qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Time (getZonedTime)
|
||||
import Data.Tuple (swap)
|
||||
import Linear (zero)
|
||||
import Swarm.Game.Achievement.Attainment
|
||||
import Swarm.Game.Achievement.Definitions
|
||||
import Swarm.Game.Achievement.Description (getValidityRequirements)
|
||||
import Swarm.Game.CESK
|
||||
import Swarm.Game.Device
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
||||
import Swarm.Game.Entity qualified as E
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot
|
||||
@ -59,25 +64,88 @@ import Swarm.Language.Requirement qualified as R
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Text.Markdown qualified as Markdown
|
||||
import Swarm.Log
|
||||
import Swarm.Util hiding (both)
|
||||
import System.Clock (TimeSpec)
|
||||
import Prelude hiding (Applicative (..), lookup)
|
||||
|
||||
data GrabbingCmd = Grab' | Harvest' | Swap' | Push' deriving (Eq, Show)
|
||||
data GrabbingCmd
|
||||
= Grab'
|
||||
| Harvest'
|
||||
| Swap'
|
||||
| Push'
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Ensure that a robot is capable of executing a certain constant
|
||||
-- (either because it has a device which gives it that capability,
|
||||
-- or it is a system robot, or we are in creative mode).
|
||||
ensureCanExecute :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m ()
|
||||
--
|
||||
-- For certain capabilities that require payment of inventory
|
||||
-- items in order to be exercised, we pay the toll up front, regardless of
|
||||
-- other conditions that may preclude the capability from eventually
|
||||
-- being exercised (e.g. an obstacle that ultimately prevents a "move").
|
||||
--
|
||||
-- Note that there exist some code paths where the "toll"
|
||||
-- is bypassed, e.g. see 'hasCapabilityFor'.
|
||||
-- We should just try to avoid authoring scenarios that
|
||||
-- include toll-gated devices for those particular capabilities.
|
||||
--
|
||||
-- Since this function has the side-effect of removing items from the
|
||||
-- robot's inventory, we must be careful that it is executed exactly
|
||||
-- once per command.
|
||||
ensureCanExecute ::
|
||||
( Has (State Robot) sig m
|
||||
, Has (State GameState) sig m
|
||||
, Has (Throw Exn) sig m
|
||||
) =>
|
||||
Const ->
|
||||
m ()
|
||||
ensureCanExecute c =
|
||||
gets @Robot (constCapsFor c) >>= \case
|
||||
Nothing -> pure ()
|
||||
Just cap -> do
|
||||
isPrivileged <- isPrivilegedBot
|
||||
robotCaps <- use robotCapabilities
|
||||
let hasCaps = cap `S.member` robotCaps
|
||||
(isPrivileged || hasCaps)
|
||||
`holdsOr` Incapable FixByEquip (R.singletonCap cap) (TConst c)
|
||||
-- Privileged robots can execute commands regardless
|
||||
-- of equipped devices, and without expending
|
||||
-- a capability's exercise cost.
|
||||
unless isPrivileged $ do
|
||||
robotCaps <- use robotCapabilities
|
||||
let capProviders = M.lookup cap $ getMap robotCaps
|
||||
case capProviders of
|
||||
Nothing -> throwError $ Incapable FixByEquip (R.singletonCap cap) (TConst c)
|
||||
Just rawCosts -> payExerciseCost c rawCosts
|
||||
|
||||
payExerciseCost ::
|
||||
( Has (State Robot) sig m
|
||||
, Has (State GameState) sig m
|
||||
, Has (Throw Exn) sig m
|
||||
) =>
|
||||
Const ->
|
||||
NE.NonEmpty (DeviceUseCost Entity EntityName) ->
|
||||
m ()
|
||||
payExerciseCost c rawCosts = do
|
||||
em <- use $ landscape . terrainAndEntities . entityMap
|
||||
let eitherCosts = (traverse . traverse) (lookupEntityE $ entitiesByName em) rawCosts
|
||||
costs <- case eitherCosts of
|
||||
-- NOTE: Entity references have been validated already at scenario load time,
|
||||
-- so we should never encounter this error.
|
||||
Left e -> throwError $ Fatal e
|
||||
Right cs -> return cs
|
||||
inv <- use robotInventory
|
||||
let getMissingIngredients = findLacking inv . ingredients . useCost
|
||||
maybeFeasibleRecipe = find (null . getMissingIngredients) $ NE.sort costs
|
||||
case maybeFeasibleRecipe of
|
||||
Nothing ->
|
||||
throwError $
|
||||
Incapable FixByObtainConsumables (expenseToRequirement $ NE.head costs) (TConst c)
|
||||
-- Consume the inventory
|
||||
Just feasibleRecipe ->
|
||||
forM_ (ingredients . useCost $ feasibleRecipe) $ \(cnt, e) ->
|
||||
robotInventory %= deleteCount cnt e
|
||||
where
|
||||
expenseToRequirement :: DeviceUseCost Entity Entity -> R.Requirements
|
||||
expenseToRequirement (DeviceUseCost d (ExerciseCost ingdts)) =
|
||||
R.Requirements S.empty (S.singleton $ d ^. entityName) ingdtsMap
|
||||
where
|
||||
ingdtsMap = M.fromListWith (+) $ map (swap . fmap (view entityName)) ingdts
|
||||
|
||||
-- | Clear watches that are out of range
|
||||
purgeFarAwayWatches ::
|
||||
@ -253,9 +321,9 @@ updateAvailableRecipes invs e = do
|
||||
|
||||
updateAvailableCommands :: Has (State GameState) sig m => Entity -> m ()
|
||||
updateAvailableCommands e = do
|
||||
let newCaps = e ^. entityCapabilities
|
||||
let newCaps = getMap $ e ^. entityCapabilities
|
||||
keepConsts = \case
|
||||
Just cap -> cap `S.member` newCaps
|
||||
Just cap -> cap `M.member` newCaps
|
||||
Nothing -> False
|
||||
entityConsts = filter (keepConsts . constCaps) allConst
|
||||
knownCommands <- use $ discovery . availableCommands . notificationsContent
|
||||
|
||||
@ -12,18 +12,24 @@ module Swarm.Language.Capability (
|
||||
Capability (..),
|
||||
capabilityName,
|
||||
constCaps,
|
||||
constByCaps,
|
||||
) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.Aeson (FromJSONKey, ToJSONKey)
|
||||
import Data.Char (toLower)
|
||||
import Data.Data (Data)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map (Map)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Tuple (swap)
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util (failT)
|
||||
import Swarm.Util (binTuples, failT)
|
||||
import Text.Read (readMaybe)
|
||||
import Witch (from)
|
||||
import Prelude hiding (lookup)
|
||||
@ -336,3 +342,10 @@ constCaps = \case
|
||||
-- currently don't.
|
||||
View -> Nothing -- TODO: #17 should require equipping an antenna
|
||||
Knows -> Nothing
|
||||
|
||||
-- | Inverts the 'constCaps' mapping.
|
||||
constByCaps :: Map Capability (NE.NonEmpty Const)
|
||||
constByCaps =
|
||||
binTuples $
|
||||
map swap $
|
||||
mapMaybe (sequenceA . (id &&& constCaps)) allConst
|
||||
|
||||
134
src/swarm-scenario/Swarm/Game/Device.hs
Normal file
134
src/swarm-scenario/Swarm/Game/Device.hs
Normal file
@ -0,0 +1,134 @@
|
||||
-- |
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- A device is an entity that provides capabilities.
|
||||
--
|
||||
-- Some capabilities have a cost to exercise.
|
||||
-- Items will be consumed from the inventory for
|
||||
-- invoking a command that utilizes a given capability.
|
||||
module Swarm.Game.Device (
|
||||
SingleEntityCapabilities,
|
||||
MultiEntityCapabilities,
|
||||
Capabilities (..),
|
||||
DeviceUseCost (..),
|
||||
ExerciseCost (..),
|
||||
CommandsAndCost (..),
|
||||
getCapabilitySet,
|
||||
zeroCostCapabilities,
|
||||
commandsForDeviceCaps,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Function (on)
|
||||
import Data.Hashable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Set (Set)
|
||||
import Data.Vector qualified as V
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Language.Capability (Capability, constByCaps)
|
||||
import Swarm.Language.Syntax (Const)
|
||||
|
||||
-- | The 'Capabilities e' wrapper type stores information of type @e@ for each
|
||||
-- of some set of capabilities.
|
||||
-- For example, @e@ could be a list of ingredients needed to exercise a
|
||||
-- capability, or a set of devices capable of providing a capability.
|
||||
newtype Capabilities e = Capabilities
|
||||
{ getMap :: Map Capability e
|
||||
}
|
||||
deriving (Show, Eq, Generic, ToJSON, Hashable, Functor, Foldable, Traversable)
|
||||
|
||||
-- | Get the set of capabilities about which we are storing information.
|
||||
getCapabilitySet :: Capabilities e -> Set Capability
|
||||
getCapabilitySet (Capabilities m) = M.keysSet m
|
||||
|
||||
-- | Records an 'ExerciseCost', i.e. list of consumed ingredients, per capability that can be exercised. This represents information about a single entity/device, which can provide multiple capabilities (with a different exercise cost for each).
|
||||
type SingleEntityCapabilities e = Capabilities (ExerciseCost e)
|
||||
|
||||
-- | Records a list of devices capable of providing each capability;
|
||||
-- along with each device is recorded the 'ExerciseCost' needed to use
|
||||
-- that device to achieve the given capability.
|
||||
--
|
||||
-- See 'DeviceUseCost' for explanation of type parameters.
|
||||
type MultiEntityCapabilities e en = Capabilities (NonEmpty (DeviceUseCost e en))
|
||||
|
||||
-- | Create a default 'SingleEntityCapabilities' map for a device which provides capabilities with no associated costs.
|
||||
zeroCostCapabilities :: Set Capability -> SingleEntityCapabilities e
|
||||
zeroCostCapabilities = Capabilities . M.fromSet (const $ ExerciseCost [])
|
||||
|
||||
-- | Package together a capability and exercise cost; only used temporarily for parsing this information from JSON format.
|
||||
data CapabilityCost e = CapabilityCost
|
||||
{ capability :: Capability
|
||||
, cost :: IngredientList e
|
||||
}
|
||||
deriving (Generic, FromJSON)
|
||||
|
||||
-- | First, attempt to parse capabilities as a list, interpreted as a set of capabilities with no exercise cost.
|
||||
-- Otherwise, parse as a Map from capabilities to ingredients.
|
||||
instance (FromJSON e) => FromJSON (SingleEntityCapabilities e) where
|
||||
parseJSON x =
|
||||
simpleList <|> (Capabilities <$> costMap)
|
||||
where
|
||||
simpleList = zeroCostCapabilities <$> parseJSON x
|
||||
costMap = withArray "Capabilities" (fmap (M.fromList . map toMapEntry) . mapM parseJSON . V.toList) x
|
||||
toMapEntry (CapabilityCost a b) = (a, ExerciseCost b)
|
||||
|
||||
instance (Ord e, Semigroup e) => Semigroup (Capabilities e) where
|
||||
Capabilities c1 <> Capabilities c2 =
|
||||
Capabilities $ M.unionWith (<>) c1 c2
|
||||
|
||||
instance (Ord e, Semigroup e) => Monoid (Capabilities e) where
|
||||
mempty = Capabilities mempty
|
||||
|
||||
-- | Exercising a capability may have a cost, in the form of entities that must be consumed each time it is used.
|
||||
newtype ExerciseCost e = ExerciseCost
|
||||
{ ingredients :: IngredientList e
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON, Hashable, Functor, Foldable, Traversable)
|
||||
|
||||
-- | Sort 'ExerciseCost's by the total count of ingredients consumed.
|
||||
instance (Eq e) => Ord (ExerciseCost e) where
|
||||
compare = compare `on` (getCost . ingredients)
|
||||
|
||||
-- | A device paired with a cost to use it.
|
||||
--
|
||||
-- At scenario parse time, the type parameters @e@ and @en@ will stand for
|
||||
-- 'Entity' and 'EntityName'.
|
||||
-- This is because `ExerciseCost` is a member of the 'Entity' datatype, and
|
||||
-- therefore can only refer to another 'Entity' by name before all 'Entity's
|
||||
-- are parsed.
|
||||
--
|
||||
-- However, after parse time, we are able to look up actual 'Entity' objects
|
||||
-- by name, and therefore can instantiate 'ExerciseCost' with 'Entity' as
|
||||
-- the type parameter.
|
||||
-- Then the two type parameters of 'DeviceUseCost' are both of 'Entity' type.
|
||||
data DeviceUseCost e en = DeviceUseCost
|
||||
{ device :: e
|
||||
, useCost :: ExerciseCost en
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON, Functor, Foldable, Traversable)
|
||||
|
||||
-- * Utils
|
||||
|
||||
-- | A nonempty list of commands together with an exercise cost for using any of them (typically these will be a list of commands all requiring the same capability).
|
||||
data CommandsAndCost e = CommandsAndCost
|
||||
{ commandCost :: ExerciseCost e
|
||||
, enabledCommands :: NonEmpty Const
|
||||
}
|
||||
|
||||
-- | Given mapping from capabilities to their exercise costs provided by a single device, turn it into an mapping from capabilities to their exercise cost and enabled commands.
|
||||
--
|
||||
-- NOTE: Because each 'Const' is mapped to at most one
|
||||
-- 'Capability' by the 'constCaps' function, we know that
|
||||
-- a given 'Const' will not appear more than once as a value in the 'Map' produced by
|
||||
-- this function, i.e. for the capabilities provided by a single 'Entity`
|
||||
-- ('SingleEntityCapabilities').
|
||||
commandsForDeviceCaps :: SingleEntityCapabilities e -> Capabilities (CommandsAndCost e)
|
||||
commandsForDeviceCaps = Capabilities . M.mapMaybeWithKey f . getMap
|
||||
where
|
||||
f cap xc =
|
||||
CommandsAndCost xc <$> M.lookup cap constByCaps
|
||||
@ -47,15 +47,15 @@ module Swarm.Game.Entity (
|
||||
-- ** Entity map
|
||||
EntityMap (..),
|
||||
buildEntityMap,
|
||||
lookupEntityE,
|
||||
validateEntityAttrRefs,
|
||||
loadEntities,
|
||||
allEntities,
|
||||
lookupEntityName,
|
||||
deviceForCap,
|
||||
devicesForCap,
|
||||
|
||||
-- * Inventories
|
||||
Inventory,
|
||||
Count,
|
||||
|
||||
-- ** Construction
|
||||
empty,
|
||||
@ -95,6 +95,7 @@ import Control.Lens (Getter, Lens', lens, to, view, (^.))
|
||||
import Control.Monad (forM_, unless, (<=<))
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Char (toLower)
|
||||
import Data.Either.Extra (maybeToEither)
|
||||
import Data.Function (on)
|
||||
import Data.Hashable
|
||||
import Data.IntMap (IntMap)
|
||||
@ -105,17 +106,19 @@ import Data.List (foldl')
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
||||
import Data.Maybe (isJust, listToMaybe)
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as Set (fromList, member, toList, unions)
|
||||
import Data.Set qualified as Set (fromList, member)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Game.Device
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity.Cosmetic (WorldAttr (..))
|
||||
import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes)
|
||||
import Swarm.Game.Failure
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||
import Swarm.Language.Capability
|
||||
@ -277,7 +280,7 @@ data Entity = Entity
|
||||
-- grabbed.
|
||||
, _entityProperties :: Set EntityProperty
|
||||
-- ^ Properties of the entity.
|
||||
, _entityCapabilities :: Set Capability
|
||||
, _entityCapabilities :: SingleEntityCapabilities EntityName
|
||||
-- ^ Capabilities provided by this entity.
|
||||
, _entityInventory :: Inventory
|
||||
-- ^ Inventory of other entities held by this entity.
|
||||
@ -331,7 +334,7 @@ mkEntity ::
|
||||
-- | Properties
|
||||
[EntityProperty] ->
|
||||
-- | Capabilities
|
||||
[Capability] ->
|
||||
Set Capability ->
|
||||
Entity
|
||||
mkEntity disp nm descr props caps =
|
||||
rehashEntity $
|
||||
@ -347,7 +350,7 @@ mkEntity disp nm descr props caps =
|
||||
Nothing
|
||||
Nothing
|
||||
(Set.fromList props)
|
||||
(Set.fromList caps)
|
||||
(zeroCostCapabilities caps)
|
||||
empty
|
||||
|
||||
------------------------------------------------------------
|
||||
@ -363,11 +366,11 @@ mkEntity disp nm descr props caps =
|
||||
-- This enables scenario authors to specify iteration order of
|
||||
-- the 'Swarm.Language.Syntax.TagMembers' command.
|
||||
data EntityMap = EntityMap
|
||||
{ entitiesByName :: Map Text Entity
|
||||
, entitiesByCap :: Map Capability [Entity]
|
||||
{ entitiesByName :: Map EntityName Entity
|
||||
, entitiesByCap :: MultiEntityCapabilities Entity Entity
|
||||
, entityDefinitionOrder :: [Entity]
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
deriving (Eq, Show, Generic, ToJSON)
|
||||
|
||||
-- |
|
||||
-- Note that duplicates in a single 'EntityMap' are precluded by the
|
||||
@ -382,11 +385,11 @@ instance Semigroup EntityMap where
|
||||
EntityMap n1 c1 d1 <> EntityMap n2 c2 d2 =
|
||||
EntityMap
|
||||
(n1 <> n2)
|
||||
(M.unionWith (<>) c1 c2)
|
||||
(c1 <> c2)
|
||||
(filter ((`M.notMember` n2) . view entityName) d1 <> d2)
|
||||
|
||||
instance Monoid EntityMap where
|
||||
mempty = EntityMap M.empty M.empty []
|
||||
mempty = EntityMap M.empty mempty []
|
||||
mappend = (<>)
|
||||
|
||||
-- | Get a list of all the entities in the entity map.
|
||||
@ -399,8 +402,8 @@ lookupEntityName nm = M.lookup nm . entitiesByName
|
||||
|
||||
-- | Find all entities which are devices that provide the given
|
||||
-- capability.
|
||||
deviceForCap :: Capability -> EntityMap -> [Entity]
|
||||
deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap
|
||||
devicesForCap :: Capability -> EntityMap -> [Entity]
|
||||
devicesForCap cap = maybe [] (NE.toList . NE.map device) . M.lookup cap . getMap . entitiesByCap
|
||||
|
||||
-- | Validates references to 'Display' attributes
|
||||
validateEntityAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m ()
|
||||
@ -429,14 +432,48 @@ buildEntityMap es = do
|
||||
case findDup (map fst namedEntities) of
|
||||
Nothing -> return ()
|
||||
Just duped -> throwError $ Duplicate Entities duped
|
||||
return $
|
||||
EntityMap
|
||||
{ entitiesByName = M.fromList namedEntities
|
||||
, entitiesByCap = M.fromListWith (<>) . concatMap (\e -> map (,[e]) (Set.toList $ e ^. entityCapabilities)) $ es
|
||||
, entityDefinitionOrder = es
|
||||
}
|
||||
case combineEntityCapsM entsByName es of
|
||||
Left x -> throwError $ CustomMessage x
|
||||
Right ebc ->
|
||||
return $
|
||||
EntityMap
|
||||
{ entitiesByName = entsByName
|
||||
, entitiesByCap = ebc
|
||||
, entityDefinitionOrder = es
|
||||
}
|
||||
where
|
||||
namedEntities = map (view entityName &&& id) es
|
||||
entsByName = M.fromList namedEntities
|
||||
|
||||
-- Compare to 'combineEntityCapsM'
|
||||
combineEntityCaps ::
|
||||
[Entity] ->
|
||||
MultiEntityCapabilities Entity EntityName
|
||||
combineEntityCaps = mconcat . map mkForEntity
|
||||
where
|
||||
mkForEntity e = f <$> e ^. entityCapabilities
|
||||
where
|
||||
f = pure . DeviceUseCost e
|
||||
|
||||
lookupEntityE :: Map Text b -> Text -> Either Text b
|
||||
lookupEntityE em en =
|
||||
maybeToEither err $ M.lookup en em
|
||||
where
|
||||
err = T.unwords [quote en, "is not a valid entity name"]
|
||||
|
||||
combineEntityCapsM ::
|
||||
Map EntityName Entity ->
|
||||
[Entity] ->
|
||||
Either Text (MultiEntityCapabilities Entity Entity)
|
||||
combineEntityCapsM em =
|
||||
fmap mconcat . mapM mkForEntity
|
||||
where
|
||||
transformCaps = (traverse . traverse) (lookupEntityE em)
|
||||
|
||||
mkForEntity e =
|
||||
fmap f <$> transformCaps (e ^. entityCapabilities)
|
||||
where
|
||||
f = pure . DeviceUseCost e
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Serialization
|
||||
@ -456,7 +493,7 @@ instance FromJSON Entity where
|
||||
<*> v .:? "combustion"
|
||||
<*> v .:? "yields"
|
||||
<*> v .:? "properties" .!= mempty
|
||||
<*> v .:? "capabilities" .!= mempty
|
||||
<*> v .:? "capabilities" .!= Capabilities mempty
|
||||
<*> pure empty
|
||||
)
|
||||
|
||||
@ -481,7 +518,7 @@ instance ToJSON Entity where
|
||||
++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)]
|
||||
++ ["yields" .= (e ^. entityYields) | isJust (e ^. entityYields)]
|
||||
++ ["properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties]
|
||||
++ ["capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities]
|
||||
++ ["capabilities" .= (e ^. entityCapabilities) | not . M.null . getMap $ e ^. entityCapabilities]
|
||||
|
||||
-- | Load entities from a data file called @entities.yaml@, producing
|
||||
-- either an 'EntityMap' or a parse error.
|
||||
@ -579,7 +616,7 @@ hasProperty :: Entity -> EntityProperty -> Bool
|
||||
hasProperty e p = p `elem` (e ^. entityProperties)
|
||||
|
||||
-- | The capabilities this entity provides when equipped.
|
||||
entityCapabilities :: Lens' Entity (Set Capability)
|
||||
entityCapabilities :: Lens' Entity (SingleEntityCapabilities EntityName)
|
||||
entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x})
|
||||
|
||||
-- | The inventory of other entities carried by this entity.
|
||||
@ -590,10 +627,6 @@ entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x})
|
||||
-- Inventory
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | A convenient synonym to remind us when an 'Int' is supposed to
|
||||
-- represent /how many/ of something we have.
|
||||
type Count = Int
|
||||
|
||||
-- | An inventory is really just a bag/multiset of entities. That is,
|
||||
-- it contains some entities, along with the number of times each
|
||||
-- occurs. Entities can be looked up directly, or by name.
|
||||
@ -707,8 +740,8 @@ isEmpty :: Inventory -> Bool
|
||||
isEmpty = all ((== 0) . fst) . elems
|
||||
|
||||
-- | Compute the set of capabilities provided by the devices in an inventory.
|
||||
inventoryCapabilities :: Inventory -> Set Capability
|
||||
inventoryCapabilities = Set.unions . map (^. entityCapabilities) . nonzeroEntities
|
||||
inventoryCapabilities :: Inventory -> MultiEntityCapabilities Entity EntityName
|
||||
inventoryCapabilities = combineEntityCaps . nonzeroEntities
|
||||
|
||||
-- | List elements that have at least one copy in the inventory.
|
||||
nonzeroEntities :: Inventory -> [Entity]
|
||||
@ -718,14 +751,14 @@ nonzeroEntities = map snd . filter ((> 0) . fst) . elems
|
||||
-- exist with nonzero count in the inventory.
|
||||
extantElemsWithCapability :: Capability -> Inventory -> [Entity]
|
||||
extantElemsWithCapability cap =
|
||||
filter (Set.member cap . (^. entityCapabilities)) . nonzeroEntities
|
||||
filter (M.member cap . getMap . (^. entityCapabilities)) . nonzeroEntities
|
||||
|
||||
-- | Groups entities by the capabilities they offer.
|
||||
entitiesByCapability :: Inventory -> Map Capability (NE.NonEmpty Entity)
|
||||
entitiesByCapability inv =
|
||||
binTuples entityCapabilityPairs
|
||||
where
|
||||
getCaps = Set.toList . (^. entityCapabilities)
|
||||
getCaps = M.keys . getMap . (^. entityCapabilities)
|
||||
entityCapabilityPairs = concatMap ((\e -> map (,e) $ getCaps e) . snd) $ elems inv
|
||||
|
||||
-- | Delete a single copy of a certain entity from an inventory.
|
||||
|
||||
20
src/swarm-scenario/Swarm/Game/Ingredients.hs
Normal file
20
src/swarm-scenario/Swarm/Game/Ingredients.hs
Normal file
@ -0,0 +1,20 @@
|
||||
-- |
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
module Swarm.Game.Ingredients (
|
||||
IngredientList,
|
||||
Count,
|
||||
getCost,
|
||||
) where
|
||||
|
||||
-- | A convenient synonym to remind us when an 'Int' is supposed to
|
||||
-- represent /how many/ of something we have.
|
||||
type Count = Int
|
||||
|
||||
-- | An ingredient list is a list of entities with multiplicity. It
|
||||
-- is polymorphic in the entity type so that we can use either
|
||||
-- entity names when serializing, or actual entity objects while the
|
||||
-- game is running.
|
||||
type IngredientList e = [(Count, e)]
|
||||
|
||||
getCost :: IngredientList e -> Int
|
||||
getCost = sum . map fst
|
||||
@ -47,6 +47,7 @@ module Swarm.Game.Recipe (
|
||||
recipesFor,
|
||||
make,
|
||||
make',
|
||||
findLacking,
|
||||
) where
|
||||
|
||||
import Control.Algebra (Has)
|
||||
@ -67,18 +68,13 @@ import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Game.Failure
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||
import Swarm.Util.Effect (withThrow)
|
||||
import Swarm.Util.Lens (makeLensesNoSigs)
|
||||
import Swarm.Util.Yaml
|
||||
import Witch
|
||||
|
||||
-- | An ingredient list is a list of entities with multiplicity. It
|
||||
-- is polymorphic in the entity type so that we can use either
|
||||
-- entity names when serializing, or actual entity objects while the
|
||||
-- game is running.
|
||||
type IngredientList e = [(Count, e)]
|
||||
|
||||
-- | A recipe represents some kind of process where inputs are
|
||||
-- transformed into outputs.
|
||||
data Recipe e = Recipe
|
||||
@ -220,6 +216,13 @@ data MissingIngredient = MissingIngredient MissingType Count Entity
|
||||
data MissingType = MissingInput | MissingCatalyst
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Determines whether recipe inputs are satisfied by a
|
||||
-- robot's inventory.
|
||||
findLacking :: Inventory -> [(Count, Entity)] -> [(Count, Entity)]
|
||||
findLacking robotInventory = filter ((> 0) . fst) . map countNeeded
|
||||
where
|
||||
countNeeded (need, entity) = (need - E.lookup entity robotInventory, entity)
|
||||
|
||||
-- | Figure out which ingredients (if any) are lacking from an
|
||||
-- inventory to be able to carry out the recipe. Catalysts are not
|
||||
-- consumed and so can be used even when equipped.
|
||||
@ -229,8 +232,6 @@ missingIngredientsFor (inv, ins) (Recipe inps _ cats _ _) =
|
||||
<> mkMissing MissingCatalyst (findLacking ins (findLacking inv cats))
|
||||
where
|
||||
mkMissing k = map (uncurry (MissingIngredient k))
|
||||
findLacking inven = filter ((> 0) . fst) . map (countNeeded inven)
|
||||
countNeeded inven (need, entity) = (need - E.lookup entity inven, entity)
|
||||
|
||||
-- | Figure out if a recipe is available, /i.e./ if we at least know
|
||||
-- about all the ingredients. Note it does not matter whether we have
|
||||
@ -259,7 +260,12 @@ make invs r = finish <$> make' invs r
|
||||
finish (invTaken, out) = (invTaken, out, r)
|
||||
|
||||
-- | Try to make a recipe, but do not insert it yet.
|
||||
make' :: (Inventory, Inventory) -> Recipe Entity -> Either [MissingIngredient] (Inventory, IngredientList Entity)
|
||||
make' ::
|
||||
(Inventory, Inventory) ->
|
||||
Recipe Entity ->
|
||||
Either
|
||||
[MissingIngredient]
|
||||
(Inventory, IngredientList Entity)
|
||||
make' invs@(inv, _) r =
|
||||
case missingIngredientsFor invs r of
|
||||
[] ->
|
||||
|
||||
@ -71,18 +71,18 @@ import Control.Applicative ((<|>))
|
||||
import Control.Lens hiding (Const, contains)
|
||||
import Data.Hashable (hashWithSalt)
|
||||
import Data.Kind qualified
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml (FromJSON (parseJSON), (.!=), (.:), (.:?))
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import Swarm.Game.Device
|
||||
import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible)
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Ingredients
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Location (Heading, Location, toDirection, toHeading)
|
||||
import Swarm.Game.Robot.Walk
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Language.Capability (Capability)
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Language.Syntax (Syntax)
|
||||
import Swarm.Language.Text.Markdown (Document)
|
||||
@ -134,7 +134,7 @@ type instance RobotLogUpdatedMember 'TemplateRobot = ()
|
||||
data RobotR (phase :: RobotPhase) = RobotR
|
||||
{ _robotEntity :: Entity
|
||||
, _equippedDevices :: Inventory
|
||||
, _robotCapabilities :: Set Capability
|
||||
, _robotCapabilities :: MultiEntityCapabilities Entity EntityName
|
||||
-- ^ A cached view of the capabilities this robot has.
|
||||
-- Automatically generated from '_equippedDevices'.
|
||||
, _robotLog :: RobotLogMember phase
|
||||
@ -288,7 +288,7 @@ robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^.
|
||||
-- getter, not a lens, because it is automatically generated from
|
||||
-- the 'equippedDevices'. The only way to change a robot's
|
||||
-- capabilities is to modify its 'equippedDevices'.
|
||||
robotCapabilities :: Getter Robot (Set Capability)
|
||||
robotCapabilities :: Getter Robot (MultiEntityCapabilities Entity EntityName)
|
||||
robotCapabilities = to _robotCapabilities
|
||||
|
||||
-- | Is this robot a "system robot"? System robots are generated by
|
||||
@ -303,7 +303,7 @@ selfDestruct :: Lens' Robot Bool
|
||||
runningAtomic :: Lens' Robot Bool
|
||||
walkabilityContext :: Getter Robot WalkabilityContext
|
||||
walkabilityContext = to $
|
||||
\x -> WalkabilityContext (_robotCapabilities x) (_unwalkableEntities x)
|
||||
\x -> WalkabilityContext (getCapabilitySet $ _robotCapabilities x) (_unwalkableEntities x)
|
||||
|
||||
-- | A general function for creating robots.
|
||||
mkRobot ::
|
||||
@ -336,7 +336,7 @@ mkRobot ::
|
||||
mkRobot pid name descr loc dir disp m devs inv sys heavy unwalkables ts =
|
||||
RobotR
|
||||
{ _robotEntity =
|
||||
mkEntity disp name descr [] []
|
||||
mkEntity disp name descr [] mempty
|
||||
& entityOrientation ?~ dir
|
||||
& entityInventory .~ fromElems inv
|
||||
, _equippedDevices = inst
|
||||
|
||||
@ -183,11 +183,13 @@ library swarm-scenario
|
||||
exposed-modules:
|
||||
Swarm.Constant
|
||||
Swarm.Game.Achievement.Definitions
|
||||
Swarm.Game.Device
|
||||
Swarm.Game.Display
|
||||
Swarm.Game.Entity
|
||||
Swarm.Game.Entity.Cosmetic
|
||||
Swarm.Game.Entity.Cosmetic.Assignment
|
||||
Swarm.Game.Failure
|
||||
Swarm.Game.Ingredients
|
||||
Swarm.Game.Land
|
||||
Swarm.Game.Location
|
||||
Swarm.Game.Recipe
|
||||
@ -532,12 +534,14 @@ library
|
||||
Swarm.Game.Achievement.Description,
|
||||
Swarm.Game.Achievement.Persistence,
|
||||
Swarm.Game.CESK,
|
||||
Swarm.Game.Device,
|
||||
Swarm.Game.Display,
|
||||
Swarm.Game.Entity,
|
||||
Swarm.Game.Entity.Cosmetic,
|
||||
Swarm.Game.Entity.Cosmetic.Assignment,
|
||||
Swarm.Game.Exception,
|
||||
Swarm.Game.Failure,
|
||||
Swarm.Game.Ingredients,
|
||||
Swarm.Game.Land,
|
||||
Swarm.Game.Location,
|
||||
Swarm.Game.Recipe,
|
||||
|
||||
@ -370,6 +370,7 @@ testScenarioSolutions rs ui =
|
||||
, testSolution Default "Testing/1631-tags"
|
||||
, testSolution Default "Testing/1747-volume-command"
|
||||
, testSolution Default "Testing/1775-custom-terrain"
|
||||
, testSolution Default "Testing/1777-capability-cost"
|
||||
, testGroup
|
||||
-- Note that the description of the classic world in
|
||||
-- data/worlds/classic.yaml (automatically tested to some
|
||||
|
||||
@ -109,6 +109,6 @@ testInventory =
|
||||
)
|
||||
]
|
||||
where
|
||||
x = E.mkEntity (defaultEntityDisplay 'X') "fooX" mempty [] []
|
||||
y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" mempty [] []
|
||||
z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" mempty [] []
|
||||
x = E.mkEntity (defaultEntityDisplay 'X') "fooX" mempty [] mempty
|
||||
y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" mempty [] mempty
|
||||
z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" mempty [] mempty
|
||||
|
||||
@ -8,9 +8,11 @@
|
||||
module TestRecipeCoverage where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map qualified as M
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as T
|
||||
import Swarm.Game.Device
|
||||
import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName)
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Recipe (recipeOutputs)
|
||||
@ -43,7 +45,7 @@ testDeviceRecipeCoverage gsi =
|
||||
|
||||
-- Only include entities that grant a capability:
|
||||
entityNames =
|
||||
Set.fromList . map (^. entityName) . concat . M.elems . entitiesByCap $
|
||||
Set.fromList . map ((^. entityName) . device) . concatMap NE.toList . M.elems . getMap . entitiesByCap $
|
||||
initEntityTerrain (gsiScenarioInputs gsi) ^. entityMap
|
||||
|
||||
getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs
|
||||
|
||||
Loading…
Reference in New Issue
Block a user