Use custom types for immediate update

src/Swarm/Game/CESK.hs

@@ -91,20 +91,22 @@ module Swarm.Game.CESK (
 
 import Control.Lens.Combinators (pattern Empty)
 import Data.Aeson (FromJSON, ToJSON)
-import Data.Aeson qualified
+import Data.Int (Int64)
 import Data.IntMap.Strict (IntMap)
 import Data.IntMap.Strict qualified as IM
 import Data.List (intercalate)
+import Data.Text qualified as T
 import GHC.Generics (Generic)
-import Swarm.Game.Entity (Entity, Inventory)
+import Linear (V2)
+import Swarm.Game.Entity (Count, Entity)
 import Swarm.Game.Exception
 import Swarm.Game.Value as V
-import Swarm.Game.World (World)
 import Swarm.Language.Context
 import Swarm.Language.Pipeline
 import Swarm.Language.Pretty
 import Swarm.Language.Requirement (ReqCtx)
 import Swarm.Language.Syntax
+import Swarm.Language.Syntax qualified as Syntax
 import Swarm.Language.Types
 import Witch (from)
 
@@ -164,7 +166,7 @@ data Frame
     --   if there is one, to the output of the first command).
     FBind (Maybe Var) Term Env
   | -- | Apply specific updates to the world and current robot.
-    FImmediate WorldUpdate RobotUpdate
+    FImmediate Const [WorldUpdate] [RobotUpdate]
   | -- | Update the memory cell at a certain location with the computed value.
     FUpdate Loc
   | -- | Signal that we are done with an atomic computation.
@@ -350,39 +352,22 @@ prettyFrame (FDef x) = "def " ++ from x ++ " = _"
 prettyFrame FExec = "exec _"
 prettyFrame (FBind Nothing t _) = "_ ; " ++ prettyString t
 prettyFrame (FBind (Just x) t _) = from x ++ " <- _ ; " ++ prettyString t
-prettyFrame FImmediate {} = "(_ : cmd a)"
+prettyFrame (FImmediate c w r) = unwords ["immediate@" <> T.unpack (Syntax.syntax $ Syntax.constInfo c), show w, show r]
 prettyFrame (FUpdate loc) = "store@" ++ show loc ++ "(_)"
 prettyFrame FFinishAtomic = "finishAtomic"
 
 --------------------------------------------------------------
 -- Wrappers for functions in FImmediate
---
--- NOTE: we can not use GameState and Robot directly, as it
--- would create a cyclic dependency. The alternative is
--- making CESK, Cont and Frame polymorphic which just muddies
--- the picture too much for one little game feature.
---
--- BEWARE: the types do not follow normal laws for Show and Eq
 --------------------------------------------------------------
 
-newtype WorldUpdate = WorldUpdate
-  { worldUpdate :: World Int Entity -> Either Exn (World Int Entity)
-  }
-
-newtype RobotUpdate = RobotUpdate
-  { robotUpdateInventory :: Inventory -> Inventory
+data WorldUpdate = ReplaceEntity
+  { updatedLoc :: V2 Int64
+  , originalEntity :: Entity
+  , newEntity :: Maybe Entity
   }
+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
 
-instance Show WorldUpdate where show _ = "WorldUpdate {???}"
-
-instance Show RobotUpdate where show _ = "RobotUpdate {???}"
-
-instance Eq WorldUpdate where _ == _ = True
-
-instance Eq RobotUpdate where _ == _ = True
-
--- TODO: remove these instances once Update fields are concret
-instance FromJSON WorldUpdate where parseJSON _ = pure $ WorldUpdate $ \w -> Right w
-instance ToJSON WorldUpdate where toJSON _ = Data.Aeson.Null
-instance FromJSON RobotUpdate where parseJSON _ = pure $ RobotUpdate id
-instance ToJSON RobotUpdate where toJSON _ = Data.Aeson.Null
+data RobotUpdate
+  = AddEntity Count Entity
+  | LearnEntity Entity
+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)

src/Swarm/Game/Recipe.hs

@@ -222,11 +222,10 @@ make ::
   -- a function to add results and the recipe repeated
   Either
     [MissingIngredient]
-    (Inventory, Inventory -> Inventory, Recipe Entity)
+    (Inventory, IngredientList Entity, Recipe Entity)
 make invs r = finish <$> make' invs r
  where
-  finish (invTaken, out) = (invTaken, addOuts out, r)
-  addOuts out inv' = foldl' (flip $ uncurry insertCount) inv' out
+  finish (invTaken, out) = (invTaken, out, r)
 
 -- | Try to make a recipe, but do not insert it yet.
 make' :: (Inventory, Inventory) -> Recipe Entity -> Either [MissingIngredient] (Inventory, IngredientList Entity)

src/Swarm/Game/Step.hs

@@ -380,6 +380,21 @@ stepRobot r = do
   (r', cesk') <- runState (r & tickSteps -~ 1) (stepCESK (r ^. machine))
   return $ r' & machine .~ cesk'
 
+-- replace some entity in the world with another entity
+updateWorld ::
+  (Has (State GameState) sig m, Has (Throw Exn) sig m) =>
+  Const ->
+  WorldUpdate ->
+  m ()
+updateWorld c (ReplaceEntity loc eThen down) = do
+  w <- use world
+  let eNow = W.lookupEntity (W.locToCoords loc) w
+  if Just eThen /= eNow
+    then throwError $ cmdExn c ["The", eThen ^. entityName, "is not there."]
+    else do
+      world %= W.update (W.locToCoords loc) (const down)
+      pure ()
+
 -- | The main CESK machine workhorse.  Given a robot, look at its CESK
 --   machine state and figure out a single next step.
 stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK
@@ -396,13 +411,14 @@ stepCESK cesk = case cesk of
     if wakeupTime <= time
       then stepCESK cesk'
       else return cesk
-  Out v s (FImmediate wf rf : k) -> do
-    wc <- worldUpdate wf <$> use world
+  Out v s (FImmediate cmd wf rf : k) -> do
+    wc <- runError $ mapM_ (updateWorld cmd) wf
     case wc of
       Left exn -> return $ Up exn s k
-      Right wo -> do
-        robotInventory %= robotUpdateInventory rf
-        world .= wo
+      Right () -> do
+        forM_ rf $ \case
+          AddEntity c e -> robotInventory %= E.insertCount c e
+          LearnEntity e -> robotInventory %= E.insertCount 0 e
         needsRedraw .= True
         stepCESK (Out v s k)
 
@@ -914,7 +930,7 @@ execConst c vs s k = do
         -- take recipe inputs from inventory and add outputs after recipeTime
         robotInventory .= invTaken
         traverse_ (updateDiscoveredEntities . snd) (recipe ^. recipeOutputs)
-        finishCookingRecipe recipe (WorldUpdate Right) (RobotUpdate changeInv)
+        finishCookingRecipe recipe [] (map (uncurry AddEntity) changeInv)
       _ -> badConst
     Has -> case vs of
       [VText name] -> do
@@ -976,14 +992,23 @@ execConst c vs s k = do
             `isJustOrFail` ["You don't have the ingredients to drill", indefinite (nextE ^. entityName) <> "."]
 
         let (out, down) = L.partition ((`hasProperty` Portable) . snd) outs
-            changeInv =
-              flip (L.foldl' (flip $ uncurry insertCount)) out
-                . flip (L.foldl' (flip $ insertCount 0)) (map snd down)
-            changeWorld = changeWorld' nextE nextLoc down
+        let learn = map (LearnEntity . snd) down
+        let gain = map (uncurry AddEntity) out
+
+        newEntity <- case down of
+          [] -> pure Nothing
+          [(1, de)] -> pure $ Just de
+          _ -> throwError $ Fatal "Bad recipe:\n more than one unmovable entity produced."
+        let changeWorld =
+              ReplaceEntity
+                { updatedLoc = nextLoc
+                , originalEntity = nextE
+                , newEntity = newEntity
+                }
 
         -- take recipe inputs from inventory and add outputs after recipeTime
         robotInventory .= invTaken
-        finishCookingRecipe recipe (WorldUpdate changeWorld) (RobotUpdate changeInv)
+        finishCookingRecipe recipe [changeWorld] (learn <> gain)
       _ -> badConst
     Blocked -> do
       loc <- use robotLocation
@@ -1498,12 +1523,12 @@ execConst c vs s k = do
       , from (prettyCESK (Out (VCApp c (reverse vs)) s k))
       ]
 
-  finishCookingRecipe :: HasRobotStepState sig m => Recipe e -> WorldUpdate -> RobotUpdate -> m CESK
+  finishCookingRecipe :: HasRobotStepState sig m => Recipe e -> [WorldUpdate] -> [RobotUpdate] -> m CESK
   finishCookingRecipe r wf rf = do
     time <- use ticks
     let remTime = r ^. recipeTime
     return . (if remTime <= 1 then id else Waiting (remTime + time)) $
-      Out VUnit s (FImmediate wf rf : k)
+      Out VUnit s (FImmediate c wf rf : k)
 
   lookInDirection :: HasRobotStepState sig m => Direction -> m (V2 Int64, Maybe Entity)
   lookInDirection d = do
@@ -1650,23 +1675,6 @@ execConst c vs s k = do
 
         return (minimalInstallSet, missingChildInv)
 
-  -- replace some entity in the world with another entity
-  changeWorld' ::
-    Entity ->
-    V2 Int64 ->
-    IngredientList Entity ->
-    W.World Int Entity ->
-    Either Exn (W.World Int Entity)
-  changeWorld' eThen loc down w =
-    let eNow = W.lookupEntity (W.locToCoords loc) w
-     in if Just eThen /= eNow
-          then Left $ cmdExn c ["The", eThen ^. entityName, "is not there."]
-          else
-            w `updateLoc` loc <$> case down of
-              [] -> Right Nothing
-              [de] -> Right $ Just $ snd de
-              _ -> Left $ Fatal "Bad recipe:\n more than one unmovable entity produced."
-
   destroyIfNotBase :: HasRobotStepState sig m => m ()
   destroyIfNotBase = do
     rid <- use robotID
@@ -1713,9 +1721,6 @@ execConst c vs s k = do
           `holdsOrFail` ["The robot with ID", from (show rid), "is not close enough."]
         return other
 
-  -- 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