From c94c4997ecb1033c6249849c472b674938185fea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Wed, 8 Jun 2022 17:44:39 +0200 Subject: [PATCH 01/30] Add iron - add iron ore - add iron mine and iron vein - section the recipes for easier discoverability --- data/entities.yaml | 27 ++++++++++ data/recipes.yaml | 101 +++++++++++++++++++++++++++++-------- src/Swarm/Game/WorldGen.hs | 2 + src/Swarm/TUI/Attr.hs | 6 +++ 4 files changed, 114 insertions(+), 22 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index 091857b4f..45877511e 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -137,6 +137,33 @@ water or steam. properties: [portable] +- name: iron ore + display: + attr: copper + char: 'C' + description: + - Raw iron ore. Used to create more resilient tools. + - It can only be mined by drilling in the mountains. + properties: [portable] + +- name: iron vein + display: + attr: iron' + char: 'A' + description: + - A place in the mountains where raw iron ore can be mined. + As it is hidden inside a mountain, a tunnel needs to be + first drilled through, so that the vein becomes accessible. + properties: [unwalkable] + +- name: iron mine + display: + attr: iron' + char: 'Å' + description: + - An iron vein that can be actively mined to produce iron ore. + properties: [] + - name: furnace display: attr: fire diff --git a/data/recipes.yaml b/data/recipes.yaml index 2fd80ef4c..7f238bd70 100644 --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -1,3 +1,7 @@ +######################################### +## WOOD ## +######################################### + - in: - [1, tree] out: @@ -40,6 +44,17 @@ out: - [1, gear] +- in: + - [1, box] + - [1, drill bit] + - [1, motor] + out: + - [1, drill] + +######################################### +## BITS ## +######################################### + - in: - [1, bit (0)] - [1, bit (1)] @@ -47,11 +62,14 @@ - [1, drill bit] - in: - - [1, box] - - [1, drill bit] - - [1, motor] + - [8, bit (0)] + - [8, bit (1)] out: - - [1, drill] + - [1, counter] + +######################################### +## STONE ## +######################################### - in: - [1, boulder] @@ -81,6 +99,17 @@ - [1, drill] time: 90 +- in: + - [5, rock] + out: + - [1, furnace] + +######################################### +## METAL ## +######################################### + +## VEINS + - in: - [1, copper vein] out: @@ -89,6 +118,16 @@ - [1, drill] time: 42 +- in: + - [1, iron vein] + out: + - [1, iron mine] + required: + - [1, drill] + time: 42 + +## MINES + - in: - [1, copper mine] out: @@ -99,9 +138,15 @@ time: 42 - in: - - [5, rock] + - [1, iron mine] out: - - [1, furnace] + - [1, iron ore] + - [1, iron mine] + required: + - [1, drill] + time: 42 + +## SMELTING - in: - [1, copper ore] @@ -119,6 +164,31 @@ required: - [1, furnace] +- in: + - [1, iron ore] + - [2, log] + out: + - [2, iron plate] + required: + - [1, furnace] + +## TOOLS + +- in: + - [32, gear] + - [6, copper wire] + out: + - [1, motor] + +- in: + - [2, copper wire] + out: + - [1, strange loop] + +######################################### +## SAND ## +######################################### + - in: - [1, sand] out: @@ -140,25 +210,12 @@ out: - [1, calculator] -- in: - - [32, gear] - - [6, copper wire] - out: - - [1, motor] - -- in: - - [2, copper wire] - out: - - [1, strange loop] +######################################### +## LAMBDA ## +######################################### - in: - [5, lambda] - [1, water] out: - [1, curry] - -- in: - - [8, bit (0)] - - [8, bit (1)] - out: - - [1, counter] diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs index 6dd5e4088..c011b2147 100644 --- a/src/Swarm/Game/WorldGen.hs +++ b/src/Swarm/Game/WorldGen.hs @@ -58,6 +58,7 @@ testWorld2 baseSeed (Coords ix@(r, c)) = genBiome Big Hard Natural | sample ix cl0 > 0.5 && sample ix rg0 > 0.999 = (StoneT, Just "copper vein") + | sample ix cl0 > 0.5 && sample ix rg1 > 0.999 = (StoneT, Just "iron vein") | sample ix cl0 > 0.5 = (StoneT, Just "mountain") | h `mod` 30 == 0 = (StoneT, Just "boulder") | sample ix cl0 > 0 = (DirtT, Just "tree") @@ -99,6 +100,7 @@ testWorld2 baseSeed (Coords ix@(r, c)) = rg seed = ridged seed 6 0.05 1 2 rg0 = rg 42 + rg1 = rg 66 clumps :: Int -> Perlin clumps seed = perlin (seed + baseSeed) 4 0.08 0.5 diff --git a/src/Swarm/TUI/Attr.hs b/src/Swarm/TUI/Attr.hs index 840bcf2cf..509e84ade 100644 --- a/src/Swarm/TUI/Attr.hs +++ b/src/Swarm/TUI/Attr.hs @@ -38,6 +38,8 @@ swarmAttrMap = , (flowerAttr, fg (V.rgbColor @Int 200 0 200)) , (copperAttr, fg V.yellow) , (copperAttr', fg (V.rgbColor @Int 78 117 102)) + , (ironAttr, fg (V.rgbColor @Int 97 102 106)) + , (ironAttr', fg (V.rgbColor @Int 183 65 14)) , (snowAttr, fg V.white) , (sandAttr, fg (V.rgbColor @Int 194 178 128)) , (fireAttr, fg V.red `V.withStyle` V.bold) @@ -66,6 +68,8 @@ robotAttr , flowerAttr , copperAttr , copperAttr' + , ironAttr + , ironAttr' , snowAttr , sandAttr , rockAttr @@ -94,6 +98,8 @@ plantAttr = "plant" flowerAttr = "flower" copperAttr = "copper" copperAttr' = "copper'" +ironAttr = "iron" +ironAttr' = "iron'" snowAttr = "snow" sandAttr = "sand" fireAttr = "fire" From d231ab88f2b457fa6b6a06d5fc6b4cb9d19183ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Wed, 8 Jun 2022 18:01:11 +0200 Subject: [PATCH 02/30] Make iron gear - split gear into iron/wooden gear --- data/entities.yaml | 11 ++++++++++- data/recipes.yaml | 35 ++++++++++++++++++++++++----------- 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index 45877511e..c251e880f 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -295,7 +295,7 @@ - A wooden box. It can hold things. properties: [portable] -- name: gear +- name: wooden gear display: attr: wood char: '*' @@ -303,6 +303,15 @@ - A wooden gear. properties: [portable] +- name: iron gear + display: + attr: wood + char: '*' + description: + - An iron gear that is more resilient. + - It can be used to create bigger and more complex machines. + properties: [portable] + - name: counter display: attr: device diff --git a/data/recipes.yaml b/data/recipes.yaml index 7f238bd70..bf4b991d5 100644 --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -42,14 +42,7 @@ - in: - [2, board] out: - - [1, gear] - -- in: - - [1, box] - - [1, drill bit] - - [1, motor] - out: - - [1, drill] + - [1, wooden gear] ######################################### ## BITS ## @@ -124,7 +117,7 @@ - [1, iron mine] required: - [1, drill] - time: 42 + time: 64 ## MINES @@ -144,7 +137,7 @@ - [1, iron mine] required: - [1, drill] - time: 42 + time: 64 ## SMELTING @@ -175,11 +168,31 @@ ## TOOLS - in: - - [32, gear] + - [1, iron plate] + out: + - [2, iron gear] + +- in: + - [32, wooden gear] - [6, copper wire] out: - [1, motor] +- in: + - [16, iron gear] + - [6, copper wire] + out: + - [1, motor] + +- in: + - [1, box] + - [1, drill bit] + - [1, motor] + out: + - [1, drill] + +## MAGIC + - in: - [2, copper wire] out: From 95752fcd646c52b570e9c4decfc78baff421b0f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Wed, 8 Jun 2022 18:24:16 +0200 Subject: [PATCH 03/30] Make iron or wooden motors and gears --- data/entities.yaml | 39 ++++++++++++++++++++++++++++++++++++++- data/recipes.yaml | 13 ++++++++++--- 2 files changed, 48 insertions(+), 4 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index c251e880f..ccb896707 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -137,6 +137,23 @@ water or steam. properties: [portable] +- name: iron plate + display: + attr: iron + char: '■' + description: + - Raw iron ore. Used to create more resilient tools. + - It can only be mined by drilling in the mountains. + properties: [portable] + +- name: iron gear + display: + attr: iron + char: '*' + description: + - An iron gear. + properties: [portable] + - name: iron ore display: attr: copper @@ -172,13 +189,24 @@ - A furnace can be used to turn metal ore into various useful products. properties: [portable] -- name: motor +- name: small motor + display: + attr: entity + char: 'm' + description: + - A motor is useful for making devices that can turn when electric + current is applied. + - This one is rather small, but suprisingly efficient. + properties: [portable] + +- name: big motor display: attr: entity char: 'M' description: - A motor is useful for making devices that can turn when electric current is applied. + - This one is huge and could be used to construct powerful machinery. properties: [portable] - name: flower @@ -464,6 +492,15 @@ capabilities: [drill] properties: [portable] +- name: metal drill + display: + attr: iron + char: '!' + description: + - A metal drill allows robots to drill through rocks and mountains faster. + capabilities: [drill] + properties: [portable] + - name: 3D printer display: attr: device diff --git a/data/recipes.yaml b/data/recipes.yaml index bf4b991d5..35e589226 100644 --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -176,21 +176,28 @@ - [32, wooden gear] - [6, copper wire] out: - - [1, motor] + - [1, small motor] - in: - [16, iron gear] - [6, copper wire] out: - - [1, motor] + - [1, big motor] - in: - [1, box] - [1, drill bit] - - [1, motor] + - [1, small motor] out: - [1, drill] +- in: + - [1, box] + - [3, drill bit] + - [1, big motor] + out: + - [1, metal drill] + ## MAGIC - in: From 99ce4d282dbafd9fde498124c255efb3466fe269 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Wed, 8 Jun 2022 20:39:49 +0200 Subject: [PATCH 04/30] Add metal drill recipes - add drill test challenge! - add recipes with metal drill - make iron veins slightly more likely --- data/recipes.yaml | 50 +++++++++++- data/scenarios/01-creative.yaml | 3 + .../scenarios/03Challenges/02-drill_test.yaml | 76 +++++++++++++++++++ src/Swarm/Game/Scenario.hs | 4 +- src/Swarm/Game/Step.hs | 9 ++- src/Swarm/Game/WorldGen.hs | 2 +- 6 files changed, 138 insertions(+), 6 deletions(-) create mode 100644 data/scenarios/03Challenges/02-drill_test.yaml diff --git a/data/recipes.yaml b/data/recipes.yaml index 35e589226..686504850 100644 --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -86,12 +86,22 @@ - in: - [1, mountain] out: - - [9, rock] + - [8, rock] - [1, mountain tunnel] required: - [1, drill] time: 90 +- in: + - [1, mountain] + out: + - [16, rock] + - [1, mountain tunnel] + required: + - [1, metal drill] + time: 9 + + - in: - [5, rock] out: @@ -107,6 +117,7 @@ - [1, copper vein] out: - [1, copper mine] + - [1, copper ore] required: - [1, drill] time: 42 @@ -115,10 +126,29 @@ - [1, iron vein] out: - [1, iron mine] + - [1, iron ore] required: - [1, drill] time: 64 +- in: + - [1, copper vein] + out: + - [1, copper mine] + - [1, copper ore] + required: + - [1, metal drill] + time: 6 + +- in: + - [1, iron vein] + out: + - [1, iron mine] + - [1, iron ore] + required: + - [1, metal drill] + time: 7 + ## MINES - in: @@ -139,6 +169,24 @@ - [1, drill] time: 64 +- in: + - [1, copper mine] + out: + - [1, copper ore] + - [1, copper mine] + required: + - [1, metal drill] + time: 6 + +- in: + - [1, iron mine] + out: + - [1, iron ore] + - [1, iron mine] + required: + - [1, metal drill] + time: 7 + ## SMELTING - in: diff --git a/data/scenarios/01-creative.yaml b/data/scenarios/01-creative.yaml index 440dc531a..08880318e 100644 --- a/data/scenarios/01-creative.yaml +++ b/data/scenarios/01-creative.yaml @@ -6,6 +6,9 @@ robots: - name: base loc: [0,0] dir: [0,0] + display: + char: Ω + attr: robot world: seed: null offset: true \ No newline at end of file diff --git a/data/scenarios/03Challenges/02-drill_test.yaml b/data/scenarios/03Challenges/02-drill_test.yaml new file mode 100644 index 000000000..830e291d8 --- /dev/null +++ b/data/scenarios/03Challenges/02-drill_test.yaml @@ -0,0 +1,76 @@ +name: Test drill +description: This is a developer playground and will be replaced with more suitable challenges soon. +entities: + - name: goal + display: + attr: device + char: 'X' + description: + - Send robots to mine rock, iron and copper. + properties: [portable] + - name: knownwater + display: + attr: water + char: ' ' + description: + - An infinite ocean of water. + properties: [known, portable, growable, liquid] + growth: [0,0] + yields: water + - name: knownwater' + display: + attr: water + char: '~' + description: + - An infinite ocean of water. + properties: [known, portable, growable, liquid] + growth: [0,0] + yields: water +win: | + try { + i <- as base {has "iron ore"}; + c <- as base {has "copper ore"}; + s <- as base {has "rock"}; + return (i && c && s) + } { return false } +robots: + - name: base + loc: [0,-2] + dir: [1,0] + display: + char: Ω + attr: robot + devices: + - logger + - grabber + - plasma cutter + - 3D printer + inventory: + - [1, goal] + - [2, metal drill] + - [1, drill] + - [2, logger] +world: + default: [ice, knownwater] + palette: + '.': [grass, null] + ' ': [ice, knownwater] + 'L': [grass, Linux] + 'T': [grass, tree] + '~': [ice, knownwater'] + '┌': [stone, upper left corner] + '┐': [stone, upper right corner] + '└': [stone, lower left corner] + '┘': [stone, lower right corner] + '─': [stone, horizontal wall] + '│': [stone, vertical wall] + 'A': [stone, mountain] + 'C': [stone, copper vein] + 'I': [stone, iron vein] + upperleft: [-1, 1] + map: | + ┌──── ~~ + │IAAT~ ~L~ + │..AAA│ ~~ + │....C│ ~ + └─────┘ ~ diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 5bd78f1bf..d4ef49d07 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -165,11 +165,11 @@ mkWorldFun pwd = E $ \em -> do wd <- pwd let toEntity :: Char -> Parser (Int, Maybe Entity) toEntity c = case KeyMap.lookup (Key.fromString [c]) (unPalette (palette wd)) of - Nothing -> fail $ "Char not in entity palette: " ++ [c] + Nothing -> fail $ "Char not in entity palette: " ++ show c Just (t, mt) -> case mt of Nothing -> return (fromEnum t, Nothing) Just name -> case lookupEntityName name em of - Nothing -> fail $ "Unknown entity name: " ++ from @Text name + Nothing -> fail $ "Unknown entity name: " ++ show name Just e -> return (fromEnum t, Just e) grid = map (into @String) . T.lines $ area wd diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index ea930a134..d6e7faf9a 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -898,8 +898,12 @@ execConst c vs s k = do rDir <- use robotOrientation let nextLoc = loc ^+^ applyTurn d (rDir ? V2 0 0) - em <- use entityMap - drill <- lookupEntityName "drill" em `isJustOr` Fatal "Drill does not exist?!" + + let toyDrill = lookupByName "drill" ins + metalDrill = lookupByName "metal drill" ins + insDrill = listToMaybe $ metalDrill <> toyDrill + + drill <- insDrill `isJustOr` Fatal "Drill is required but not installed?!" nextME <- entityAt nextLoc nextE <- nextME @@ -1400,6 +1404,7 @@ execConst c vs s k = do [ "Bad application of execConst:" , from (prettyCESK (Out (VCApp c (reverse vs)) s k)) ] + finishCookingRecipe :: (Has (State GameState) sig m, Has (Throw Exn) sig m) => Recipe e -> diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs index c011b2147..540b6333d 100644 --- a/src/Swarm/Game/WorldGen.hs +++ b/src/Swarm/Game/WorldGen.hs @@ -58,7 +58,7 @@ testWorld2 baseSeed (Coords ix@(r, c)) = genBiome Big Hard Natural | sample ix cl0 > 0.5 && sample ix rg0 > 0.999 = (StoneT, Just "copper vein") - | sample ix cl0 > 0.5 && sample ix rg1 > 0.999 = (StoneT, Just "iron vein") + | sample ix cl0 > 0.5 && sample ix rg1 > 0.99 = (StoneT, Just "iron vein") | sample ix cl0 > 0.5 = (StoneT, Just "mountain") | h `mod` 30 == 0 = (StoneT, Just "boulder") | sample ix cl0 > 0 = (DirtT, Just "tree") From 32f1ac05d5844afbcbac9ec83c8bb31fca281bca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Thu, 9 Jun 2022 00:14:53 +0200 Subject: [PATCH 05/30] Handle multiple capability providers - try to find if robot has at least one entity providing capability - when no entity could provide the capability reject it too This "improvement" only concerns build and reprogram comands. They could use a refactor after this, as the common capability checking part should be moved into helper function or to Entity.hs --- .../scenarios/03Challenges/02-drill_test.yaml | 4 +- src/Swarm/Game/Entity.hs | 10 +-- src/Swarm/Game/Step.hs | 81 ++++++++++++------- 3 files changed, 60 insertions(+), 35 deletions(-) diff --git a/data/scenarios/03Challenges/02-drill_test.yaml b/data/scenarios/03Challenges/02-drill_test.yaml index 830e291d8..9ce9db7ac 100644 --- a/data/scenarios/03Challenges/02-drill_test.yaml +++ b/data/scenarios/03Challenges/02-drill_test.yaml @@ -49,7 +49,7 @@ robots: - [1, goal] - [2, metal drill] - [1, drill] - - [2, logger] + - [3, logger] world: default: [ice, knownwater] palette: @@ -69,7 +69,7 @@ world: 'I': [stone, iron vein] upperleft: [-1, 1] map: | - ┌──── ~~ + ┌─────┐ ~~ │IAAT~ ~L~ │..AAA│ ~~ │....C│ ~ diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index b166a3490..366764c5f 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -100,7 +100,7 @@ import qualified Data.IntSet as IS import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (isJust, listToMaybe) +import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) @@ -289,7 +289,7 @@ mkEntity disp nm descr props = -- capabilities they provide (if any). data EntityMap = EntityMap { entitiesByName :: Map Text Entity - , entitiesByCap :: Map Capability Entity + , entitiesByCap :: Map Capability [Entity] } instance Semigroup EntityMap where @@ -305,8 +305,8 @@ lookupEntityName nm = M.lookup nm . entitiesByName -- | Find an entity which is a device that provides the given -- capability. -deviceForCap :: Capability -> EntityMap -> Maybe Entity -deviceForCap cap = M.lookup cap . entitiesByCap +deviceForCap :: Capability -> EntityMap -> [Entity] +deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap -- | Build an 'EntityMap' from a list of entities. The idea is that -- this will be called once at startup, when loading the entities @@ -315,7 +315,7 @@ buildEntityMap :: [Entity] -> EntityMap buildEntityMap es = EntityMap { entitiesByName = M.fromList . map (view entityName &&& id) $ es - , entitiesByCap = M.fromList . concatMap (\e -> map (,e) (e ^. entityCapabilities)) $ es + , entitiesByCap = M.fromListWith (<>) . concatMap (\e -> map (,[e]) (e ^. entityCapabilities)) $ es } ------------------------------------------------------------ diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index d6e7faf9a..b338ca16c 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -20,7 +20,7 @@ -- interpreter for the Swarm language. module Swarm.Game.Step where -import Control.Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) +import Control.Lens as Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) import Control.Monad (forM_, guard, msum, unless, when) import Data.Array (bounds, (!)) import Data.Bool (bool) @@ -65,6 +65,7 @@ import Control.Carrier.Throw.Either (ThrowC, runThrow) import Control.Effect.Error import Control.Effect.Lens import Control.Effect.Lift +import Data.Containers.ListUtils (nubOrd) import Data.Functor (void) -- | The maximum number of CESK machine evaluation steps each robot is @@ -1176,18 +1177,29 @@ execConst c vs s k = do -- be run on the other robot, and what devices would provide those -- capabilities. (caps, _capCtx) = requiredCaps (r ^. robotContext . defCaps) cmd - capDevices = S.fromList . mapMaybe (`deviceForCap` em) . S.toList $ caps + + -- list of possible devices per capability + capDevices = map (`deviceForCap` em) . S.toList $ caps -- device is ok if it is installed on the childRobot deviceOK d = (childRobot ^. installedDevices) `E.contains` d + ignoreOK ([], miss) = ([], miss) + ignoreOK (ds, _miss) = (ds, []) + + (deviceSets, missingDeviceSets) = + Lens.over _2 (nubOrd . map S.fromList) . unzip $ + map (ignoreOK . L.partition deviceOK) capDevices - missingDevices = S.filter (not . deviceOK) capDevices + formatDevices = T.intercalate " or " . map (^. entityName) . S.toList -- check if robot has all devices to execute new command - (creative || S.null missingDevices) - `holdsOrFail` [ "the target robot does not have required devices:" - , commaList (map (^. entityName) (S.toList missingDevices)) - ] + (creative || all null missingDeviceSets) + `holdsOrFail` ( "the target robot does not have required devices:" : + (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) + ) + + (creative || not (any null deviceSets)) + `holdsOrFail` ["the target robot cannot perform an impossible task"] -- update other robot's CESK machine, environment and context -- the childRobot inherits the parent robot's environment @@ -1223,7 +1235,7 @@ execConst c vs s k = do -- would return the capabilities needed to *execute* them), -- hopefully without duplicating too much code. [VDelay cmd e] -> do - r <- get + r <- get @Robot em <- use entityMap creative <- use creativeMode @@ -1236,33 +1248,46 @@ execConst c vs s k = do ["treads", "grabber", "solar panel", "scanner", "plasma cutter"] stdDevices = S.fromList $ mapMaybe (`lookupEntityName` em) stdDeviceList - -- Find out what capabilities are required by the program that will - -- be run on the newly constructed robot, and what devices would - -- provide those capabilities. - (caps, _capCtx) = requiredCaps (r ^. robotContext . defCaps) cmd - capDevices = S.fromList . mapMaybe (`deviceForCap` em) . S.toList $ caps + -- Note that _capCtx must be empty: at least at the + -- moment, definitions are only allowed at the top level, + -- so there can't be any inside the argument to build. + -- (Though perhaps there is an argument that this ought to + -- be relaxed specifically in the case of 'Build'.) + -- See #349 - -- Note that _capCtx must be empty: at least at the - -- moment, definitions are only allowed at the top level, - -- so there can't be any inside the argument to build. - -- (Though perhaps there is an argument that this ought to - -- be relaxed specifically in the case of 'Build'.) + let -- Find out what capabilities are required by the program that will + -- be run on the other robot, and what devices would provide those + -- capabilities. + (caps, _capCtx) = requiredCaps (r ^. robotContext . defCaps) cmd - -- The devices that need to be installed on the new robot is the union - -- of these two sets. - devices = stdDevices `S.union` capDevices + -- list of possible devices per capability + capDevices = map (`deviceForCap` em) . S.toList $ caps -- A device is OK to install if it is a standard device, or we have one -- in our inventory. deviceOK d = d `S.member` stdDevices || (r ^. robotInventory) `E.contains` d + ignoreOK ([], miss) = ([], miss) + ignoreOK (ds, _miss) = (ds, []) + + (deviceSets, missingDeviceSets) = + Lens.over both (nubOrd . map S.fromList) . unzip $ + map (ignoreOK . L.partition deviceOK) capDevices - missingDevices = S.filter (not . deviceOK) capDevices + -- if given a choice between required devices giving same capability + devices = + if creative + then S.unions deviceSets -- give them all in creative + else S.unions $ map (S.take 1) deviceSets -- give first one otherwise + formatDevices = T.intercalate " or " . map (^. entityName) . S.toList - -- Make sure we're not missing any required devices. - (creative || S.null missingDevices) - `holdsOrFail` [ "this would require installing devices you don't have:" - , commaList (map (^. entityName) (S.toList missingDevices)) - ] + -- check if robot has all devices to execute new command + (creative || all null missingDeviceSets) + `holdsOrFail` ( "this would require installing devices you don't have:" : + (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) + ) + + (creative || not (any null deviceSets)) + `holdsOrFail` ["no robot could perform such impossible task"] -- Pick a random display name. displayName <- randomName @@ -1404,7 +1429,7 @@ execConst c vs s k = do [ "Bad application of execConst:" , from (prettyCESK (Out (VCApp c (reverse vs)) s k)) ] - + finishCookingRecipe :: (Has (State GameState) sig m, Has (Throw Exn) sig m) => Recipe e -> From 06b9f28345b87376c25db62a909fcbf4da113bf8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Fri, 10 Jun 2022 13:46:23 +0200 Subject: [PATCH 06/30] Fix entity attributes (thanks @byorgey) Co-authored-by: Brent Yorgey --- data/entities.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index ccb896707..151b8e3e5 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -156,8 +156,8 @@ - name: iron ore display: - attr: copper - char: 'C' + attr: iron + char: 'F' description: - Raw iron ore. Used to create more resilient tools. - It can only be mined by drilling in the mountains. @@ -333,7 +333,7 @@ - name: iron gear display: - attr: wood + attr: iron char: '*' description: - An iron gear that is more resilient. From 5650d512a065122e5fd20a53fb34d80775c710fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 14:40:53 +0200 Subject: [PATCH 07/30] Fix iron plate description --- data/entities.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index 151b8e3e5..2268dd286 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -142,8 +142,8 @@ attr: iron char: '■' description: - - Raw iron ore. Used to create more resilient tools. - - It can only be mined by drilling in the mountains. + - Worked iron suitable for crafting resilient tools. + - It also possess some electro-magnetic properties. properties: [portable] - name: iron gear From 7cee36f0678d533869610f15466a03930d7988da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 14:44:38 +0200 Subject: [PATCH 08/30] Add compass device Closes #341 --- TUTORIAL.md | 34 ++++++++++++++------------ bench/Benchmark.hs | 8 +----- data/entities.yaml | 16 ++++++++++-- data/recipes.yaml | 7 ++++++ data/scenarios/00-classic.yaml | 2 +- data/scenarios/02Tutorial/01-turn.yaml | 1 + src/Swarm/Language/Capability.hs | 6 ++++- src/Swarm/Language/Syntax.hs | 7 +++++- 8 files changed, 54 insertions(+), 27 deletions(-) diff --git a/TUTORIAL.md b/TUTORIAL.md index 7ee596b41..15d6ffaec 100644 --- a/TUTORIAL.md +++ b/TUTORIAL.md @@ -71,7 +71,7 @@ Pretty much the only thing you can do at this point is build robots. Let's buil one! Tab back to the REPL (or hit the Meta+R shortcut) and type ``` -build {turn north; move} +build {move} ``` then hit Enter. You should see a robot appear and travel to the north one step before stopping. It should look something like this: @@ -187,9 +187,12 @@ def m2 = m; m end; def m4 = m2; m2 end; def m8 = m4; m4 end Great, now we have commands that will execute `move` multiple times. Now let's use them: ``` -build { turn west; m4; m } +build { turn left; m4; m } ``` This should build a robot that moves toward the green mass to the west. +The base is still turned north, so the robot needs to turn left +to be oriented to the west. Once you have a compass to install on +the robot, you will be able to `turn west` directly. You might wonder at this point if it is possible to create a function that takes a number as input and moves that many steps forward, like @@ -213,7 +216,7 @@ Let's build another robot, but this time we will capture it in a variable using the above syntax. Then we can use the `view` command to focus on it instead of the base: ``` -r <- build { turn west; m4; m }; view r +r <- build { turn left; m4; m }; view r ``` Note that `base` executes the `view r` command as soon as it finishes executing the `build` command, which is about the same time @@ -250,18 +253,19 @@ You can `scan` items in the world to learn about them, and later Let's build a robot to learn about those green `?` things to the west: ``` -build {turn west; m4; move; scan west; turn back; m4; upload base} +build {turn left; m4; move; scan forward; turn back; m4; upload base} ``` The `turn` command we used to turn the robot takes a direction as an -argument, which can be either an absolute direction -(`north`, `south`, `east`, or `west`) or a relative direction -(`forward`, `back`, `left`, `right`, or `down`). Instead of `upload -base` we could have also written `upload parent`; every robot has a -special variable `parent` which refers to the robot that built it. +argument, which can be either a relative direction (`forward`, `back`, +`left`, `right`, or `down`) or an absolute direction (`north`, `south`, +`east`, or `west`) for which you need a `compass`. +Instead of `upload base` we could have also written `upload parent`; +every robot has a special variable `parent` which refers to the robot +that built it. Notice that the robot did not actually need to walk on top of a `?` to -learn about it, since it could `scan west` to scan the cell one unit -to the west (you can also `scan down` to scan an item directly beneath the +learn about it, since it could `scan forward` to scan the cell one unit +in its direction (you can also `scan down` to scan an item directly beneath the robot). Also, it was able to `upload` at a distance of one cell away from the base. @@ -338,14 +342,14 @@ First, we have to make a `logger` device. A `logger` can be made from one `log`, which you should already have in your inventory, so simply type `make "logger"` at the REPL. -Now, how de we `build` a robot with the `logger` installed? The +Now, how do we `build` a robot with the `logger` installed? The easiest way is to have the robot explicitly use the `log` command; the `build` command analyzes the given program and automatically installs any devices that will be necessary to execute it. (It is also possible to manually install devices with the `install` command.) So let's type the following: ``` -crasher <- build {setname "crasher"; log "hi!"; turn south; move; grab; move} +crasher <- build {setname "crasher"; log "hi!"; turn back; move; grab; move} ``` (The `setname "crasher"` command is not strictly necessary, but will help us understand the logs we look at later --- otherwise the log @@ -382,9 +386,9 @@ the `upload` command, which we have seen before. In addition to uploading knowledge about entities, it turns out that it also uploads the log from a `logger`. ``` -build {turn west; m8; m; thing <- grab; turn back; m8; m; give base thing} +build {turn left; m8; m; thing <- grab; turn back; m8; m; give base thing} make "log"; make "logger" -build {setname "salvager"; turn south; move; log "salvaging..."; salvage; turn back; move; upload base} +build {setname "salvager"; turn back; move; log "salvaging..."; salvage; turn back; move; upload base} ``` The world should now look something like this: diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index 4c7f444e9..bae7632d3 100644 --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -60,13 +60,7 @@ circlerProgram = let forever : cmd () -> cmd () = \c. c; forever c in forever ( move; - turn east; - move; - turn south; - move; - turn west; - move; - turn north + turn right; ) |] diff --git a/data/entities.yaml b/data/entities.yaml index 2268dd286..90319b9be 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -428,7 +428,7 @@ - Installing treads on a robot allows it to move (via the 'move' command) and turn (via the 'turn' command). - 'Example:' - - ' move; turn left; move; turn north' + - ' move; turn left; move; turn right' capabilities: [move, turn] properties: [portable] @@ -551,7 +551,7 @@ is 'if' followed by three arguments: a boolean test and then two delayed expressions of the same type. - 'Example:' - - 'if (x > 3) {move} {turn west; move}' + - 'if (x > 3) {move} {turn right; move}' properties: [portable] capabilities: [cond] @@ -648,3 +648,15 @@ exponentiation." properties: [portable] capabilities: [arith] + +- name: compass + display: + attr: device + char: 'N' + description: + - "A compass gives robot the ability to orient itself in cardinal directions." + - "That is north, south, west and east." + - "Example:" + - "turn west; move; turn north" + properties: [portable] + capabilities: [orient] \ No newline at end of file diff --git a/data/recipes.yaml b/data/recipes.yaml index 686504850..225a0bf64 100644 --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -220,6 +220,13 @@ out: - [2, iron gear] +- in: + - [1, iron plate] + - [1, water] + - [1, box] + out: + - [1, compass] + - in: - [32, wooden gear] - [6, copper wire] diff --git a/data/scenarios/00-classic.yaml b/data/scenarios/00-classic.yaml index ff33d52d6..5347f99e9 100644 --- a/data/scenarios/00-classic.yaml +++ b/data/scenarios/00-classic.yaml @@ -3,7 +3,7 @@ description: The classic open-world, resource-gathering version of the game. Yo robots: - name: base loc: [0,0] - dir: [1,0] + dir: [0,1] display: char: Ω attr: robot diff --git a/data/scenarios/02Tutorial/01-turn.yaml b/data/scenarios/02Tutorial/01-turn.yaml index 10aa04469..667064184 100644 --- a/data/scenarios/02Tutorial/01-turn.yaml +++ b/data/scenarios/02Tutorial/01-turn.yaml @@ -30,6 +30,7 @@ robots: dir: [1,0] devices: - treads + - compass - logger inventory: - [1, goal] diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index 2333a58a9..525650649 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -44,6 +44,8 @@ data Capability = -- | Execute the 'Move' command CMove | -- | Execute the 'Turn' command + -- + -- NOTE: using cardinal directions is separate 'COrient' capability CTurn | -- | Execute the 'Selfdestruct' command CSelfdestruct @@ -87,6 +89,8 @@ data Capability CCond | -- | Evaluate comparison operations CCompare + | -- | Use cardinal direction constants. + COrient | -- | Evaluate arithmetic operations CArith | -- | Store and look up definitions in an environment @@ -183,7 +187,7 @@ requiredCaps' ctx = go -- Some primitive literals that don't require any special -- capability. TUnit -> S.empty - TDir _ -> S.empty + TDir d -> if isCardinal d then S.singleton COrient else S.empty TInt _ -> S.empty TAntiInt _ -> S.empty TString _ -> S.empty diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index fb756ba4d..e208e43ae 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -25,6 +25,7 @@ module Swarm.Language.Syntax ( toDirection, fromDirection, allDirs, + isCardinal, dirInfo, north, south, @@ -84,7 +85,7 @@ import Data.Hashable (Hashable) import GHC.Generics (Generic) import Witch.From (from) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Swarm.Language.Types ------------------------------------------------------------ @@ -132,6 +133,10 @@ dirInfo d = case d of cardinal v2 = DirInfo directionSyntax (Just v2) (const v2) relative = DirInfo directionSyntax Nothing +-- | Check if the direction is absolute (e.g. 'north' or 'south'). +isCardinal :: Direction -> Bool +isCardinal = isJust . dirAbs . dirInfo + -- | The cardinal direction north = @V2 0 1@. north :: V2 Int64 north = V2 0 1 From dd03922186707b0763d1fce8082ceec69fd91968 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 17:29:15 +0200 Subject: [PATCH 09/30] Disallow cardinal diretion values without compass --- src/Swarm/Game/Step.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index b338ca16c..98b78ce08 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -374,10 +374,19 @@ stepCESK cesk = case cesk of -- Now some straightforward cases. These all immediately turn -- into values. In TUnit _ s k -> return $ Out VUnit s k - In (TDir d) _ s k -> return $ Out (VDir d) s k In (TInt n) _ s k -> return $ Out (VInt n) s k In (TString str) _ s k -> return $ Out (VString str) s k In (TBool b) _ s k -> return $ Out (VBool b) s k + -- Direction is simple too unless it is absolute (e.g. north) + -- and needs orient capability (provided by a compass). + -- This may be redundant just because of base escaping + -- capability checking (see #231). + In (TDir d) _ s k -> do + orient <- hasCapability COrient + if isCardinal d && not orient + then return $ Up (Incapable (S.singleton COrient) (TDir d)) s [] + else return $ Out (VDir d) s k + -- There should not be any antiquoted variables left at this point. In (TAntiString v) _ s k -> return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $str:" v)) s k From be8eb73610c6562804ee7829312274fa4b71e024 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 22:08:34 +0200 Subject: [PATCH 10/30] Refactor checking required devices - refactor out required device checking to common function - add a fun little linguistic function :) --- src/Swarm/Game/Step.hs | 128 ++++++++++++++++++++--------------------- src/Swarm/Util.hs | 28 ++++++++- 2 files changed, 88 insertions(+), 68 deletions(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 98b78ce08..f1aa830ca 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1157,7 +1157,6 @@ execConst c vs s k = do Reprogram -> case vs of [VRobot childRobotID, VDelay cmd e] -> do r <- get - em <- use entityMap creative <- use creativeMode -- check if robot exists @@ -1182,33 +1181,7 @@ execConst c vs s k = do (creative || (childRobot ^. robotLocation) `manhattan` loc <= 1) `holdsOrFail` ["You can only program adjacent robot"] - let -- Find out what capabilities are required by the program that will - -- be run on the other robot, and what devices would provide those - -- capabilities. - (caps, _capCtx) = requiredCaps (r ^. robotContext . defCaps) cmd - - -- list of possible devices per capability - capDevices = map (`deviceForCap` em) . S.toList $ caps - - -- device is ok if it is installed on the childRobot - deviceOK d = (childRobot ^. installedDevices) `E.contains` d - ignoreOK ([], miss) = ([], miss) - ignoreOK (ds, _miss) = (ds, []) - - (deviceSets, missingDeviceSets) = - Lens.over _2 (nubOrd . map S.fromList) . unzip $ - map (ignoreOK . L.partition deviceOK) capDevices - - formatDevices = T.intercalate " or " . map (^. entityName) . S.toList - - -- check if robot has all devices to execute new command - (creative || all null missingDeviceSets) - `holdsOrFail` ( "the target robot does not have required devices:" : - (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) - ) - - (creative || not (any null deviceSets)) - `holdsOrFail` ["the target robot cannot perform an impossible task"] + _ <- checkRequiredDevices (childRobot ^. robotInventory) cmd "The target robot" -- update other robot's CESK machine, environment and context -- the childRobot inherits the parent robot's environment @@ -1256,47 +1229,14 @@ execConst c vs s k = do stdDeviceList = ["treads", "grabber", "solar panel", "scanner", "plasma cutter"] stdDevices = S.fromList $ mapMaybe (`lookupEntityName` em) stdDeviceList + addStdDevs i = foldr insert i stdDevices - -- Note that _capCtx must be empty: at least at the - -- moment, definitions are only allowed at the top level, - -- so there can't be any inside the argument to build. - -- (Though perhaps there is an argument that this ought to - -- be relaxed specifically in the case of 'Build'.) - -- See #349 - - let -- Find out what capabilities are required by the program that will - -- be run on the other robot, and what devices would provide those - -- capabilities. - (caps, _capCtx) = requiredCaps (r ^. robotContext . defCaps) cmd - - -- list of possible devices per capability - capDevices = map (`deviceForCap` em) . S.toList $ caps - - -- A device is OK to install if it is a standard device, or we have one - -- in our inventory. - deviceOK d = d `S.member` stdDevices || (r ^. robotInventory) `E.contains` d - ignoreOK ([], miss) = ([], miss) - ignoreOK (ds, _miss) = (ds, []) - - (deviceSets, missingDeviceSets) = - Lens.over both (nubOrd . map S.fromList) . unzip $ - map (ignoreOK . L.partition deviceOK) capDevices - - -- if given a choice between required devices giving same capability - devices = - if creative + deviceSets <- checkRequiredDevices (addStdDevs $ r ^. robotInventory) cmd "You" + + let devices = + if creative -- if given a choice between required devices giving same capability then S.unions deviceSets -- give them all in creative else S.unions $ map (S.take 1) deviceSets -- give first one otherwise - formatDevices = T.intercalate " or " . map (^. entityName) . S.toList - - -- check if robot has all devices to execute new command - (creative || all null missingDeviceSets) - `holdsOrFail` ( "this would require installing devices you don't have:" : - (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) - ) - - (creative || not (any null deviceSets)) - `holdsOrFail` ["no robot could perform such impossible task"] -- Pick a random display name. displayName <- randomName @@ -1308,7 +1248,7 @@ execConst c vs s k = do (F.Const ()) (Just pid) displayName - ["A robot."] + ["A robot built by the robot named " <> r ^. robotName <> "."] (r ^. robotLocation) ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir) ? east @@ -1451,6 +1391,57 @@ execConst c vs s k = do return . (if remTime <= 1 then id else Waiting (remTime + time)) $ Out VUnit s (FImmediate wf rf : k) + -- Find out the required devices for running the command on the + -- target robot - this is common for 'Build' and 'Reprogram'. + -- + -- Note that _capCtx must be empty: at least at the + -- moment, definitions are only allowed at the top level, + -- so there can't be any inside the argument to build. + -- (Though perhaps there is an argument that this ought to be + -- relaxed specifically in the cases of 'Build' and 'Reprogram'.) + -- See #349 + checkRequiredDevices :: + (Has (State GameState) sig m, Has (State Robot) sig m, Has (Error Exn) sig m) => + Inventory -> + Term -> + Text -> + m [S.Set Entity] + checkRequiredDevices inventory cmd subject = do + currentContext <- use $ robotContext . defCaps + em <- use entityMap + creative <- use creativeMode + let -- Find out what capabilities are required by the program that will + -- be run on the target robot, and what devices would provide those + -- capabilities. + (caps, _capCtx) = requiredCaps currentContext cmd + + -- list of possible devices per capability + capDevices = map (`deviceForCap` em) . S.toList $ caps + + -- device is ok if it is available in the inventory of parent + -- when building or installed in target robot when reprogramming + deviceOK d = inventory `E.contains` d + ignoreOK ([], miss) = ([], miss) + ignoreOK (ds, _miss) = (ds, []) + + (deviceSets, missingDeviceSets) = + Lens.over both (nubOrd . map S.fromList) . unzip $ + map (ignoreOK . L.partition deviceOK) capDevices + + formatDevices = T.intercalate " or " . map (^. entityName) . S.toList + + -- check if robot has all devices to execute new command + (creative || all null missingDeviceSets) + `holdsOrFail` ( singularSubjectVerb subject "do" : + "not have required devices:" : + (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) + ) + -- check that there are in fact devices to provide every required capability + (creative || not (any null deviceSets)) + `holdsOrFail` [singularSubjectVerb subject "can", "not perform an impossible task"] + -- give back the devices required per capability + return deviceSets + -- replace some entity in the world with another entity changeWorld' :: Entity -> @@ -1478,7 +1469,10 @@ execConst c vs s k = do -- update some tile in the world setting it to entity or making it empty updateLoc w loc res = W.update (W.locToCoords loc) (const res) w + holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m () holdsOrFail a ts = a `holdsOr` cmdExn c ts + + isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a isJustOrFail a ts = a `isJustOr` cmdExn c ts returnEvalCmp = case vs of diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index 98dbe1f03..e3fe981b5 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -37,6 +37,7 @@ module Swarm.Util ( commaList, indefinite, indefiniteQ, + singularSubjectVerb, plural, number, @@ -69,7 +70,7 @@ import Data.Int (Int64) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) +import Data.Text (Text, toUpper) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Tuple (swap) @@ -175,6 +176,31 @@ indefinite w = MM.indefiniteDet w <+> w indefiniteQ :: Text -> Text indefiniteQ w = MM.indefiniteDet w <+> squote w +-- | Combine the subject word with the simple present tense of the verb. +-- +-- Only some irregular verbs are handled, but it should be enough +-- to scrap some error message boilerplate and have fun! +-- +-- >>> singularSubjectVerb "I" "be" +-- "I am" +-- >>> singularSubjectVerb "he" "can" +-- "he can" +-- >>> singularSubjectVerb "The target robot" "do" +-- "The target robot does" +singularSubjectVerb :: Text -> Text -> Text +singularSubjectVerb sub verb + | verb == "be" = case toUpper sub of + "I" -> "I am" + "YOU" -> sub <+> "are" + _ -> sub <+> "is" + | otherwise = sub <+> (if is3rdPerson then verb3rd else verb) + where + is3rdPerson = toUpper sub `notElem` ["I", "YOU"] + verb3rd + | verb == "have" = "has" + | verb == "can" = "can" + | otherwise = fst $ MM.defaultVerbStuff verb + -- | Pluralize a noun. plural :: Text -> Text plural = MM.defaultNounPlural From a8de1d552f337b790bb4eb9f53afdec55dc791f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 22:41:24 +0200 Subject: [PATCH 11/30] Make down a relative direction There are a few reasons for this: - we do not have direction map entry for it (uses default) - it makes it easier to check - like forward is (1*dir) and back (-dir) so down is (0*dir) Really it is the weirdest direction because once you turn down you can not look up again without compass. --- src/Swarm/Language/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index e208e43ae..96a07292a 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -120,12 +120,12 @@ dirInfo d = case d of DLeft -> relative (\(V2 x y) -> V2 (- y) x) DRight -> relative (\(V2 x y) -> V2 y (- x)) DBack -> relative (\(V2 x y) -> V2 (- x) (- y)) + DDown -> relative (const down) DForward -> relative id DNorth -> cardinal north DSouth -> cardinal south DEast -> cardinal east DWest -> cardinal west - DDown -> cardinal down where -- name is generate from Direction data constuctor -- e.g. DLeft becomes "left" @@ -153,7 +153,7 @@ east = V2 1 0 west :: V2 Int64 west = V2 (-1) 0 --- | The direction for moving vertically down = @V2 0 0@. +-- | The direction for viewing the current cell = @V2 0 0@. down :: V2 Int64 down = V2 0 0 From d0ba08aaac4478abaf115e9e8aa10b1914857e18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 23:17:07 +0200 Subject: [PATCH 12/30] Improve drilling direction error message --- src/Swarm/Game/Step.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index f1aa830ca..d30f62976 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -915,9 +915,16 @@ execConst c vs s k = do drill <- insDrill `isJustOr` Fatal "Drill is required but not installed?!" nextME <- entityAt nextLoc + + let directionText = case d of + DDown -> "under" + DForward -> "ahead of" + DBack -> "behind" + _ -> dirSyntax (dirInfo d) <> " of" + nextE <- nextME - `isJustOrFail` ["There is nothing to drill", "in the direction", "of robot", rname <> "."] + `isJustOrFail` ["There is nothing to drill", directionText, "robot", rname <> "."] inRs <- use recipesIn From e5a45716b15404a4c4d4d20a4825e04e299ba0d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Fri, 10 Jun 2022 23:46:43 +0200 Subject: [PATCH 13/30] Inline moves in benchmark --- bench/Benchmark.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index bae7632d3..9000b51e0 100644 --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -61,6 +61,12 @@ circlerProgram = in forever ( move; turn right; + move; + turn right; + move; + turn right; + move; + turn right; ) |] From 5b54dccdb726d933db23dee4c07f9d13d9cc9908 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sat, 11 Jun 2022 00:43:31 +0200 Subject: [PATCH 14/30] Check direction on use --- src/Swarm/Game/Step.hs | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index d30f62976..bcb0ed9d5 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -295,11 +295,11 @@ hasCapability cap = do -- | Ensure that either a robot has a given capability, OR we are in creative -- mode. -hasCapabilityOr :: - (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Exn -> m () -hasCapabilityOr cap exn = do +hasCapabilityFor :: + (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m () +hasCapabilityFor cap term = do h <- hasCapability cap - h `holdsOr` exn + h `holdsOr` Incapable (S.singleton cap) term -- | Create an exception about a command failing. cmdExn :: Const -> [Text] -> Exn @@ -447,7 +447,7 @@ stepCESK cesk = case cesk of Out v1 s (FLet x t2 e : k) -> return $ In t2 (addBinding x v1 e) s k -- Definitions immediately turn into VDef values, awaiting execution. In tm@(TDef r x _ t) e s k -> withExceptions s k $ do - CEnv `hasCapabilityOr` Incapable (S.singleton CEnv) tm + hasCapabilityFor CEnv tm return $ Out (VDef r x t e) s k -- Bind expressions don't evaluate: just package it up as a value @@ -740,6 +740,7 @@ execConst c vs s k = do return $ Out (VString (e ^. entityName)) s k Turn -> case vs of [VDir d] -> do + when (isCardinal d) $ hasCapabilityFor COrient (TDir d) robotOrientation . _Just %= applyTurn d flagRedraw return $ Out VUnit s k @@ -904,17 +905,12 @@ execConst c vs s k = do rname <- use robotName inv <- use robotInventory ins <- use installedDevices - loc <- use robotLocation - rDir <- use robotOrientation - - let nextLoc = loc ^+^ applyTurn d (rDir ? V2 0 0) let toyDrill = lookupByName "drill" ins metalDrill = lookupByName "metal drill" ins insDrill = listToMaybe $ metalDrill <> toyDrill drill <- insDrill `isJustOr` Fatal "Drill is required but not installed?!" - nextME <- entityAt nextLoc let directionText = case d of DDown -> "under" @@ -922,6 +918,7 @@ execConst c vs s k = do DBack -> "behind" _ -> dirSyntax (dirInfo d) <> " of" + (nextLoc, nextME) <- lookInDirection d nextE <- nextME `isJustOrFail` ["There is nothing to drill", directionText, "robot", rname <> "."] @@ -956,10 +953,7 @@ execConst c vs s k = do return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) s k Scan -> case vs of [VDir d] -> do - loc <- use robotLocation - orient <- use robotOrientation - let scanLoc = loc ^+^ applyTurn d (orient ? zero) - me <- entityAt scanLoc + (_loc, me) <- lookInDirection d res <- case me of Nothing -> return $ VInj False VUnit Just e -> do @@ -1397,6 +1391,16 @@ execConst c vs s k = do let remTime = r ^. recipeTime return . (if remTime <= 1 then id else Waiting (remTime + time)) $ Out VUnit s (FImmediate wf rf : k) + + lookInDirection :: + (Has (State GameState) sig m, Has (State Robot) sig m, Has (Error Exn) sig m) => + Direction -> m (V2 Int64, Maybe Entity) + lookInDirection d = do + loc <- use robotLocation + orient <- use robotOrientation + when (isCardinal d) $ hasCapabilityFor COrient (TDir d) + let nextLoc = loc ^+^ applyTurn d (orient ? zero) + (nextLoc,) <$> entityAt nextLoc -- Find out the required devices for running the command on the -- target robot - this is common for 'Build' and 'Reprogram'. From fe1f851bde9f33c5bb9025dde74015b6856ea4eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sat, 11 Jun 2022 00:43:56 +0200 Subject: [PATCH 15/30] Revert "Disallow cardinal diretion values without compass" This reverts commit dd03922186707b0763d1fce8082ceec69fd91968. --- src/Swarm/Game/Step.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index bcb0ed9d5..71c00f2e1 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -374,19 +374,10 @@ stepCESK cesk = case cesk of -- Now some straightforward cases. These all immediately turn -- into values. In TUnit _ s k -> return $ Out VUnit s k + In (TDir d) _ s k -> return $ Out (VDir d) s k In (TInt n) _ s k -> return $ Out (VInt n) s k In (TString str) _ s k -> return $ Out (VString str) s k In (TBool b) _ s k -> return $ Out (VBool b) s k - -- Direction is simple too unless it is absolute (e.g. north) - -- and needs orient capability (provided by a compass). - -- This may be redundant just because of base escaping - -- capability checking (see #231). - In (TDir d) _ s k -> do - orient <- hasCapability COrient - if isCardinal d && not orient - then return $ Up (Incapable (S.singleton COrient) (TDir d)) s [] - else return $ Out (VDir d) s k - -- There should not be any antiquoted variables left at this point. In (TAntiString v) _ s k -> return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $str:" v)) s k From f527b18d2f191dd573b8bfa28c08f2bd70a32ab4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sat, 11 Jun 2022 02:25:30 +0200 Subject: [PATCH 16/30] Parse Recipe With EntityMap --- src/Swarm/Game/Recipe.hs | 12 ++++++++++++ src/Swarm/Util/Yaml.hs | 4 ++++ 2 files changed, 16 insertions(+) diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs index 9e31afcf1..32057bf6d 100644 --- a/src/Swarm/Game/Recipe.hs +++ b/src/Swarm/Game/Recipe.hs @@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -56,6 +57,7 @@ import Control.Carrier.Throw.Either (runThrow) import Paths_swarm import Swarm.Game.Entity as E import Swarm.Util +import Swarm.Util.Yaml -- | An ingredient list is a list of entities with multiplicity. It -- is polymorphic in the entity type so that we can use either @@ -126,6 +128,16 @@ instance FromJSON (Recipe Text) where resolveRecipes :: EntityMap -> [Recipe Text] -> Validation [Text] [Recipe Entity] resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) +instance FromJSONE EntityMap (Recipe Entity) where + parseJSONE v = do + rt <- liftE $ parseJSON @(Recipe Text) v + em <- fromE + let erEnt :: Validation [Text] (Recipe Entity) + erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt + case validationToEither erEnt of + Right rEnt -> return rEnt + Left err -> fail . from @Text . T.unlines $ err + -- | Given an already loaded 'EntityMap', try to load a list of -- recipes from the data file @recipes.yaml@. loadRecipes :: (Has (Lift IO) sig m) => EntityMap -> m (Either Text [Recipe Entity]) diff --git a/src/Swarm/Util/Yaml.hs b/src/Swarm/Util/Yaml.hs index 290b79367..0e30084d2 100644 --- a/src/Swarm/Util/Yaml.hs +++ b/src/Swarm/Util/Yaml.hs @@ -19,6 +19,7 @@ module Swarm.Util.Yaml ( ParserE, liftE, withE, + fromE, FromJSONE (..), decodeFileEitherE, (..:), @@ -61,6 +62,9 @@ liftE = E . const withE :: Semigroup e => e -> With e f a -> With e f a withE e (E f) = E (f . (<> e)) +fromE :: (Monad f) => With e f e +fromE = E return + ------------------------------------------------------------ -- FromJSONE ------------------------------------------------------------ From 14114dda5111fd3c83a8595a6c0cd599e087dc29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sat, 11 Jun 2022 02:26:00 +0200 Subject: [PATCH 17/30] Add custom recipes to scenarios --- src/Swarm/Game/Scenario.hs | 7 +++++++ src/Swarm/Game/State.hs | 3 +++ 2 files changed, 10 insertions(+) diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index d4ef49d07..3f684fd0d 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -30,6 +30,7 @@ module Swarm.Game.Scenario ( scenarioCreative, scenarioSeed, scenarioEntities, + scenarioRecipes, scenarioWorld, scenarioRobots, scenarioWin, @@ -76,6 +77,7 @@ import Swarm.Game.World import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray) import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Util.Yaml +import Swarm.Game.Recipe -- | A 'Scenario' contains all the information to describe a -- scenario. @@ -85,6 +87,7 @@ data Scenario = Scenario , _scenarioCreative :: Bool -- Maybe generalize this to a mode enumeration , _scenarioSeed :: Maybe Int , _scenarioEntities :: EntityMap + , _scenarioRecipes :: [Recipe Entity] , _scenarioWorld :: Seed -> WorldFun Int Entity , _scenarioRobots :: [URobot] , _scenarioWin :: Maybe ProcessedTerm @@ -101,6 +104,7 @@ instance FromJSONE EntityMap Scenario where <*> liftE (v .:? "creative" .!= False) <*> liftE (v .:? "seed") <*> pure em + <*> withE em (v ..:? "recipes" ..!= []) <*> withE em (mkWorldFun (v .: "world")) <*> withE em (v ..: "robots") <*> liftE (v .:? "win") @@ -121,6 +125,9 @@ scenarioSeed :: Lens' Scenario (Maybe Int) -- | Any custom entities used for this scenario. scenarioEntities :: Lens' Scenario EntityMap +-- | Any custom recipes used in this scenario. +scenarioRecipes :: Lens' Scenario [Recipe Entity] + -- | The starting world for the scenario. scenarioWorld :: Lens' Scenario (Seed -> WorldFun Int Entity) diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 413575ebe..86228c5b0 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -489,6 +489,8 @@ playScenario em scenario userSeed toRun g = do , _waitingRobots = M.empty , _gensym = initGensym , _randGen = mkStdGen seed + , _recipesOut = addRecipesWith outRecipeMap recipesOut + , _recipesIn = addRecipesWith inRecipeMap recipesIn , _world = theWorld seed , _viewCenterRule = VCRobot baseID , _viewCenter = V2 0 0 @@ -522,6 +524,7 @@ playScenario em scenario userSeed toRun g = do theWorld = W.newWorld . (scenario ^. scenarioWorld) theWinCondition = maybe NoWinCondition WinCondition (scenario ^. scenarioWin) initGensym = length robotList - 1 + addRecipesWith f gRs = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) (g ^. gRs) maxMessageQueueSize :: Int maxMessageQueueSize = 1000 From 806fa328247f2e935617267bec4637688b4fd16a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sat, 11 Jun 2022 02:31:49 +0200 Subject: [PATCH 18/30] Use custom recipes in scenarios Bye trusty copper vein, I will see you in tutorials and challenges! --- data/entities.yaml | 20 --- data/recipes.yaml | 15 ++- .../scenarios/03Challenges/02-drill_test.yaml | 118 ++++++++++++++---- src/Swarm/Game/WorldGen.hs | 11 +- 4 files changed, 104 insertions(+), 60 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index 90319b9be..11ef18670 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -91,16 +91,6 @@ mountains, but those would require a drill to access and mine. properties: [portable] -- name: copper vein - display: - attr: copper' - char: 'A' - description: - - A place in the mountains where raw copper ore can be mined. - As it is hidden inside a mountain, a tunnel needs to be - first drilled through, so that the vein becomes accessible. - properties: [unwalkable] - - name: copper mine display: attr: copper' @@ -163,16 +153,6 @@ - It can only be mined by drilling in the mountains. properties: [portable] -- name: iron vein - display: - attr: iron' - char: 'A' - description: - - A place in the mountains where raw iron ore can be mined. - As it is hidden inside a mountain, a tunnel needs to be - first drilled through, so that the vein becomes accessible. - properties: [unwalkable] - - name: iron mine display: attr: iron' diff --git a/data/recipes.yaml b/data/recipes.yaml index 225a0bf64..9a3976529 100644 --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -91,6 +91,7 @@ required: - [1, drill] time: 90 + weight: 8 - in: - [1, mountain] @@ -100,7 +101,7 @@ required: - [1, metal drill] time: 9 - + weight: 8 - in: - [5, rock] @@ -114,40 +115,44 @@ ## VEINS - in: - - [1, copper vein] + - [1, mountain] out: - [1, copper mine] - [1, copper ore] required: - [1, drill] time: 42 + weight: 1 - in: - - [1, iron vein] + - [1, mountain] out: - [1, iron mine] - [1, iron ore] required: - [1, drill] time: 64 + weight: 1 - in: - - [1, copper vein] + - [1, mountain] out: - [1, copper mine] - [1, copper ore] required: - [1, metal drill] time: 6 + weight: 1 - in: - - [1, iron vein] + - [1, mountain] out: - [1, iron mine] - [1, iron ore] required: - [1, metal drill] time: 7 + weight: 1 ## MINES diff --git a/data/scenarios/03Challenges/02-drill_test.yaml b/data/scenarios/03Challenges/02-drill_test.yaml index 9ce9db7ac..1b80ee883 100644 --- a/data/scenarios/03Challenges/02-drill_test.yaml +++ b/data/scenarios/03Challenges/02-drill_test.yaml @@ -1,31 +1,5 @@ name: Test drill description: This is a developer playground and will be replaced with more suitable challenges soon. -entities: - - name: goal - display: - attr: device - char: 'X' - description: - - Send robots to mine rock, iron and copper. - properties: [portable] - - name: knownwater - display: - attr: water - char: ' ' - description: - - An infinite ocean of water. - properties: [known, portable, growable, liquid] - growth: [0,0] - yields: water - - name: knownwater' - display: - attr: water - char: '~' - description: - - An infinite ocean of water. - properties: [known, portable, growable, liquid] - growth: [0,0] - yields: water win: | try { i <- as base {has "iron ore"}; @@ -50,14 +24,15 @@ robots: - [2, metal drill] - [1, drill] - [3, logger] + - [3, compass] world: default: [ice, knownwater] palette: '.': [grass, null] ' ': [ice, knownwater] + '~': [ice, knownwavywater] 'L': [grass, Linux] 'T': [grass, tree] - '~': [ice, knownwater'] '┌': [stone, upper left corner] '┐': [stone, upper right corner] '└': [stone, lower left corner] @@ -74,3 +49,92 @@ world: │..AAA│ ~~ │....C│ ~ └─────┘ ~ +entities: + - name: goal + display: + attr: device + char: 'X' + description: + - Send robots to mine rock, iron and copper. + properties: [portable] + + ## KNOWN ENTITIES + - name: knownwater + display: + attr: water + char: ' ' + description: + - An infinite ocean of water. + properties: [known, portable, growable, liquid] + growth: [0,0] + yields: water + + - name: knownwavywater + display: + attr: water + char: '~' + description: + - An infinite ocean of water. + properties: [known, portable, growable, liquid] + growth: [0,0] + yields: water + + ## MOUNTAIN MINES (for guaranteed profit) + - name: copper vein + display: + attr: copper' + char: 'A' + description: + - A place in the mountains where raw copper ore can be mined. + As it is hidden inside a mountain, a tunnel needs to be + first drilled through, so that the vein becomes accessible. + properties: [unwalkable] + + - name: iron vein + display: + attr: iron' + char: 'A' + description: + - A place in the mountains where raw iron ore can be mined. + As it is hidden inside a mountain, a tunnel needs to be + first drilled through, so that the vein becomes accessible. + properties: [unwalkable] + +recipes: + ## TOY DRILL + - in: + - [1, copper vein] + out: + - [1, copper mine] + - [1, copper ore] + required: + - [1, drill] + time: 42 + + - in: + - [1, iron vein] + out: + - [1, iron mine] + - [1, iron ore] + required: + - [1, drill] + time: 64 + + ## METAL DRILL + - in: + - [1, copper vein] + out: + - [1, copper mine] + - [1, copper ore] + required: + - [1, metal drill] + time: 6 + + - in: + - [1, iron vein] + out: + - [1, iron mine] + - [1, iron ore] + required: + - [1, metal drill] + time: 7 \ No newline at end of file diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs index 540b6333d..3c08f24d7 100644 --- a/src/Swarm/Game/WorldGen.hs +++ b/src/Swarm/Game/WorldGen.hs @@ -21,7 +21,6 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Numeric.Noise.Perlin -import Numeric.Noise.Ridged import Witch import Data.Array.IArray @@ -57,8 +56,6 @@ testWorld2 baseSeed (Coords ix@(r, c)) = h = murmur3 0 (into (show ix)) genBiome Big Hard Natural - | sample ix cl0 > 0.5 && sample ix rg0 > 0.999 = (StoneT, Just "copper vein") - | sample ix cl0 > 0.5 && sample ix rg1 > 0.99 = (StoneT, Just "iron vein") | sample ix cl0 > 0.5 = (StoneT, Just "mountain") | h `mod` 30 == 0 = (StoneT, Just "boulder") | sample ix cl0 > 0 = (DirtT, Just "tree") @@ -96,11 +93,9 @@ testWorld2 baseSeed (Coords ix@(r, c)) = pn1 = pn 1 pn2 = pn 2 - rg :: Int -> Ridged - rg seed = ridged seed 6 0.05 1 2 - - rg0 = rg 42 - rg1 = rg 66 + -- alternative noise function + -- rg :: Int -> Ridged + -- rg seed = ridged seed 6 0.05 1 2 clumps :: Int -> Perlin clumps seed = perlin (seed + baseSeed) 4 0.08 0.5 From 9bf5b17709dfcc8d9b33e3aa4401caaf7b691faa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sat, 11 Jun 2022 02:50:33 +0200 Subject: [PATCH 19/30] Fix doctest setup --- src/Swarm/Util.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index e3fe981b5..d8b9c7a79 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -181,6 +181,7 @@ indefiniteQ w = MM.indefiniteDet w <+> squote w -- Only some irregular verbs are handled, but it should be enough -- to scrap some error message boilerplate and have fun! -- +-- >>> :set -XOverloadedStrings -- >>> singularSubjectVerb "I" "be" -- "I am" -- >>> singularSubjectVerb "he" "can" From 2f5f5f6dcc4fe57cf33b507487bb755450176b95 Mon Sep 17 00:00:00 2001 From: "Restyled.io" Date: Sat, 11 Jun 2022 00:33:01 +0000 Subject: [PATCH 20/30] Restyled by fourmolu --- src/Swarm/Game/Recipe.hs | 2 +- src/Swarm/Game/Scenario.hs | 2 +- src/Swarm/Game/Step.hs | 15 ++++++++------- src/Swarm/Util.hs | 16 ++++++++-------- 4 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs index 32057bf6d..d63159e87 100644 --- a/src/Swarm/Game/Recipe.hs +++ b/src/Swarm/Game/Recipe.hs @@ -131,7 +131,7 @@ resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lo instance FromJSONE EntityMap (Recipe Entity) where parseJSONE v = do rt <- liftE $ parseJSON @(Recipe Text) v - em <- fromE + em <- fromE let erEnt :: Validation [Text] (Recipe Entity) erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt case validationToEither erEnt of diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 3f684fd0d..4910af964 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -71,13 +71,13 @@ import Control.Carrier.Throw.Either (Throw, runThrow, throwError) import Paths_swarm (getDataDir, getDataFileName) import Swarm.Game.Entity +import Swarm.Game.Recipe import Swarm.Game.Robot (URobot) import Swarm.Game.Terrain import Swarm.Game.World import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray) import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Util.Yaml -import Swarm.Game.Recipe -- | A 'Scenario' contains all the information to describe a -- scenario. diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 71c00f2e1..c9f7b2adf 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1382,16 +1382,17 @@ execConst c vs s k = do let remTime = r ^. recipeTime return . (if remTime <= 1 then id else Waiting (remTime + time)) $ Out VUnit s (FImmediate wf rf : k) - + lookInDirection :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Error Exn) sig m) => - Direction -> m (V2 Int64, Maybe Entity) + Direction -> + m (V2 Int64, Maybe Entity) lookInDirection d = do - loc <- use robotLocation - orient <- use robotOrientation - when (isCardinal d) $ hasCapabilityFor COrient (TDir d) - let nextLoc = loc ^+^ applyTurn d (orient ? zero) - (nextLoc,) <$> entityAt nextLoc + loc <- use robotLocation + orient <- use robotOrientation + when (isCardinal d) $ hasCapabilityFor COrient (TDir d) + let nextLoc = loc ^+^ applyTurn d (orient ? zero) + (nextLoc,) <$> entityAt nextLoc -- Find out the required devices for running the command on the -- target robot - this is common for 'Build' and 'Reprogram'. diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index d8b9c7a79..7b352f99a 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -177,7 +177,7 @@ indefiniteQ :: Text -> Text indefiniteQ w = MM.indefiniteDet w <+> squote w -- | Combine the subject word with the simple present tense of the verb. --- +-- -- Only some irregular verbs are handled, but it should be enough -- to scrap some error message boilerplate and have fun! -- @@ -189,18 +189,18 @@ indefiniteQ w = MM.indefiniteDet w <+> squote w -- >>> singularSubjectVerb "The target robot" "do" -- "The target robot does" singularSubjectVerb :: Text -> Text -> Text -singularSubjectVerb sub verb +singularSubjectVerb sub verb | verb == "be" = case toUpper sub of "I" -> "I am" "YOU" -> sub <+> "are" _ -> sub <+> "is" | otherwise = sub <+> (if is3rdPerson then verb3rd else verb) - where - is3rdPerson = toUpper sub `notElem` ["I", "YOU"] - verb3rd - | verb == "have" = "has" - | verb == "can" = "can" - | otherwise = fst $ MM.defaultVerbStuff verb + where + is3rdPerson = toUpper sub `notElem` ["I", "YOU"] + verb3rd + | verb == "have" = "has" + | verb == "can" = "can" + | otherwise = fst $ MM.defaultVerbStuff verb -- | Pluralize a noun. plural :: Text -> Text From 79eddbc4972700e81b7d91e991123c6ab77ff02c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Sun, 12 Jun 2022 11:29:42 +0200 Subject: [PATCH 21/30] Fix wording (thanks @byorgey) Co-authored-by: Brent Yorgey --- data/entities.yaml | 3 +-- src/Swarm/Game/Entity.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index 11ef18670..cb1f03737 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -634,8 +634,7 @@ attr: device char: 'N' description: - - "A compass gives robot the ability to orient itself in cardinal directions." - - "That is north, south, west and east." + - "A compass gives a robot the ability to orient using cardinal directions: north, south, west, and east." - "Example:" - "turn west; move; turn north" properties: [portable] diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index 366764c5f..2363a09fc 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -303,7 +303,7 @@ instance Monoid EntityMap where lookupEntityName :: Text -> EntityMap -> Maybe Entity lookupEntityName nm = M.lookup nm . entitiesByName --- | Find an entity which is a device that provides the given +-- | Find all entities which are devices that provide the given -- capability. deviceForCap :: Capability -> EntityMap -> [Entity] deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap From 7a5e4cfd9c89ce5f0d927e11639912e35a8b2285 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sun, 12 Jun 2022 11:35:35 +0200 Subject: [PATCH 22/30] Explain ignoreOK --- src/Swarm/Game/Step.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index c9f7b2adf..663516216 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1424,6 +1424,10 @@ execConst c vs s k = do -- device is ok if it is available in the inventory of parent -- when building or installed in target robot when reprogramming deviceOK d = inventory `E.contains` d + + -- take a pair of device sets providing capabilities that is + -- split into (AVAIL,MISSING) and if there are some available + -- ignore missing because we only need them for error message ignoreOK ([], miss) = ([], miss) ignoreOK (ds, _miss) = (ds, []) From 6c01e62788e66dc890c10ee0deb96bdf39811501 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sun, 12 Jun 2022 12:38:20 +0200 Subject: [PATCH 23/30] Differentiate exception for CGod and others --- src/Swarm/Game/Step.hs | 19 ++++++++++++++++--- src/Swarm/Language/Capability.hs | 7 ++++++- 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 663516216..1406410cf 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1416,10 +1416,10 @@ execConst c vs s k = do let -- Find out what capabilities are required by the program that will -- be run on the target robot, and what devices would provide those -- capabilities. - (caps, _capCtx) = requiredCaps currentContext cmd + (caps, _capCtx) = Lens.over _1 S.toList $ requiredCaps currentContext cmd -- list of possible devices per capability - capDevices = map (`deviceForCap` em) . S.toList $ caps + capDevices = map (`deviceForCap` em) caps -- device is ok if it is available in the inventory of parent -- when building or installed in target robot when reprogramming @@ -1437,6 +1437,9 @@ execConst c vs s k = do formatDevices = T.intercalate " or " . map (^. entityName) . S.toList + -- check that the capability is not restricted to system robots + (creative || CGod `notElem` caps) + `holdsOrFail` [singularSubjectVerb subject "can", "not perform an impossible task"] -- check if robot has all devices to execute new command (creative || all null missingDeviceSets) `holdsOrFail` ( singularSubjectVerb subject "do" : @@ -1444,8 +1447,18 @@ execConst c vs s k = do (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) ) -- check that there are in fact devices to provide every required capability + let capsNone = map (capabilityName . fst) . filter (null . snd) $ zip caps deviceSets + capMsg = case capsNone of + [ca] -> indefiniteQ ca <> "capability" + cas -> "the capabilities " <> T.intercalate ", " (map squote cas) + (creative || not (any null deviceSets)) - `holdsOrFail` [singularSubjectVerb subject "can", "not perform an impossible task"] + `holdsOrFail` [ singularSubjectVerb subject "do" + , "not have" + , capMsg + , ", because no device can provide it." + , "\nSee https://github.com/swarm-game/swarm/issues/26." + ] -- give back the devices required per capability return deviceSets diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index 525650649..e3fbb0409 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Swarm.Language.Capability @@ -17,6 +18,7 @@ module Swarm.Language.Capability ( Capability (..), CapCtx, + capabilityName, requiredCaps, constCaps, ) where @@ -111,8 +113,11 @@ data Capability CGod deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data) +capabilityName :: Capability -> Text +capabilityName = from @String . map toLower . drop 1 . show + instance ToJSON Capability where - toJSON = String . from . map toLower . drop 1 . show + toJSON = String . capabilityName instance FromJSON Capability where parseJSON = withText "Capability" tryRead From c29558c7899c196f63bab7f122b11f9653d9d46c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sun, 12 Jun 2022 13:52:18 +0200 Subject: [PATCH 24/30] Use common code for incapable exception - fixes #342 --- src/Swarm/Game/CESK.hs | 2 +- src/Swarm/Game/Exception.hs | 81 +++++++++++++++++++++++++++++-------- src/Swarm/Game/Step.hs | 48 +++++++++------------- 3 files changed, 86 insertions(+), 45 deletions(-) diff --git a/src/Swarm/Game/CESK.hs b/src/Swarm/Game/CESK.hs index 0e31b0f4a..9b3578398 100644 --- a/src/Swarm/Game/CESK.hs +++ b/src/Swarm/Game/CESK.hs @@ -320,7 +320,7 @@ prettyCESK (Out v _ k) = ] prettyCESK (Up e _ k) = unlines - [ "! " ++ from (formatExn e) + [ "! " ++ from (formatExn mempty e) , " " ++ prettyCont k ] prettyCESK (Waiting t cek) = diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs index 86693eb75..977c5f874 100644 --- a/src/Swarm/Game/Exception.hs +++ b/src/Swarm/Game/Exception.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -10,6 +11,7 @@ -- Runtime exceptions for the Swarm language interpreter. module Swarm.Game.Exception ( Exn (..), + IncapableFix (..), formatExn, ) where @@ -17,11 +19,21 @@ import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as T +import Control.Lens ((^.)) +import qualified Data.Set as S +import Swarm.Game.Entity (EntityMap, deviceForCap, entityName) import Swarm.Language.Capability import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax import Swarm.Util +-- | Suggested way to fix incapable error. +data IncapableFix + = FixByInstall -- ^ install the missing device on yourself/target + | FixByObtain -- ^ add the missing device to your inventory + deriving (Eq, Show) + + -- | The type of exceptions that can be thrown by robot programs. data Exn = -- | Something went very wrong. This is a bug in Swarm and cannot @@ -34,7 +46,7 @@ data Exn | -- | A robot tried to do something for which it does not have some -- of the required capabilities. This cannot be caught by a -- @try@ block. - Incapable (Set Capability) Term + Incapable IncapableFix (Set Capability) Term | -- | A command failed in some "normal" way (/e.g./ a 'Move' -- command could not move, or a 'Grab' command found nothing to -- grab, /etc./). @@ -43,18 +55,55 @@ data Exn User Text deriving (Eq, Show) --- | Pretty-print an exception for displaying to the user. -formatExn :: Exn -> Text -formatExn (Fatal t) = - T.unlines - [ T.append "fatal error: " t - , "Please report this as a bug at https://github.com/swarm-game/swarm/issues/new ." - ] -formatExn InfiniteLoop = "Infinite loop detected!" -formatExn (Incapable _caps tm) = - T.concat - [ "missing device(s) needed to execute command " - , squote (prettyText tm) - ] -formatExn (CmdFailed c t) = T.concat [prettyText c, ": ", t] -formatExn (User t) = T.concat ["user exception: ", t] +-- | Pretty-print an exception for displaying to the player. +formatExn :: EntityMap -> Exn -> Text +formatExn em = \case + Fatal t -> + T.unlines + [ "Fatal error: " <> t + , "Please report this as a bug at" + , "." + ] + InfiniteLoop -> "Infinite loop detected!" + (CmdFailed c t) -> T.concat [prettyText c, ": ", t] + (User t) -> "Player exception: " <> t + (Incapable f caps tm) -> formatIncapable em f caps tm + +-- ------------------------------------------------------------------ +-- INCAPABLE HELPERS +-- ------------------------------------------------------------------ + +formatIncapableFix :: IncapableFix -> Text +formatIncapableFix = \case + FixByInstall -> "Install" + FixByObtain -> "Obtain" + +-- | Pretty print the incapable exception with actionable suggestion +-- on what to install to fix it. +formatIncapable :: EntityMap -> IncapableFix -> Set Capability -> Term -> Text +formatIncapable em f caps tm + | CGod `S.member` caps = "Can not perform an impossible task:\n" <> prettyText tm + | not (null capsNone) = + T.unlines + [ "Missing the " <> capMsg <> " required for:" + , prettyText tm + , "because no device can provide it." + , "See https://github.com/swarm-game/swarm/issues/26." + ] + | otherwise = + T.unlines + ( "You do not have the devices required for:" : + prettyText tm : + formatIncapableFix f <>":" : + ((" - " <>) . formatDevices <$> filter (not . null) deviceSets) + ) + where + capList = S.toList caps + deviceSets = map (`deviceForCap` em) capList + devicePerCap = zip capList deviceSets + -- capabilities not provided by any device + capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap + capMsg = case capsNone of + [ca] -> ca <> " capability" + cas -> "capabilities " <> T.intercalate ", " (map squote cas) + formatDevices = T.intercalate " or " . map (^. entityName) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 1406410cf..3096a5ad9 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -281,7 +281,7 @@ ensureCanExecute c = do robotCaps <- use robotCapabilities let missingCaps = constCaps c `S.difference` robotCaps (sys || creative || S.null missingCaps) - `holdsOr` Incapable missingCaps (TConst c) + `holdsOr` Incapable FixByInstall missingCaps (TConst c) -- | Test whether the current robot has a given capability (either -- because it has a device which gives it that capability, or it is a @@ -299,7 +299,7 @@ hasCapabilityFor :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m () hasCapabilityFor cap term = do h <- hasCapability cap - h `holdsOr` Incapable (S.singleton cap) term + h `holdsOr` Incapable FixByInstall (S.singleton cap) term -- | Create an exception about a command failing. cmdExn :: Const -> [Text] -> Exn @@ -566,8 +566,9 @@ stepCESK cesk = case cesk of Up exn s [] -> do let s' = resetBlackholes s h <- hasCapability CLog + em <- use entityMap case h of - True -> return $ In (TApp (TConst Log) (TString (formatExn exn))) empty s' [FExec] + True -> return $ In (TApp (TConst Log) (TString (formatExn em exn))) empty s' [FExec] False -> return $ Out VUnit s' [] -- Fatal errors, capability errors, and infinite loop errors can't -- be caught; just throw away the continuation stack. @@ -1173,7 +1174,7 @@ execConst c vs s k = do (creative || (childRobot ^. robotLocation) `manhattan` loc <= 1) `holdsOrFail` ["You can only program adjacent robot"] - _ <- checkRequiredDevices (childRobot ^. robotInventory) cmd "The target robot" + _ <- checkRequiredDevices (childRobot ^. robotInventory) cmd "The target robot" FixByInstall -- update other robot's CESK machine, environment and context -- the childRobot inherits the parent robot's environment @@ -1223,7 +1224,7 @@ execConst c vs s k = do stdDevices = S.fromList $ mapMaybe (`lookupEntityName` em) stdDeviceList addStdDevs i = foldr insert i stdDevices - deviceSets <- checkRequiredDevices (addStdDevs $ r ^. robotInventory) cmd "You" + deviceSets <- checkRequiredDevices (addStdDevs $ r ^. robotInventory) cmd "You" FixByObtain let devices = if creative -- if given a choice between required devices giving same capability @@ -1408,8 +1409,9 @@ execConst c vs s k = do Inventory -> Term -> Text -> + IncapableFix -> m [S.Set Entity] - checkRequiredDevices inventory cmd subject = do + checkRequiredDevices inventory cmd subject fixI = do currentContext <- use $ robotContext . defCaps em <- use entityMap creative <- use creativeMode @@ -1436,29 +1438,19 @@ execConst c vs s k = do map (ignoreOK . L.partition deviceOK) capDevices formatDevices = T.intercalate " or " . map (^. entityName) . S.toList + -- capabilities not provided by any device in inventory + missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets + + unless creative $ do + -- check if robot has all devices to execute new command + all null missingDeviceSets + `holdsOrFail` ( singularSubjectVerb subject "do" : + "not have required devices:" : + (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) + ) + -- check that there are in fact devices to provide every required capability + not (any null deviceSets) `holdsOr` Incapable fixI missingCaps cmd - -- check that the capability is not restricted to system robots - (creative || CGod `notElem` caps) - `holdsOrFail` [singularSubjectVerb subject "can", "not perform an impossible task"] - -- check if robot has all devices to execute new command - (creative || all null missingDeviceSets) - `holdsOrFail` ( singularSubjectVerb subject "do" : - "not have required devices:" : - (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) - ) - -- check that there are in fact devices to provide every required capability - let capsNone = map (capabilityName . fst) . filter (null . snd) $ zip caps deviceSets - capMsg = case capsNone of - [ca] -> indefiniteQ ca <> "capability" - cas -> "the capabilities " <> T.intercalate ", " (map squote cas) - - (creative || not (any null deviceSets)) - `holdsOrFail` [ singularSubjectVerb subject "do" - , "not have" - , capMsg - , ", because no device can provide it." - , "\nSee https://github.com/swarm-game/swarm/issues/26." - ] -- give back the devices required per capability return deviceSets From dcbd614f5c715e813d0d3c3b7d53bd8a0c0b8fc6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sun, 12 Jun 2022 15:37:11 +0200 Subject: [PATCH 25/30] Rename fromE --- src/Swarm/Game/Recipe.hs | 2 +- src/Swarm/Util/Yaml.hs | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs index d63159e87..16e90fa34 100644 --- a/src/Swarm/Game/Recipe.hs +++ b/src/Swarm/Game/Recipe.hs @@ -131,7 +131,7 @@ resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lo instance FromJSONE EntityMap (Recipe Entity) where parseJSONE v = do rt <- liftE $ parseJSON @(Recipe Text) v - em <- fromE + em <- getE let erEnt :: Validation [Text] (Recipe Entity) erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt case validationToEither erEnt of diff --git a/src/Swarm/Util/Yaml.hs b/src/Swarm/Util/Yaml.hs index 0e30084d2..fa9e8fe92 100644 --- a/src/Swarm/Util/Yaml.hs +++ b/src/Swarm/Util/Yaml.hs @@ -19,7 +19,7 @@ module Swarm.Util.Yaml ( ParserE, liftE, withE, - fromE, + getE, FromJSONE (..), decodeFileEitherE, (..:), @@ -59,11 +59,13 @@ type ParserE e = With e Parser liftE :: Functor f => f a -> With e f a liftE = E . const +-- | Locally merge an environment with the current one for given action. withE :: Semigroup e => e -> With e f a -> With e f a withE e (E f) = E (f . (<> e)) -fromE :: (Monad f) => With e f e -fromE = E return +-- | Get the current environment. +getE :: (Monad f) => With e f e +getE = E return ------------------------------------------------------------ -- FromJSONE From e91632291ddbb4c8d5ee5729c73051f3aede7eeb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sun, 12 Jun 2022 15:38:10 +0200 Subject: [PATCH 26/30] Improve and test incapable exception --- src/Swarm/Game/Entity.hs | 6 ++- src/Swarm/Game/Exception.hs | 89 ++++++++++++++++++++++++++++--------- src/Swarm/Game/Robot.hs | 2 +- src/Swarm/TUI/View.hs | 2 +- test/Unit.hs | 12 +++-- 5 files changed, 83 insertions(+), 28 deletions(-) diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index 2363a09fc..d3def4487 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -276,9 +276,11 @@ mkEntity :: [Text] -> -- | Properties [EntityProperty] -> + -- | Capabilities + [Capability] -> Entity -mkEntity disp nm descr props = - rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing props [] empty +mkEntity disp nm descr props caps = + rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing props caps empty ------------------------------------------------------------ -- Entity map diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs index 977c5f874..3a3c99b9f 100644 --- a/src/Swarm/Game/Exception.hs +++ b/src/Swarm/Game/Exception.hs @@ -13,6 +13,9 @@ module Swarm.Game.Exception ( Exn (..), IncapableFix (..), formatExn, + + -- * Helper functions + formatIncapable, ) where import Data.Set (Set) @@ -22,18 +25,35 @@ import qualified Data.Text as T import Control.Lens ((^.)) import qualified Data.Set as S import Swarm.Game.Entity (EntityMap, deviceForCap, entityName) -import Swarm.Language.Capability +import Swarm.Language.Capability (Capability (CGod), capabilityName) import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Syntax +import Swarm.Language.Syntax (Const, Term) import Swarm.Util +-- ------------------------------------------------------------------ +-- SETUP FOR DOCTEST + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens +-- >>> import qualified Data.Set as S +-- >>> import Data.Text (unpack) +-- >>> import Swarm.Language.Syntax +-- >>> import Swarm.Language.Capability +-- >>> import Swarm.Game.Entity +-- >>> import Swarm.Game.Display + +-- ------------------------------------------------------------------ + + -- | Suggested way to fix incapable error. data IncapableFix - = FixByInstall -- ^ install the missing device on yourself/target - | FixByObtain -- ^ add the missing device to your inventory + = -- | install the missing device on yourself/target + FixByInstall + | -- | add the missing device to your inventory + FixByObtain deriving (Eq, Show) - -- | The type of exceptions that can be thrown by robot programs. data Exn = -- | Something went very wrong. This is a bug in Swarm and cannot @@ -75,27 +95,52 @@ formatExn em = \case formatIncapableFix :: IncapableFix -> Text formatIncapableFix = \case - FixByInstall -> "Install" - FixByObtain -> "Obtain" + FixByInstall -> "install" + FixByObtain -> "obtain" --- | Pretty print the incapable exception with actionable suggestion --- on what to install to fix it. +-- | Pretty print the incapable exception with an actionable suggestion +-- on how to fix it. +-- +-- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" [] [] [CAppear] +-- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" [] [] [CAppear] +-- >>> m = buildEntityMap [w,r] +-- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByInstall cs t +-- +-- >>> incapableError (S.singleton CGod) (TConst As) +-- Can not perform an impossible task: +-- 'as' +-- +-- >>> incapableError (S.singleton CAppear) (TConst Appear) +-- You do not have the devices required for: +-- 'appear' +-- please install: +-- - the one ring or magic wand +-- +-- >>> incapableError (S.singleton CCreate) (TConst Create) +-- Missing the create capability for: +-- 'create' +-- but no device yet provides it. See +-- https://github.com/swarm-game/swarm/issues/26 formatIncapable :: EntityMap -> IncapableFix -> Set Capability -> Term -> Text formatIncapable em f caps tm - | CGod `S.member` caps = "Can not perform an impossible task:\n" <> prettyText tm + | CGod `S.member` caps = + unlinesExText + [ "Can not perform an impossible task:" + , squote $ prettyText tm + ] | not (null capsNone) = - T.unlines - [ "Missing the " <> capMsg <> " required for:" - , prettyText tm - , "because no device can provide it." - , "See https://github.com/swarm-game/swarm/issues/26." + unlinesExText + [ "Missing the " <> capMsg <> " for:" + , squote $ prettyText tm + , "but no device yet provides it. See" + , "https://github.com/swarm-game/swarm/issues/26" ] | otherwise = - T.unlines + unlinesExText ( "You do not have the devices required for:" : - prettyText tm : - formatIncapableFix f <>":" : - ((" - " <>) . formatDevices <$> filter (not . null) deviceSets) + squote (prettyText tm) : + "please " <> formatIncapableFix f <> ":" : + ((" - " <>) . formatDevices <$> filter (not . null) deviceSets) ) where capList = S.toList caps @@ -105,5 +150,9 @@ formatIncapable em f caps tm capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap capMsg = case capsNone of [ca] -> ca <> " capability" - cas -> "capabilities " <> T.intercalate ", " (map squote cas) + cas -> "capabilities " <> T.intercalate ", " cas formatDevices = T.intercalate " or " . map (^. entityName) + +-- | Exceptions that span multiple lines should be indented. +unlinesExText :: [Text] -> Text +unlinesExText ts = T.unlines . (head ts :) . map (" " <>) $ tail ts diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index 992bea99b..6f347a5c2 100644 --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -362,7 +362,7 @@ mkRobot :: mkRobot rid pid name descr loc dir disp m devs inv sys = RobotR { _robotEntity = - mkEntity disp name descr [] + mkEntity disp name descr [] [] & entityOrientation ?~ dir & entityInventory .~ fromElems inv , _installedDevices = inst diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index de9dd7e08..2bc578a1f 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -654,7 +654,7 @@ drawRecipe e inv (Recipe ins outs reqs time _weight) = -- | Ad-hoc entity to represent time - only used in recipe drawing timeE :: Entity -timeE = mkEntity (defaultEntityDisplay '.') "ticks" [] [] +timeE = mkEntity (defaultEntityDisplay '.') "ticks" [] [] [] drawReqs :: IngredientList Entity -> Widget Name drawReqs = vBox . map (hCenter . drawReq) diff --git a/test/Unit.hs b/test/Unit.hs index 98663b076..cf3989026 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -32,6 +32,7 @@ import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (mkOp) import Swarm.TUI.Model +import Swarm.Game.Entity (EntityMap) main :: IO () main = do @@ -487,8 +488,11 @@ eval g = where r = mkRobot (-1) Nothing "" [] zero zero defaultRobotDisplay cesk [] [] False + entMap :: EntityMap + entMap = g ^. entityMap + runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value, Int)) - runCESK _ (Up exn _ []) = return (Left (formatExn exn)) + runCESK _ (Up exn _ []) = return (Left (formatExn entMap exn)) runCESK !steps cesk = case finalValue cesk of Just (v, _) -> return (Right (v, steps)) Nothing -> stepCESK cesk >>= runCESK (steps + 1) @@ -626,6 +630,6 @@ inventory = ) ] where - x = E.mkEntity (defaultEntityDisplay 'X') "fooX" [] [] - y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" [] [] - _z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" [] [] + x = E.mkEntity (defaultEntityDisplay 'X') "fooX" [] [] [] + y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" [] [] [] + _z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" [] [] [] From 9e2429394850d9f51a9b857abd46924798512663 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Sun, 12 Jun 2022 16:11:43 +0200 Subject: [PATCH 27/30] Fix creative robots not getting devices --- src/Swarm/Game/Exception.hs | 1 + src/Swarm/Game/Step.hs | 26 ++++++++++++++------------ 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs index 3a3c99b9f..4c88566e9 100644 --- a/src/Swarm/Game/Exception.hs +++ b/src/Swarm/Game/Exception.hs @@ -16,6 +16,7 @@ module Swarm.Game.Exception ( -- * Helper functions formatIncapable, + formatIncapableFix, ) where import Data.Set (Set) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 3096a5ad9..d73ea6999 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1441,18 +1441,20 @@ execConst c vs s k = do -- capabilities not provided by any device in inventory missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets - unless creative $ do - -- check if robot has all devices to execute new command - all null missingDeviceSets - `holdsOrFail` ( singularSubjectVerb subject "do" : - "not have required devices:" : - (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) - ) - -- check that there are in fact devices to provide every required capability - not (any null deviceSets) `holdsOr` Incapable fixI missingCaps cmd - - -- give back the devices required per capability - return deviceSets + if creative + then return $ S.fromList <$> capDevices + else do + -- check if robot has all devices to execute new command + all null missingDeviceSets + `holdsOrFail` ( singularSubjectVerb subject "do" : + "not have required devices, please": + formatIncapableFix fixI <> ":" : + (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) + ) + -- check that there are in fact devices to provide every required capability + not (any null deviceSets) `holdsOr` Incapable fixI missingCaps cmd + -- give back the devices required per capability + return deviceSets -- replace some entity in the world with another entity changeWorld' :: From a8c83be5dc38cdf5690dd004e393157d00d00868 Mon Sep 17 00:00:00 2001 From: "Restyled.io" Date: Sun, 12 Jun 2022 14:14:00 +0000 Subject: [PATCH 28/30] Restyled by fourmolu --- src/Swarm/Game/Exception.hs | 33 ++++++++++++++++----------------- src/Swarm/Game/Step.hs | 2 +- test/Unit.hs | 2 +- 3 files changed, 18 insertions(+), 19 deletions(-) diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs index 4c88566e9..b692b0359 100644 --- a/src/Swarm/Game/Exception.hs +++ b/src/Swarm/Game/Exception.hs @@ -46,7 +46,6 @@ import Swarm.Util -- ------------------------------------------------------------------ - -- | Suggested way to fix incapable error. data IncapableFix = -- | install the missing device on yourself/target @@ -125,24 +124,24 @@ formatIncapableFix = \case formatIncapable :: EntityMap -> IncapableFix -> Set Capability -> Term -> Text formatIncapable em f caps tm | CGod `S.member` caps = - unlinesExText - [ "Can not perform an impossible task:" - , squote $ prettyText tm - ] + unlinesExText + [ "Can not perform an impossible task:" + , squote $ prettyText tm + ] | not (null capsNone) = - unlinesExText - [ "Missing the " <> capMsg <> " for:" - , squote $ prettyText tm - , "but no device yet provides it. See" - , "https://github.com/swarm-game/swarm/issues/26" - ] + unlinesExText + [ "Missing the " <> capMsg <> " for:" + , squote $ prettyText tm + , "but no device yet provides it. See" + , "https://github.com/swarm-game/swarm/issues/26" + ] | otherwise = - unlinesExText - ( "You do not have the devices required for:" : - squote (prettyText tm) : - "please " <> formatIncapableFix f <> ":" : - ((" - " <>) . formatDevices <$> filter (not . null) deviceSets) - ) + unlinesExText + ( "You do not have the devices required for:" : + squote (prettyText tm) : + "please " <> formatIncapableFix f <> ":" : + ((" - " <>) . formatDevices <$> filter (not . null) deviceSets) + ) where capList = S.toList caps deviceSets = map (`deviceForCap` em) capList diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index d73ea6999..287a3c786 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1447,7 +1447,7 @@ execConst c vs s k = do -- check if robot has all devices to execute new command all null missingDeviceSets `holdsOrFail` ( singularSubjectVerb subject "do" : - "not have required devices, please": + "not have required devices, please" : formatIncapableFix fixI <> ":" : (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets) ) diff --git a/test/Unit.hs b/test/Unit.hs index cf3989026..4449a279c 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -21,6 +21,7 @@ import Witch (from) import Swarm.Game.CESK import Swarm.Game.Display +import Swarm.Game.Entity (EntityMap) import Swarm.Game.Entity qualified as E import Swarm.Game.Exception import Swarm.Game.Robot @@ -32,7 +33,6 @@ import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (mkOp) import Swarm.TUI.Model -import Swarm.Game.Entity (EntityMap) main :: IO () main = do From 6365428d694168479751516592c2f80050169679 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Tue, 14 Jun 2022 17:21:03 +0200 Subject: [PATCH 29/30] Add standard devices --- src/Swarm/Game/Step.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 287a3c786..4191c30c7 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1227,9 +1227,10 @@ execConst c vs s k = do deviceSets <- checkRequiredDevices (addStdDevs $ r ^. robotInventory) cmd "You" FixByObtain let devices = - if creative -- if given a choice between required devices giving same capability - then S.unions deviceSets -- give them all in creative - else S.unions $ map (S.take 1) deviceSets -- give first one otherwise + stdDevices + `S.union` if creative -- if given a choice between required devices giving same capability + then S.unions deviceSets -- give them all in creative + else S.unions $ map (S.take 1) deviceSets -- give first one otherwise -- Pick a random display name. displayName <- randomName From 8ab3ef7115c4e6c4df7868220871862d18a12de8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= Date: Tue, 14 Jun 2022 17:40:45 +0200 Subject: [PATCH 30/30] Explain blasphemy better --- src/Swarm/Game/Exception.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs index b692b0359..1f823e8a5 100644 --- a/src/Swarm/Game/Exception.hs +++ b/src/Swarm/Game/Exception.hs @@ -107,8 +107,9 @@ formatIncapableFix = \case -- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByInstall cs t -- -- >>> incapableError (S.singleton CGod) (TConst As) --- Can not perform an impossible task: +-- Thee shalt not utter such blasphemy: -- 'as' +-- If't be true thee wanteth to playeth god, then tryeth Creative game. -- -- >>> incapableError (S.singleton CAppear) (TConst Appear) -- You do not have the devices required for: @@ -125,8 +126,9 @@ formatIncapable :: EntityMap -> IncapableFix -> Set Capability -> Term -> Text formatIncapable em f caps tm | CGod `S.member` caps = unlinesExText - [ "Can not perform an impossible task:" + [ "Thee shalt not utter such blasphemy:" , squote $ prettyText tm + , "If't be true thee wanteth to playeth god, then tryeth Creative game." ] | not (null capsNone) = unlinesExText