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/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....
+   ......*.......

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
+      let nextLoc = loc .+^ heading
+      let 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 <- (||) <$> use systemRobot <*> use creativeMode
+          (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) $
@@ -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