Implement push command

data/scenarios/Testing/00-ORDER.txt

@@ -31,4 +31,5 @@
 1171-chirp-command.yaml
 1171-resonate-command.yaml
 1207-scout-command.yaml
-1218-stride-command.yaml
+1218-stride-command.yaml
+1234-push-command.yaml

data/scenarios/Testing/1218-stride-command.yaml

@@ -15,6 +15,7 @@ objectives:
     teaser: Grab flower
     goal:
       - Grab a flower
+    optional: true
     condition: |
       as base {has "flower"}
 solution: |

data/scenarios/Testing/1234-push-command.yaml

@@ -0,0 +1,78 @@
+version: 1
+name: Push test
+creative: false
+description: Push items as in Sokoban
+objectives:
+  - goal:
+      - Push a crate onto the stone pad
+    condition: |
+      j <- robotnamed "judge";
+      as j {ishere "crate"}
+solution: |
+  push;
+  turn left;
+  move;
+  turn right;
+  move;
+  move;
+  turn right;
+  push;
+robots:
+  - name: base
+    dir: [1, 0]
+    display:
+      char: Ω
+      attr: robot
+    devices:
+      - branch predictor
+      - calculator
+      - compass
+      - dictionary
+      - grabber
+      - logger
+      - net
+      - scanner
+      - treads
+      - dozer blade
+  - name: judge
+    dir: [0, 1]
+    system: true
+    display:
+      char: j
+      attr: robot
+      invisible: true
+entities:
+- name: dozer blade
+  display:
+    attr: silver
+    char: '/'
+  description:
+  - Facilitates pushing
+  properties: [known, portable]
+  capabilities: [push]
+- name: crate
+  display:
+    attr: wood
+    char: '▪'
+  description:
+  - Pushable crate
+  properties: [known, portable, unwalkable]
+  capabilities: [push]
+known: [tree, flower, boulder, water]
+world:
+  default: [blank]
+  palette:
+    'Ω': [grass, null, base]
+    'j': [stone, null, judge]
+    '.': [grass]
+    '@': [grass, boulder]
+    'w': [grass, water]
+    '*': [grass, flower]
+    'x': [grass, crate]
+  upperleft: [0, 0]
+  map: |
+   ..............
+   ......w.......
+   .....@Ωx.x....
+   ......*..j....
+   ......*.......

data/scenarios/Testing/394-build-drill.yaml

@@ -13,15 +13,15 @@ objectives:
 solution: |
   def forever = \c. c ; forever c end;
   def unblock = try {drill forward; return ()} {} end;
-  def push = unblock; move end;
+  def doPush = unblock; move end;
   log "Hi, I am base";
   r <- build {
     wait 2;
     log "Hi, I am builder";
     forever (
       build {
         log "Hi, I am pusher";
-        forever push
+        forever doPush
       };
       log "- robot built"
     )

editors/emacs/swarm-mode.el

@@ -54,6 +54,7 @@
                "wait"
                "selfdestruct"
                "move"
+               "push"
                "stride"
                "turn"
                "grab"

editors/vscode/syntaxes/swarm.tmLanguage.json

@@ -58,7 +58,7 @@
 				},
 				{
 				"name": "keyword.other",
-				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|stride|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|scout|whereami|detect|resonate|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
+				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|push|stride|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|scout|whereami|detect|resonate|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
 				}
 			]
 			},

src/Swarm/Game/Step.hs

@@ -1066,6 +1066,36 @@ execConst c vs s k = do
           }
       updateRobotLocation loc nextLoc
       return $ Out VUnit s k
+    Push -> do
+      -- Figure out where we're going
+      loc <- use robotLocation
+      orient <- use robotOrientation
+      let heading = orient ? zero
+          nextLoc = loc .+^ heading
+          placementLoc = nextLoc .+^ heading
+
+      -- If unobstructed, the robot will move even if
+      -- there is nothing to push.
+      maybeCurrentE <- entityAt nextLoc
+      case maybeCurrentE of
+        Just e -> do
+          -- Make sure there's nothing already occupying the destination
+          nothingHere <- isNothing <$> entityAt placementLoc
+          nothingHere `holdsOrFail` ["Blocked by an entity."]
+
+          let verbed = verbedGrabbingCmd Push'
+          -- Ensure it can be pushed.
+          omni <- isPrivilegedBot
+          (omni || e `hasProperty` Portable && not (e `hasProperty` Liquid))
+            `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."]
+
+          -- Place the entity and remove it from previous loc
+          updateEntityAt nextLoc (const Nothing)
+          updateEntityAt placementLoc (const (Just e))
+        Nothing -> return ()
+
+      updateRobotLocation loc nextLoc
+      return $ Out VUnit s k
     Stride -> case vs of
       [VInt d] -> do
         when (d > fromIntegral maxStrideRange) $
@@ -2386,7 +2416,7 @@ execConst c vs s k = do
         >>= (`isJustOrFail` ["There is nothing here to", verb <> "."])
 
     -- Ensure it can be picked up.
-    omni <- (||) <$> use systemRobot <*> use creativeMode
+    omni <- isPrivilegedBot
     (omni || e `hasProperty` Portable)
       `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."]
 
@@ -2489,19 +2519,21 @@ data MoveFailure = MoveFailure
   , failIfDrown :: RobotFailure
   }
 
-data GrabbingCmd = Grab' | Harvest' | Swap' deriving (Eq, Show)
+data GrabbingCmd = Grab' | Harvest' | Swap' | Push' deriving (Eq, Show)
 
 verbGrabbingCmd :: GrabbingCmd -> Text
 verbGrabbingCmd = \case
   Harvest' -> "harvest"
   Grab' -> "grab"
   Swap' -> "swap"
+  Push' -> "push"
 
 verbedGrabbingCmd :: GrabbingCmd -> Text
 verbedGrabbingCmd = \case
   Harvest' -> "harvested"
   Grab' -> "grabbed"
   Swap' -> "swapped"
+  Push' -> "pushed"
 
 -- | Format a set of suggested devices for use in an error message,
 --   in the format @device1 or device2 or ... or deviceN@.

src/Swarm/Language/Capability.hs

@@ -34,6 +34,8 @@ data Capability
     CPower
   | -- | Execute the 'Move' command
     CMove
+  | -- | Execute the 'Push' command
+    CPush
   | -- | Execute the 'Stride' command
     CMovemultiple
   | -- | Execute the 'Move' command for a heavy robot
@@ -195,6 +197,7 @@ constCaps = \case
   Log -> Just CLog
   Selfdestruct -> Just CSelfdestruct
   Move -> Just CMove
+  Push -> Just CPush
   Stride -> Just CMovemultiple
   Turn -> Just CTurn
   Grab -> Just CGrab

src/Swarm/Language/Syntax.hs

@@ -206,6 +206,8 @@ data Const
 
     -- | Move forward one step.
     Move
+  | -- | Push an entity forward one step.
+    Push
   | -- | Move forward multiple steps.
     Stride
   | -- | Turn in some direction.
@@ -565,6 +567,11 @@ constInfo c = case c of
       , "This destroys the robot's inventory, so consider `salvage` as an alternative."
       ]
   Move -> command 0 short "Move forward one step."
+  Push ->
+    command 1 short . doc "Push an entity forward one step." $
+      [ "Both entity and robot moves forward one step."
+      , "Destination must not contain an entity."
+      ]
   Stride ->
     command 1 short . doc "Move forward multiple steps." $
       [ T.unwords ["Has a max range of", T.pack $ show maxStrideRange, "units."]

src/Swarm/Language/Typecheck.hs

@@ -543,6 +543,7 @@ inferConst c = case c of
   Noop -> [tyQ| cmd unit |]
   Selfdestruct -> [tyQ| cmd unit |]
   Move -> [tyQ| cmd unit |]
+  Push -> [tyQ| cmd unit |]
   Stride -> [tyQ| int -> cmd unit |]
   Turn -> [tyQ| dir -> cmd unit |]
   Grab -> [tyQ| cmd text |]

test/integration/Main.hs

@@ -271,6 +271,8 @@ testScenarioSolution _ci _em =
         , testSolution Default "Testing/1171-chirp-command"
         , testSolution Default "Testing/1171-resonate-command"
         , testSolution Default "Testing/1207-scout-command"
+        , testSolution Default "Testing/1218-stride-command"
+        , testSolution Default "Testing/1234-push-command"
         ]
     ]
  where