Add world metrics (#2573)

* add `Metric` fused effect and re-export it from `Swarm.Effect` in utility library (moving Time effect)
* add `Swarm.Game.World.Metrics` module with `WorldMetrics` stored in `Landscape` state
  * game.tile_loaded
  * game.tile_in_memory
  * game.tile_average_load_time
  * game.tiles_batch_load_time
* add `loadRegionM` (and `loadCellM`) function that caches tile and updates metrics
* make World state use [`strict`](https://hackage.haskell.org/package/strict-0.5) pair and maybe types
  * this makes the measurements meaningful but otherwise isn't a big change as the tile would be forced soon enough

This comes with the major caveat that only the time loading tiles by the world view in TUI is measured.
You can see the disparity in the graph:
```bash
cabal run swarm -- --seed 0 --scenario Creative --run <(echo 'build {require "boat"; turn south; let m = move; m in m}')
```
<img width="400"  alt="Screenshot 2025-08-31 at 12 41 43 AM" src="https://github.com/user-attachments/assets/1a13a941-9c1d-4885-bc2e-ac06f0bc4b27" />

Adding effects to other world functions changes the type of few very common functions in Swarm Engine (e.g. structure recognizer) which were only using the `GameState`. I will do that in a follow up PR.

Author: xsebek

src/swarm-engine/Swarm/Game/State.hs

@@ -570,11 +570,11 @@ zoomRobots n = do
 zoomWorld ::
   (Has (State GameState) sig m) =>
   SubworldName ->
-  Fused.StateC (W.World Int Entity) Identity b ->
+  Fused.StateC (W.World Int Entity) m b ->
   m (Maybe b)
 zoomWorld swName n = do
   mw <- use $ landscape . multiWorld
   forM (M.lookup swName mw) $ \w -> do
-    let (w', a) = run (Fused.runState w n)
+    (w', a) <- Fused.runState w n
     landscape . multiWorld %= M.insert swName w'
     return a

src/swarm-engine/Swarm/Game/State/Initialize.hs

@@ -45,11 +45,11 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.State
-import Swarm.Game.State.Landscape (mkLandscape)
+import Swarm.Game.State.Landscape (mkLandscape, worldMetrics)
 import Swarm.Game.State.Runtime
 import Swarm.Game.State.Substate
 import Swarm.Game.Step.Util (adaptGameState)
-import Swarm.Game.World (Seed)
+import Swarm.Game.World (Seed, WorldMetrics, initWorldMetrics)
 import Swarm.Language.Capability (constCaps)
 import Swarm.Language.Syntax (allConst, erase)
 import Swarm.Language.Types
@@ -62,23 +62,26 @@ scenarioToGameState ::
   ScenarioWith (Maybe ScenarioPath) ->
   ValidatedLaunchParams ->
   Maybe GameMetrics ->
+  Maybe WorldMetrics ->
   RuntimeState ->
   IO GameState
-scenarioToGameState si@(ScenarioWith scenario _) (LaunchParams (Identity userSeed) (Identity toRun)) prevMetric rs = do
+scenarioToGameState si@(ScenarioWith scenario _) (LaunchParams (Identity userSeed) (Identity toRun)) prevGMetric prevWMetric rs = do
   theSeed <- arbitrateSeed userSeed $ scenario ^. scenarioLandscape
   now <- Clock.getTime Clock.Monotonic
-  gMetric <- maybe (initGameMetrics $ rs ^. metrics) pure prevMetric
-  return $ pureScenarioToGameState si theSeed now toRun (Just gMetric) (rs ^. stdGameConfigInputs)
+  gMetric <- maybe (initGameMetrics $ rs ^. metrics) pure prevGMetric
+  wMetric <- maybe (initWorldMetrics $ rs ^. metrics) pure prevWMetric
+  return $ pureScenarioToGameState si theSeed now toRun (Just gMetric) (Just wMetric) (rs ^. stdGameConfigInputs)
 
 pureScenarioToGameState ::
   ScenarioWith (Maybe ScenarioPath) ->
   Seed ->
   Clock.TimeSpec ->
   Maybe CodeToRun ->
   Maybe GameMetrics ->
+  Maybe WorldMetrics ->
   GameStateConfig ->
   GameState
-pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gMetric gsc =
+pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gMetric wMetric gsc =
   preliminaryGameState
     & discovery . structureRecognition .~ recognition
  where
@@ -110,6 +113,7 @@ pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gMetric gsc
       & randomness . randGen .~ mkStdGen theSeed
       & recipesInfo %~ modifyRecipesInfo
       & landscape .~ mkLandscape sLandscape worldTuples theSeed
+      & landscape . worldMetrics .~ wMetric
       & gameControls . initiallyRunCode .~ (erase <$> initialCodeToRun)
       & gameControls . replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working,
       -- otherwise the store of definition cells is not saved (see #333, #838)

src/swarm-scenario/Swarm/Game/State/Landscape.hs

@@ -14,6 +14,7 @@ module Swarm.Game.State.Landscape (
   worldScrollable,
   terrainAndEntities,
   recognizerAutomatons,
+  worldMetrics,
 
   -- ** Utilities
   initLandscape,
@@ -64,6 +65,7 @@ data Landscape = Landscape
   , _terrainAndEntities :: TerrainEntityMaps
   , _recognizerAutomatons :: RecognizerAutomatons RecognizableStructureContent Entity
   , _worldScrollable :: Bool
+  , _worldMetrics :: Maybe WorldMetrics
   }
 
 makeLensesNoSigs ''Landscape
@@ -87,6 +89,9 @@ recognizerAutomatons :: Lens' Landscape (RecognizerAutomatons RecognizableStruct
 -- | Whether the world map is supposed to be scrollable or not.
 worldScrollable :: Lens' Landscape Bool
 
+-- | Metrics tracked for the Swarm World, namely tile load time and cache. See 'RuntimeState' metrics store.
+worldMetrics :: Lens' Landscape (Maybe WorldMetrics)
+
 -- | Create an record that is empty except for
 -- system-provided entities.
 initLandscape :: GameStateConfig -> Landscape
@@ -97,6 +102,7 @@ initLandscape gsc =
     , _terrainAndEntities = initEntityTerrain $ gsiScenarioInputs $ initState gsc
     , _recognizerAutomatons = RecognizerAutomatons mempty mempty
     , _worldScrollable = True
+    , _worldMetrics = Nothing
     }
 
 mkLandscape :: ScenarioLandscape -> NonEmpty SubworldDescription -> Seed -> Landscape
@@ -110,6 +116,7 @@ mkLandscape sLandscape worldTuples theSeed =
       -- Leaning toward no, but for now just adopt the root world scrollability
       -- as being universal.
       _worldScrollable = NE.head (sLandscape ^. scenarioWorlds) ^. to scrollable
+    , _worldMetrics = Nothing
     }
 
 buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription

src/swarm-scenario/Swarm/Game/World.hs

@@ -33,9 +33,8 @@ module Swarm.Game.World (
   lookupEntityM,
   lookupContentM,
   updateM,
-  -- TODO: #2555
-  -- loadCellM
-  -- loadRegionM,
+  loadCellM,
+  loadRegionM,
 
   -- * Multi-Worlds
   MultiWorld,
@@ -47,12 +46,14 @@ module Swarm.Game.World (
 
   -- * Re-Exports
   Seed,
+  module Metrics,
   module Coords,
 ) where
 
 import Swarm.Game.World.Coords as Coords
 import Swarm.Game.World.DSL.Gen (Seed)
 import Swarm.Game.World.Function
+import Swarm.Game.World.Metrics as Metrics
 import Swarm.Game.World.Multi
 import Swarm.Game.World.Pure
 import Swarm.Game.World.Stateful

src/swarm-scenario/Swarm/Game/World/Metrics.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+-- Description: Game-related state and utilities
+--
+-- Definition of metrics tracked for world.
+module Swarm.Game.World.Metrics (
+  WorldMetrics (..),
+  initWorldMetrics,
+) where
+
+import System.Metrics
+import System.Metrics.Distribution (Distribution)
+import System.Metrics.Gauge (Gauge)
+
+-- | Metrics tracked in Swarm game engine.
+data WorldMetrics = WorldMetrics
+  { loadedTiles :: Gauge
+  , inMemoryTiles :: Gauge
+  , tilesBatchLoadTime :: Distribution
+  , tileAverageLoadTime :: Distribution
+  }
+
+-- | Create and register the metrics to metric store.
+--
+-- This function can be only called **once** on the store.
+initWorldMetrics :: Store -> IO WorldMetrics
+initWorldMetrics s = do
+  loadedTiles <- createGauge "game.tile_loaded" s
+  inMemoryTiles <- createGauge "game.tile_in_memory" s
+  tileAverageLoadTime <- createDistribution "game.tile_average_load_time" s
+  tilesBatchLoadTime <- createDistribution "game.tile_batch_load_time" s
+  pure WorldMetrics {..}

src/swarm-scenario/Swarm/Game/World/Pure.hs

@@ -36,20 +36,21 @@ module Swarm.Game.World.Pure (
   loadRegion,
 ) where
 
-import Control.Arrow ((&&&))
+import Control.Arrow (second)
 import Control.Lens hiding (use)
 import Data.Array qualified as A
 import Data.Array.IArray
 import Data.Array.Unboxed qualified as U
-import Data.Foldable (foldl')
+import Data.List qualified as List
 import Data.Map.Strict qualified as M
+import Data.Strict (toLazy, toStrict)
+import Data.Strict qualified as Strict
 import Swarm.Game.Entity (Entity, entityHash)
 import Swarm.Game.Scenario.Topography.Modify
 import Swarm.Game.World.Coords
 import Swarm.Game.World.Function
 import Swarm.Game.World.Tile
 import Swarm.Util ((?))
-import Prelude hiding (Foldable (..), lookup)
 
 -- | A 'World' consists of a 'WorldFun' that specifies the initial
 --   world, a cache of loaded square tiles to make lookups faster, and
@@ -65,8 +66,8 @@ import Prelude hiding (Foldable (..), lookup)
 --   handle respawning.
 data World t e = World
   { worldFun :: WorldFun t e
-  , tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e)
-  , changed :: M.Map Coords (Maybe e)
+  , tileCache :: M.Map TileCoords (Strict.Pair (TerrainTile t) (EntityTile e))
+  , changed :: M.Map Coords (Strict.Maybe e)
   }
 
 -- | Create a new 'World' from a 'WorldFun'.
@@ -81,7 +82,7 @@ newWorld f = World f M.empty M.empty
 --   given coordinates is loaded.  For that, see 'lookupTerrainM'.
 lookupTerrain :: (IArray U.UArray t) => Coords -> World t e -> t
 lookupTerrain i (World f t _) =
-  ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t)
+  ((U.! tileOffset i) . Strict.fst <$> M.lookup (tileCoords i) t)
     ? fst (runWF f i)
 
 -- | Look up the entity at certain coordinates: first, see if it is in
@@ -92,10 +93,11 @@ lookupTerrain i (World f t _) =
 --   This function does /not/ ensure that the tile containing the
 --   given coordinates is loaded.  For that, see 'lookupEntityM'.
 lookupEntity :: Coords -> World t e -> Maybe e
-lookupEntity i (World f t m) =
-  M.lookup i m
-    ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)
-    ? snd (runWF f i)
+lookupEntity i (World f t m) = modifiedEntity ? cachedTileEntity ? computedEntity
+ where
+  modifiedEntity = toLazy <$> M.lookup i m
+  cachedTileEntity = toLazy . (A.! tileOffset i) . Strict.snd <$> M.lookup (tileCoords i) t
+  computedEntity = snd (runWF f i)
 
 -- | Update the entity (or absence thereof) at a certain location,
 --   returning an updated 'World' and a Boolean indicating whether
@@ -109,7 +111,7 @@ update ::
 update i g w@(World f t m) =
   (wNew, classifyModification (view entityHash) entityBefore entityAfter)
  where
-  wNew = World f t $ M.insert i entityAfter m
+  wNew = World f t $ M.insert i (toStrict entityAfter) m
   entityBefore = lookupEntity i w
   entityAfter = g entityBefore
 
@@ -119,7 +121,7 @@ loadCell ::
   Coords ->
   World t e ->
   World t e
-loadCell c = loadRegion (c, c)
+loadCell c = fst . loadRegion (c, c)
 
 -- | Load all the tiles which overlap the given rectangular region
 --   (specified as an upper-left and lower-right corner, inclusive).
@@ -128,18 +130,17 @@ loadRegion ::
   (IArray U.UArray t) =>
   (Coords, Coords) ->
   World t e ->
-  World t e
-loadRegion reg (World f t m) = World f t' m
+  (World t e, [TileCoords])
+loadRegion reg (World f t m) = (World f t' m, tileCs)
  where
-  tiles = range (over both tileCoords reg)
-  t' = foldl' (\hm (i, tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles)
-
-  maybeInsert k v tm
-    | k `M.member` tm = tm
-    | otherwise = M.insert k v tm
+  -- the range is applied to tile coordinates, so we are not loading a tile twice
+  tileCs = filter (`M.notMember` t) $ range (over both tileCoords reg)
+  tiles = map loadTile tileCs
+  t' = List.foldl' (\hm (i, tile) -> M.insert i tile hm) t (zip tileCs tiles)
 
-  loadTile :: TileCoords -> (TerrainTile t, EntityTile e)
-  loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities)
+  loadTile :: TileCoords -> Strict.Pair (TerrainTile t) (EntityTile e)
+  loadTile tc = listArray tileBounds terrain Strict.:!: listArray tileBounds entities
    where
     tileCorner = tileOrigin tc
-    (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds)
+    runWF' = second toStrict . runWF f
+    (terrain, entities) = unzip $ map (runWF' . plusOffset tileCorner) (range tileBounds)

src/swarm-scenario/Swarm/Game/World/Stateful.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- |
@@ -18,20 +19,32 @@ module Swarm.Game.World.Stateful (
 
   -- ** Update
   updateM,
-  -- TODO: #2555
-  -- Loading
-  -- loadCellM,
-  -- loadRegionM,
+
+  -- ** Loading
+  loadCellM,
+  loadRegionM,
 ) where
 
 import Control.Algebra (Has)
 import Control.Effect.State (State, get, modify, state)
+import Control.Monad (unless, void)
 import Data.Array.IArray
 import Data.Array.Unboxed qualified as U
+import Data.Map.Strict qualified as M
+import Swarm.Effect qualified as Effect
 import Swarm.Game.Entity (Entity)
 import Swarm.Game.Scenario.Topography.Modify
 import Swarm.Game.World.Coords
+import Swarm.Game.World.Metrics
 import Swarm.Game.World.Pure
+import Swarm.Game.World.Tile
+
+type HasWorldStateEffect t e sig m =
+  ( IArray U.UArray t
+  , Has (State (World t e)) sig m
+  , Has Effect.Metric sig m
+  , Has Effect.Time sig m
+  )
 
 -- | A stateful variant of 'lookupTerrain', which first loads the tile
 --   containing the given coordinates if it is not already loaded,
@@ -77,3 +90,35 @@ updateM ::
   m (CellUpdate Entity)
 updateM c g = do
   state @(World t Entity) $ update c g . loadCell c
+
+loadCellM ::
+  forall t e sig m.
+  HasWorldStateEffect t e sig m =>
+  Maybe WorldMetrics ->
+  Coords ->
+  m ()
+loadCellM wm c = loadRegionM @t @e wm (c, c)
+
+loadRegionM ::
+  forall t e sig m.
+  HasWorldStateEffect t e sig m =>
+  Maybe WorldMetrics ->
+  (Coords, Coords) ->
+  m ()
+loadRegionM wm = updateMetric . state @(World t e) . loadRegion'
+ where
+  loadRegion' :: (Coords, Coords) -> World t e -> (World t e, [TileCoords])
+  loadRegion' cc ow = let (nw, ts) = loadRegion cc ow in nw.tileCache `seq` (nw, ts)
+  updateMetric :: m [TileCoords] -> m ()
+  updateMetric m = case wm of
+    Nothing -> void m
+    Just wMetrics -> do
+      (loadTime, loadedTiles) <- Effect.measureCpuTimeInSec m
+      inMemoryTiles <- M.size . (.tileCache) <$> get @(World t e)
+      Effect.gaugeSet wMetrics.inMemoryTiles inMemoryTiles
+      unless (null loadedTiles) $ do
+        let loadedCount = length loadedTiles
+        let avgTime = loadTime / fromIntegral loadedCount
+        Effect.gaugeAdd wMetrics.loadedTiles loadedCount
+        Effect.distributionAdd wMetrics.tilesBatchLoadTime loadTime
+        Effect.distributionAdd wMetrics.tileAverageLoadTime avgTime

src/swarm-scenario/Swarm/Game/World/Tile.hs

@@ -33,6 +33,7 @@ import Data.Array.IArray qualified as A
 import Data.Array.Unboxed qualified as U
 import Data.Bits
 import Data.Int (Int32)
+import Data.Strict qualified as Strict
 import GHC.Generics (Generic)
 import Swarm.Game.World.Coords
 
@@ -42,7 +43,7 @@ type TerrainTile t = U.UArray TileOffset t
 -- | An entity tile is an array of possible entity values.  Note it
 --   cannot be an unboxed array since entities are complex records
 --   which have to be boxed.
-type EntityTile e = A.Array TileOffset (Maybe e)
+type EntityTile e = A.Array TileOffset (Strict.Maybe e)
 
 -- | The number of bits we need in each coordinate to represent all
 --   the locations in a tile.  In other words, each tile has a size of

src/swarm-tournament/Swarm/Web/Tournament/Validate.hs

@@ -193,7 +193,7 @@ gamestateFromScenarioText content = do
 
   let scenarioInputs = gsiScenarioInputs . initState $ rs ^. stdGameConfigInputs
   scenarioObject <- initScenarioObject scenarioInputs content
-  gs <- liftIO $ scenarioToGameState (ScenarioWith scenarioObject Nothing) emptyLaunchParams Nothing rs
+  gs <- liftIO $ scenarioToGameState (ScenarioWith scenarioObject Nothing) emptyLaunchParams Nothing Nothing rs
   return (gs, scenarioObject)
 
 verifySolution ::