demo pixi.js

src/Swarm/Game/Scenario/Topography/Center.hs

@@ -15,11 +15,14 @@ import Swarm.Game.Scenario (Scenario)
 import Swarm.Game.State (SubworldDescription, genRobotTemplates)
 import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld))
 
-determineViewCenter ::
+-- | Determine view center for a static map
+-- without reference to a 'GameState'
+-- (i.e. outside the context of an active game)
+determineStaticViewCenter ::
   Scenario ->
   NonEmpty SubworldDescription ->
   Cosmic Location
-determineViewCenter s worldTuples =
+determineStaticViewCenter s worldTuples =
   fromMaybe defaultVC baseRobotLoc
  where
   theRobots = genRobotTemplates s worldTuples

src/Swarm/Game/World/Render.hs

@@ -19,7 +19,7 @@ import Swarm.Game.Display (defaultChar)
 import Swarm.Game.Entity.Cosmetic
 import Swarm.Game.Location
 import Swarm.Game.ResourceLoading (initNameGenerator, readAppData)
-import Swarm.Game.Scenario (Scenario, area, loadStandaloneScenario, scenarioCosmetics, scenarioWorlds, ul, worldName)
+import Swarm.Game.Scenario (PWorldDescription, Scenario, area, loadStandaloneScenario, scenarioCosmetics, scenarioWorlds, ul, worldName)
 import Swarm.Game.Scenario.Status (seedLaunchParams)
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
@@ -85,43 +85,49 @@ fromHiFi = fmap $ \case
   -- those triples are not inputs to the VTY attribute creation.
   AnsiColor x -> namedToTriple x
 
--- | When output size is not explicitly provided on command line,
+-- | When output size is not explicitly provided,
 -- uses natural map bounds (if a map exists).
+getBoundingBox ::
+  Location ->
+  PWorldDescription e ->
+  Maybe AreaDimensions ->
+  W.BoundsRectangle
+getBoundingBox vc scenarioWorld maybeSize =
+  mkBoundingBox areaDims upperLeftLocation
+ where
+  upperLeftLocation =
+    if null maybeSize && not (isEmpty mapAreaDims)
+      then ul scenarioWorld
+      else vc .+^ ((`div` 2) <$> V2 (negate w) h)
+
+  mkBoundingBox areaDimens upperLeftLoc =
+    both W.locToCoords locationBounds
+   where
+    lowerRightLocation = upperLeftToBottomRight areaDimens upperLeftLoc
+    locationBounds = (upperLeftLoc, lowerRightLocation)
+
+  worldArea = area scenarioWorld
+  mapAreaDims = getAreaDimensions worldArea
+  areaDims@(AreaDimensions w h) =
+    fromMaybe (AreaDimensions 20 10) $
+      maybeSize <|> surfaceEmpty isEmpty mapAreaDims
+
 getDisplayGrid ::
+  Location ->
   Scenario ->
   GameState ->
   Maybe AreaDimensions ->
-  Grid (PCell EntityFacade)
-getDisplayGrid myScenario gs maybeSize =
+  Grid CellPaintDisplay
+getDisplayGrid vc myScenario gs maybeSize =
   getMapRectangle
     mkFacade
     (getContentAt worlds . mkCosmic)
-    (mkBoundingBox areaDims upperLeftLocation)
+    (getBoundingBox vc firstScenarioWorld maybeSize)
  where
   mkCosmic = Cosmic $ worldName firstScenarioWorld
-
   worlds = view (landscape . multiWorld) gs
 
-  worldTuples = buildWorldTuples myScenario
-  vc = determineViewCenter myScenario worldTuples
-
   firstScenarioWorld = NE.head $ view scenarioWorlds myScenario
-  worldArea = area firstScenarioWorld
-  mapAreaDims = getAreaDimensions worldArea
-  areaDims@(AreaDimensions w h) =
-    fromMaybe (AreaDimensions 20 10) $
-      maybeSize <|> surfaceEmpty isEmpty mapAreaDims
-
-  upperLeftLocation =
-    if null maybeSize && not (isEmpty mapAreaDims)
-      then ul firstScenarioWorld
-      else view planar vc .+^ ((`div` 2) <$> V2 (negate w) h)
-
-  mkBoundingBox areaDimens upperLeftLoc =
-    both W.locToCoords locationBounds
-   where
-    lowerRightLocation = upperLeftToBottomRight areaDimens upperLeftLoc
-    locationBounds = (upperLeftLoc, lowerRightLocation)
 
 getRenderableGrid ::
   RenderOpts ->
@@ -138,7 +144,11 @@ getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize) fp = simpleErrorHandle $
         myScenario
         (seedLaunchParams maybeSeed)
         gsc
-  return (getDisplayGrid myScenario gs maybeSize, myScenario ^. scenarioCosmetics)
+  let vc =
+        view planar $
+          determineStaticViewCenter myScenario $
+            buildWorldTuples myScenario
+  return (getDisplayGrid vc myScenario gs maybeSize, myScenario ^. scenarioCosmetics)
 
 doRenderCmd :: RenderOpts -> FilePath -> IO ()
 doRenderCmd opts@(RenderOpts _ asPng _ _) mapPath =

src/Swarm/TUI/View.hs

@@ -243,7 +243,7 @@ drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of
       , padTop (Pad 1) table
       ]
    where
-    vc = determineViewCenter s worldTuples
+    vc = determineStaticViewCenter s worldTuples
 
     worldTuples = buildWorldTuples s
     theWorlds = genMultiWorld worldTuples $ fromMaybe 0 $ s ^. scenarioSeed

src/Swarm/Web.hs

@@ -67,6 +67,7 @@ import Swarm.Game.Robot
 import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Objective.Graph
 import Swarm.Game.Scenario.Objective.WinCheck
+import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
@@ -83,6 +84,7 @@ import Swarm.TUI.Model
 import Swarm.TUI.Model.Goal
 import Swarm.TUI.Model.UI
 import Swarm.Util.RingBuffer
+import Swarm.Web.Worldview
 import System.Timeout (timeout)
 import Text.Read (readEither)
 import WaiAppStatic.Types (unsafeToPiece)
@@ -108,6 +110,7 @@ type SwarmAPI =
     :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
     :<|> "paths" :> "log" :> Get '[JSON] (RingBuffer CacheLogEntry)
     :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem]
+    :<|> "map" :> Capture "size" AreaDimensions :> Get '[JSON] GridResponse
 
 swarmApi :: Proxy SwarmAPI
 swarmApi = Proxy
@@ -162,6 +165,7 @@ mkApp state events =
     :<|> codeRunHandler events
     :<|> pathsLogHandler state
     :<|> replHandler state
+    :<|> mapViewHandler state
 
 robotsHandler :: ReadableIORef AppState -> Handler [Robot]
 robotsHandler appStateRef = do
@@ -244,6 +248,18 @@ replHandler appStateRef = do
       items = toList replHistorySeq
   pure items
 
+mapViewHandler :: ReadableIORef AppState -> AreaDimensions -> Handler GridResponse
+mapViewHandler appStateRef areaSize = do
+  appState <- liftIO (readIORef appStateRef)
+  let maybeScenario = fst <$> appState ^. uiState . scenarioRef
+  pure $ case maybeScenario of
+    Just s ->
+      GridResponse True
+        . Just
+        . getCellGrid s (appState ^. gameState)
+        $ areaSize
+    Nothing -> GridResponse False Nothing
+
 -- ------------------------------------------------------------------
 -- Main app (used by service and for development)
 -- ------------------------------------------------------------------
@@ -338,3 +354,19 @@ instance ToCapture (Capture "id" RobotID) where
     SD.DocCapture
       "id" -- name
       "(integer) robot ID" -- description
+
+instance FromHttpApiData AreaDimensions where
+  parseUrlPiece x = left T.pack $ do
+    pieces <- mapM (readEither . T.unpack) $ T.splitOn "x" x
+    case pieces of
+      [w, h] -> return $ AreaDimensions w h
+      _ -> Left "Need two dimensions"
+
+instance SD.ToSample AreaDimensions where
+  toSamples _ = SD.samples [AreaDimensions 20 30]
+
+instance ToCapture (Capture "size" AreaDimensions) where
+  toCapture _ =
+    SD.DocCapture
+      "size" -- name
+      "(integer, integer) dimensions of area" -- description

src/Swarm/Web/Worldview.hs

@@ -0,0 +1,57 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+-- Description: Render game world for web display
+module Swarm.Web.Worldview where
+
+import Control.Lens ((^.))
+import Data.Aeson (ToJSON)
+import Data.Colour.Palette.BrewerSet (Kolor)
+import Data.Colour.SRGB (RGB (..), sRGB24, sRGB24show)
+import Data.IntMap qualified as IM
+import Data.Text qualified as T
+import GHC.Generics (Generic)
+import Servant.Docs qualified as SD
+import Swarm.Game.Entity.Cosmetic (RGBColor, flattenBg)
+import Swarm.Game.Scenario (Scenario, scenarioCosmetics)
+import Swarm.Game.Scenario.Style
+import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), Grid)
+import Swarm.Game.State (GameState, robotInfo)
+import Swarm.Game.State.Robot (viewCenter)
+import Swarm.Game.Universe (planar)
+import Swarm.Game.World.Render
+import Swarm.TUI.View.CellDisplay (getTerrainEntityColor)
+import Swarm.Util.OccurrenceEncoder
+
+data GridResponse = GridResponse
+  { isPlaying :: Bool
+  , grid :: Maybe CellGrid
+  }
+  deriving (Generic, ToJSON)
+
+getCellGrid ::
+  Scenario ->
+  GameState ->
+  AreaDimensions ->
+  CellGrid
+getCellGrid myScenario gs requestedSize =
+  CellGrid indexGrid encoding
+ where
+  vc = gs ^. robotInfo . viewCenter
+  dg = getDisplayGrid (vc ^. planar) myScenario gs (Just requestedSize)
+  aMap = myScenario ^. scenarioCosmetics
+
+  asColour :: RGBColor -> Kolor
+  asColour (RGB r g b) = sRGB24 r g b
+  asHex = HexColor . T.pack . sRGB24show . asColour
+
+  f = asHex . maybe (RGB 0 0 0) (flattenBg . fromHiFi) . getTerrainEntityColor aMap
+  (indexGrid, encoding) = runEncoder $ f <$> dg
+
+data CellGrid = CellGrid
+  { coords :: Grid IM.Key
+  , colors :: [HexColor]
+  }
+  deriving (Generic, ToJSON)
+
+instance SD.ToSample GridResponse where
+  toSamples _ = SD.noSamples

src/swarm-util/Swarm/Util/OccurrenceEncoder.hs

@@ -0,0 +1,58 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+-- Description: Compress representation of traversable
+--
+-- Useful for compressing the representation of a
+-- structure that has many repeating elements
+-- for transmission (e.g. over the network).
+module Swarm.Util.OccurrenceEncoder (
+  runEncoder,
+) where
+
+import Control.Monad.Trans.State
+import Data.List (sortOn)
+import Data.Map (Map)
+import Data.Map qualified as M
+
+type OccurrenceEncoder a = State (Encoder a)
+
+newtype Encoder a = Encoder (Map a Int)
+
+-- |
+-- Given a data structure that may have many repeating "complex" elements,
+-- will store the "complex" element representation
+-- in an array so that the structure's elements can be replaced
+-- with simple indices into that array.
+--
+-- The first encountered element is assigned index 0, and the next
+-- novel element encountered gets index 1, and so on.
+runEncoder ::
+  (Traversable t, Ord b) =>
+  t b ->
+  (t Int, [b])
+runEncoder structure =
+  getIndices <$> runState (mapM encodeOccurrence structure) emptyEncoder
+
+emptyEncoder :: Ord a => Encoder a
+emptyEncoder = Encoder mempty
+
+-- | Map indices are guaranteed to be contiguous
+-- from @[0..N]@, so we may convert to a list
+-- with no loss of information.
+getIndices :: Encoder a -> [a]
+getIndices (Encoder m) = map fst $ sortOn snd $ M.toList m
+
+-- | Translate each the first occurrence in the structure
+-- to a new integer as it is encountered.
+-- Subsequent encounters re-use the allocated integer.
+encodeOccurrence :: Ord a => a -> OccurrenceEncoder a Int
+encodeOccurrence c = do
+  Encoder currentMap <- get
+  maybe (cacheNewIndex currentMap) return $
+    M.lookup c currentMap
+ where
+  cacheNewIndex currentMap = do
+    put $ Encoder $ M.insert c newIdx currentMap
+    return newIdx
+   where
+    newIdx = M.size currentMap

swarm.cabal

@@ -103,6 +103,7 @@ library swarm-util
                       Swarm.Util
                       Swarm.Util.Erasable
                       Swarm.Util.Lens
+                      Swarm.Util.OccurrenceEncoder
                       Swarm.Util.Parse
                       Swarm.Util.RingBuffer
                       Swarm.Util.UnitInterval
@@ -288,12 +289,14 @@ library
                       Swarm.Util.Effect
                       Swarm.Version
                       Swarm.Web
+                      Swarm.Web.Worldview
 
     reexported-modules: Control.Carrier.Accum.FixedStrict
                       , Data.BoolExpr.Simplify
                       , Swarm.Util
                       , Swarm.Util.Erasable
                       , Swarm.Util.Lens
+                      , Swarm.Util.OccurrenceEncoder
                       , Swarm.Util.Parse
                       , Swarm.Util.RingBuffer
                       , Swarm.Util.UnitInterval

web/index.html

@@ -6,5 +6,6 @@
   <body>
     <h1>Hello Swarm player!</h1>
     <p>Looking for the <a href="api">Web API docs</a>?</p>
+    <p>Or an <a href="play.html">experimental web frontend</a> for the game?</p>
   </body>
 </html>

web/play.html

@@ -0,0 +1,32 @@
+<!doctype html>
+<html>
+  <head>
+    <title>Web frontend</title>
+    <script src="https://pixijs.download/release/pixi.js"></script>
+
+    <script src="script/display.js"></script>
+    <script src="script/fetch.js"></script>
+
+    <script>
+
+      function startLoop() {
+        const button = document.getElementById('restart-button');
+        button.style.display = 'none';
+
+        let displayWidth = 600;
+        let displayHeight = 300;
+        let out = setupGraphics(button, displayWidth, displayHeight);
+        let appView = out[0];
+        let graphics = out[1];
+        doFetch(button, appView, graphics, displayWidth, displayHeight);
+      }
+
+      window.onload=()=>{
+        startLoop();
+      }
+    </script>
+  </head>
+  <body>
+    <button id="restart-button" onclick="startLoop();" style="display: block;">Restart</button>
+  </body>
+</html>

web/script/display.js

@@ -0,0 +1,15 @@
+function setupGraphics(button, displayWidth, displayHeight) {
+
+    // Create the application helper and add its render target to the page
+    let app = new PIXI.Application({
+        width: displayWidth,
+        height: displayHeight,
+        backgroundColor: 0xFFFFFF
+        });
+
+    document.body.insertBefore(app.view, button);
+
+    const graphics = new PIXI.Graphics();
+    app.stage.addChild(graphics);
+    return [app.view, graphics];
+}