diff --git a/src/swarm-engine/Swarm/Game/Robot.hs b/src/swarm-engine/Swarm/Game/Robot.hs index e1f4dba85..df4f3707b 100644 --- a/src/swarm-engine/Swarm/Game/Robot.hs +++ b/src/swarm-engine/Swarm/Game/Robot.hs @@ -100,16 +100,13 @@ import Swarm.Game.CESK qualified as C import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Location (Heading, Location, toDirection, toHeading) +import Swarm.Game.Robot.Context import Swarm.Game.Universe import Swarm.Language.Capability (Capability) -import Swarm.Language.Context qualified as Ctx import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Requirement (ReqCtx) import Swarm.Language.Syntax (Const, Syntax) import Swarm.Language.Text.Markdown (Document) -import Swarm.Language.Typed (Typed (..)) -import Swarm.Language.Types (TCtx) import Swarm.Language.Value as V import Swarm.Log import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs) @@ -117,53 +114,6 @@ import Swarm.Util.WindowedCounter import Swarm.Util.Yaml import System.Clock (TimeSpec) --- | A record that stores the information --- for all definitions stored in a 'Robot' -data RobotContext = RobotContext - { _defTypes :: TCtx - -- ^ Map definition names to their types. - , _defReqs :: ReqCtx - -- ^ Map definition names to the capabilities - -- required to evaluate/execute them. - , _defVals :: Env - -- ^ Map definition names to their values. Note that since - -- definitions are delayed, the values will just consist of - -- 'VRef's pointing into the store. - , _defStore :: C.Store - -- ^ A store containing memory cells allocated to hold - -- definitions. - } - deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON) - -makeLenses ''RobotContext - -emptyRobotContext :: RobotContext -emptyRobotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty C.emptyStore - -type instance Index RobotContext = Ctx.Var -type instance IxValue RobotContext = Typed Value - -instance Ixed RobotContext -instance At RobotContext where - at name = lens getter setter - where - getter ctx = - do - typ <- Ctx.lookup name (ctx ^. defTypes) - val <- Ctx.lookup name (ctx ^. defVals) - req <- Ctx.lookup name (ctx ^. defReqs) - return $ Typed val typ req - setter ctx Nothing = - ctx - & defTypes %~ Ctx.delete name - & defVals %~ Ctx.delete name - & defReqs %~ Ctx.delete name - setter ctx (Just (Typed val typ req)) = - ctx - & defTypes %~ Ctx.addBinding name typ - & defVals %~ Ctx.addBinding name val - & defReqs %~ Ctx.addBinding name req - -- | A unique identifier for a robot. type RID = Int @@ -270,6 +220,10 @@ type family RobotMachine (phase :: RobotPhase) :: Data.Kind.Type type instance RobotMachine 'TemplateRobot = Maybe ProcessedTerm type instance RobotMachine 'ConcreteRobot = C.CESK +type family RobotContextMember (phase :: RobotPhase) :: Data.Kind.Type +type instance RobotContextMember 'TemplateRobot = () +type instance RobotContextMember 'ConcreteRobot = RobotContext + -- | A value of type 'RobotR' is a record representing the state of a -- single robot. The @f@ parameter is for tracking whether or not -- the robot has been assigned a unique ID. @@ -282,7 +236,7 @@ data RobotR (phase :: RobotPhase) = RobotR , _robotLog :: Seq LogEntry , _robotLogUpdated :: Bool , _robotLocation :: RobotLocation phase - , _robotContext :: RobotContext + , _robotContext :: RobotContextMember phase , _robotID :: RobotID phase , _robotParentID :: Maybe RID , _robotHeavy :: Bool @@ -296,8 +250,8 @@ data RobotR (phase :: RobotPhase) = RobotR } deriving (Generic) -deriving instance (Show (RobotLocation phase), Show (RobotID phase), Show (RobotMachine phase)) => Show (RobotR phase) -deriving instance (Eq (RobotLocation phase), Eq (RobotID phase), Eq (RobotMachine phase)) => Eq (RobotR phase) +deriving instance (Show (RobotLocation phase), Show (RobotID phase), Show (RobotMachine phase), Show (RobotContextMember phase)) => Show (RobotR phase) +deriving instance (Eq (RobotLocation phase), Eq (RobotID phase), Eq (RobotMachine phase), Eq (RobotContextMember phase)) => Eq (RobotR phase) -- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ -- for the approach used here with lenses. @@ -318,6 +272,7 @@ instance ToSample Robot where sampleBase = mkRobot 0 + emptyRobotContext Nothing "base" "The starting robot." @@ -430,6 +385,7 @@ instantiateRobot maybeMachine i r = { _robotID = i , _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r , _machine = fromMaybe (mkMachine $ _machine r) maybeMachine + , _robotContext = emptyRobotContext } -- | The ID number of the robot's parent, that is, the robot that @@ -535,6 +491,8 @@ mkMachine (Just pt) = C.initMachine pt mempty C.emptyStore mkRobot :: -- | ID number of the robot. RobotID phase -> + -- | Initial context. + RobotContextMember phase -> -- | ID number of the robot's parent, if it has one. Maybe Int -> -- | Name of the robot. @@ -562,7 +520,7 @@ mkRobot :: -- | Creation date TimeSpec -> RobotR phase -mkRobot rid pid name descr loc dir disp m devs inv sys heavy unwalkables ts = +mkRobot rid ctx pid name descr loc dir disp m devs inv sys heavy unwalkables ts = RobotR { _robotEntity = mkEntity disp name descr [] [] @@ -573,7 +531,7 @@ mkRobot rid pid name descr loc dir disp m devs inv sys heavy unwalkables ts = , _robotLog = Seq.empty , _robotLogUpdated = False , _robotLocation = loc - , _robotContext = emptyRobotContext + , _robotContext = ctx , _robotID = rid , _robotParentID = pid , _robotHeavy = heavy @@ -605,7 +563,7 @@ instance FromJSONE EntityMap TRobot where sys <- liftE $ v .:? "system" .!= False let defDisplay = defaultRobotDisplay & invisible .~ sys - mkRobot () Nothing + mkRobot () () Nothing <$> liftE (v .: "name") <*> liftE (v .:? "description" .!= mempty) <*> liftE (v .:? "loc") diff --git a/src/swarm-engine/Swarm/Game/Robot/Context.hs b/src/swarm-engine/Swarm/Game/Robot/Context.hs new file mode 100644 index 000000000..96aebe40b --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Robot/Context.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A data type to represent robot context. +module Swarm.Game.Robot.Context where + +import Control.Lens hiding (Const, contains) +import Data.Aeson qualified as Ae (FromJSON, ToJSON (..)) +import GHC.Generics (Generic) +import Swarm.Game.CESK qualified as C +import Swarm.Language.Context qualified as Ctx +import Swarm.Language.Requirement (ReqCtx) +import Swarm.Language.Typed (Typed (..)) +import Swarm.Language.Types (TCtx) +import Swarm.Language.Value as V + +-- | A record that stores the information +-- for all definitions stored in a 'Robot' +data RobotContext = RobotContext + { _defTypes :: TCtx + -- ^ Map definition names to their types. + , _defReqs :: ReqCtx + -- ^ Map definition names to the capabilities + -- required to evaluate/execute them. + , _defVals :: Env + -- ^ Map definition names to their values. Note that since + -- definitions are delayed, the values will just consist of + -- 'VRef's pointing into the store. + , _defStore :: C.Store + -- ^ A store containing memory cells allocated to hold + -- definitions. + } + deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON) + +makeLenses ''RobotContext + +emptyRobotContext :: RobotContext +emptyRobotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty C.emptyStore + +type instance Index RobotContext = Ctx.Var +type instance IxValue RobotContext = Typed Value + +instance Ixed RobotContext +instance At RobotContext where + at name = lens getter setter + where + getter ctx = + do + typ <- Ctx.lookup name (ctx ^. defTypes) + val <- Ctx.lookup name (ctx ^. defVals) + req <- Ctx.lookup name (ctx ^. defReqs) + return $ Typed val typ req + setter ctx Nothing = + ctx + & defTypes %~ Ctx.delete name + & defVals %~ Ctx.delete name + & defReqs %~ Ctx.delete name + setter ctx (Just (Typed val typ req)) = + ctx + & defTypes %~ Ctx.addBinding name typ + & defVals %~ Ctx.addBinding name val + & defReqs %~ Ctx.addBinding name req diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index b5c6b86ca..a773e001b 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -358,16 +358,17 @@ evalPT t = evaluateCESK (initMachine t empty emptyStore) -- -- Use ID (-1) so it won't conflict with any robots currently in the robot map. hypotheticalRobot :: CESK -> TimeSpec -> Robot -hypotheticalRobot c = +hypotheticalRobot m = mkRobot (-1) + emptyRobotContext Nothing "hypothesis" mempty defaultCosmicLocation zero defaultRobotDisplay - c + m [] [] True diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs index 25d791279..d89bd46a4 100644 --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -98,6 +98,7 @@ addCombustionBot inputEntity combustibility ts loc = do zoomRobots . addTRobot (initMachine combustionProg empty emptyStore) $ mkRobot + () () Nothing "fire" @@ -212,6 +213,7 @@ addIgnitionBot :: addIgnitionBot ignitionDelay inputEntity ts loc = addTRobot (initMachine (ignitionProgram ignitionDelay) empty emptyStore) $ mkRobot + () () Nothing "firestarter" diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 679657a8c..21244c6be 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -1063,6 +1063,7 @@ execConst runChildProg c vs s k = do newRobot <- zoomRobots . addTRobotWithContext parentCtx (In cmd e s [FExec]) $ mkRobot + () () (Just pid) displayName diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index 928d3f696..2de673ca1 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -375,6 +375,7 @@ addSeedBot e (minT, maxT) loc ts = zoomRobots . addTRobot (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore) $ mkRobot + () () Nothing "seed" diff --git a/swarm.cabal b/swarm.cabal index 3e8a7d406..2ab4a3119 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -175,6 +175,7 @@ library swarm-engine Swarm.Game.Recipe Swarm.Game.ResourceLoading Swarm.Game.Robot + Swarm.Game.Robot.Context Swarm.Game.Scenario Swarm.Game.Universe Swarm.Game.Scenario.Objective @@ -440,6 +441,7 @@ library , Swarm.Game.Recipe , Swarm.Game.ResourceLoading , Swarm.Game.Robot + , Swarm.Game.Robot.Context , Swarm.Game.Scenario , Swarm.Game.Universe , Swarm.Game.Scenario.Objective diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs index 48a8add50..042c603d4 100644 --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -113,7 +113,23 @@ waveProgram manualInline = -- | Initializes a robot with program prog at location loc facing north. initRobot :: ProcessedTerm -> Location -> TRobot -initRobot prog loc = mkRobot () Nothing "" mempty (Just $ Cosmic DefaultRootSubworld loc) north defaultRobotDisplay (Just prog) [] [] False False mempty 0 +initRobot prog loc = + mkRobot + () + () + Nothing + "" + mempty + (Just $ Cosmic DefaultRootSubworld loc) + north + defaultRobotDisplay + (Just prog) + [] + [] + False + False + mempty + 0 -- | Creates a GameState with numRobot copies of robot on a blank map, aligned -- in a row starting at (0,0) and spreading east.