diff --git a/src/swarm-engine/Swarm/Game/State/Robot.hs b/src/swarm-engine/Swarm/Game/State/Robot.hs index 24d332819..da65c481d 100644 --- a/src/swarm-engine/Swarm/Game/State/Robot.hs +++ b/src/swarm-engine/Swarm/Game/State/Robot.hs @@ -23,6 +23,7 @@ module Swarm.Game.State.Robot ( robotMap, robotsByLocation, robotsWatching, + wakeLog, activeRobots, waitingRobots, viewCenterRule, @@ -72,6 +73,7 @@ import Swarm.Game.Location import Swarm.Game.ResourceLoading (NameGenerator) import Swarm.Game.Robot import Swarm.Game.State.Config +import Swarm.Game.Step.WakeLog import Swarm.Game.Universe as U import Swarm.Util (binTuples, surfaceEmpty, (<+=), (<<.=)) import Swarm.Util.Lens (makeLensesExcluding) @@ -122,6 +124,7 @@ data Robots = Robots -- that we do not have to iterate over all "waiting" robots, -- since there may be many. _robotsWatching :: Map (Cosmic Location) (S.Set RID) + , _wakeLog :: [WakeLogEvent] , _robotNaming :: RobotNaming , _viewCenterRule :: ViewCenterRule , _viewCenter :: Cosmic Location @@ -164,6 +167,7 @@ robotsByLocation :: Lens' Robots (Map SubworldName (Map Location IntSet)) -- | Get a list of all the robots that are \"watching\" by location. robotsWatching :: Lens' Robots (Map (Cosmic Location) (S.Set RID)) +wakeLog :: Lens' Robots [WakeLogEvent] -- | State and data for assigning identifiers to robots robotNaming :: Lens' Robots RobotNaming @@ -195,6 +199,7 @@ initRobots gsc = , _waitingRobots = M.empty , _robotsByLocation = M.empty , _robotsWatching = mempty + , _wakeLog = mempty , _robotNaming = RobotNaming { _nameGenerator = initNameParts gsc @@ -301,6 +306,9 @@ wakeUpRobotsDoneSleeping time = do let aliveRids = filter (`IM.member` robots) rids internalActiveRobots %= IS.union (IS.fromList aliveRids) + forM_ aliveRids $ \rid -> + wakeLog %= (WakeLogEvent rid time DoneSleeping :) + -- These robots' wake times may have been moved "forward" -- by 'wakeWatchingRobots'. clearWatchingRobots rids @@ -311,7 +319,7 @@ clearWatchingRobots :: (Has (State Robots) sig m) => [RID] -> m () -clearWatchingRobots rids = do +clearWatchingRobots rids = robotsWatching %= M.map (`S.difference` S.fromList rids) -- | Iterates through all of the currently @wait@-ing robots, @@ -358,6 +366,9 @@ wakeWatchingRobots currentTick loc = do newWakeTime = addTicks 1 currentTick newInsertions = M.singleton newWakeTime wakeableBotIds + forM_ wakeableBotIds $ \rid -> + wakeLog %= (WakeLogEvent rid newWakeTime ScheduledWakeup :) + -- NOTE: There are two "sources of truth" for the waiting state of robots: -- 1. In the GameState via "internalWaitingRobots" -- 2. In each robot, via the CESK machine state diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 21244c6be..06ee5140e 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -76,6 +76,7 @@ import Swarm.Game.Step.RobotStepState import Swarm.Game.Step.Util import Swarm.Game.Step.Util.Command import Swarm.Game.Step.Util.Inspect +import Swarm.Game.Step.WakeLog import Swarm.Game.Universe import Swarm.Game.Value import Swarm.Game.World (locToCoords) @@ -136,6 +137,10 @@ execConst runChildProg c vs s k = do [VInt d] -> do time <- use $ temporal . ticks purgeFarAwayWatches + + rid <- use robotID + robotInfo . wakeLog %= (WakeLogEvent rid time CalledWaitCommand :) + return $ Waiting (addTicks (fromIntegral d) time) (mkReturn ()) _ -> badConst Selfdestruct -> do @@ -283,6 +288,10 @@ execConst runChildProg c vs s k = do _ -> badConst Swap -> case vs of [VText name] -> do + time <- use $ temporal . ticks + rid <- use robotID + robotInfo . wakeLog %= (WakeLogEvent rid time CalledSwapCommand :) + loc <- use robotLocation -- Make sure the robot has the thing in its inventory e <- hasInInventoryOrFail name diff --git a/src/swarm-engine/Swarm/Game/Step/WakeLog.hs b/src/swarm-engine/Swarm/Game/Step/WakeLog.hs new file mode 100644 index 000000000..cd743ad87 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/WakeLog.hs @@ -0,0 +1,32 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Step.WakeLog where + +import Data.Aeson (ToJSON (..)) +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.CESK (TickNumber) +import Swarm.Game.Robot (RID) + +data WakeLogEvent = WakeLogEvent + { targetRobotID :: RID + , thisEventTime :: TickNumber + , thisEventType :: WakeLogEventType + } + deriving (Show, Eq, Generic, ToJSON) + +data WakeLogEventType + = ScheduledWakeup + | CalledWaitCommand + | CalledSwapCommand + | DoneSleeping + deriving (Show, Eq, Generic, ToJSON) + +-- instance ToJSON WakeLogEventType where +-- toJSON = genericToJSON $ defaultOptions +-- { sumEncoding = ObjectWithSingleField +-- } + +instance ToSample WakeLogEvent where + toSamples _ = SD.noSamples diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 74bfde88e..893c0ab3a 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -75,6 +75,7 @@ import Swarm.Game.State import Swarm.Game.State.Robot import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Type +import Swarm.Game.Step.WakeLog import Swarm.Language.Module import Swarm.Language.Pipeline import Swarm.Language.Pretty (prettyTextLine) @@ -99,6 +100,7 @@ newtype RobotID = RobotID Int type SwarmAPI = "robots" :> Get '[JSON] [Robot] :<|> "robot" :> Capture "id" RobotID :> Get '[JSON] (Maybe Robot) + :<|> "sleep" :> Get '[JSON] [WakeLogEvent] :<|> "goals" :> "prereqs" :> Get '[JSON] [PrereqSatisfaction] :<|> "goals" :> "active" :> Get '[JSON] [Objective] :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) @@ -154,6 +156,7 @@ mkApp :: mkApp state events = robotsHandler state :<|> robotHandler state + :<|> sleepHandler state :<|> prereqsHandler state :<|> activeGoalsHandler state :<|> goalsGraphHandler state @@ -177,6 +180,11 @@ robotHandler appStateRef (RobotID rid) = do appState <- liftIO (readIORef appStateRef) pure $ IM.lookup rid (appState ^. gameState . robotInfo . robotMap) +sleepHandler :: ReadableIORef AppState -> Handler [WakeLogEvent] +sleepHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + pure $ appState ^. gameState . robotInfo . wakeLog + prereqsHandler :: ReadableIORef AppState -> Handler [PrereqSatisfaction] prereqsHandler appStateRef = do appState <- liftIO (readIORef appStateRef) diff --git a/swarm.cabal b/swarm.cabal index 2ab4a3119..b8444b66c 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -226,6 +226,7 @@ library swarm-engine Swarm.Game.Step.Util Swarm.Game.Step.Util.Command Swarm.Game.Step.Util.Inspect + Swarm.Game.Step.WakeLog Swarm.Game.Terrain Swarm.Game.Value Swarm.Game.World @@ -492,6 +493,7 @@ library , Swarm.Game.Step.Util , Swarm.Game.Step.Util.Command , Swarm.Game.Step.Util.Inspect + , Swarm.Game.Step.WakeLog , Swarm.Game.Terrain , Swarm.Game.Value , Swarm.Game.World