demo pixi.js

src/Swarm/Game/Entity/Cosmetic.hs

@@ -61,6 +61,12 @@ getBackground = \case
   BgOnly x -> Just x
   FgAndBg _ x -> Just x
 
+flattenBg :: ColorLayers a -> a
+flattenBg = \case
+  FgOnly x -> x
+  BgOnly x -> x
+  FgAndBg _ x -> x
+
 newtype WorldAttr = WorldAttr String
   deriving (Eq, Ord, Show)
 

src/Swarm/Game/Scenario.hs

@@ -81,6 +81,7 @@ import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Objective.Validation
 import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Scenario.Style
+import Swarm.Game.Scenario.Topography.Area (Grid (Grid))
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..))
@@ -201,7 +202,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
             (sequenceA . (id &&& (Structure.mergeStructures mempty Root . Structure.structure)))
             rootLevelSharedStructures
 
-      let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> Structure.Grid s <$ ns) mergedStructures
+      let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> Grid s <$ ns) mergedStructures
 
       allWorlds <- localE (worldMap,rootLevelSharedStructures,,rsMap) $ do
         rootWorld <- v ..: "world"

src/Swarm/Game/Scenario/Style.hs

@@ -39,7 +39,7 @@ instance ToJSON StyleFlag where
 -- | Hexadecimal color notation.
 -- May include a leading hash symbol (see 'Data.Colour.SRGB.sRGB24read').
 newtype HexColor = HexColor Text
-  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
 
 data CustomAttr = CustomAttr
   { name :: String

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

@@ -4,12 +4,24 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Topography.Area where
 
+import Data.Aeson (ToJSON (..))
 import Data.Int (Int32)
 import Data.List qualified as L
 import Data.Maybe (listToMaybe)
 import Linear (V2 (..))
 import Swarm.Game.Location
 
+newtype Grid c = Grid
+  { unGrid :: [[c]]
+  }
+  deriving (Show, Eq, Functor, Foldable, Traversable)
+
+instance (ToJSON a) => ToJSON (Grid a) where
+  toJSON (Grid g) = toJSON g
+
+getGridDimensions :: Grid a -> AreaDimensions
+getGridDimensions (Grid g) = getAreaDimensions g
+
 -- | Height and width of a 2D map region
 data AreaDimensions = AreaDimensions
   { rectWidth :: Int32

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

@@ -35,11 +35,6 @@ import Swarm.Util (commaList, failT, quote, showT)
 import Swarm.Util.Yaml
 import Witch (into)
 
-newtype Grid c = Grid
-  { unGrid :: [[c]]
-  }
-  deriving (Show, Eq)
-
 data NamedArea a = NamedArea
   { name :: StructureName
   , recognize :: Set AbsoluteDir

src/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs

@@ -53,6 +53,7 @@ import Data.Set qualified as Set
 import Data.Tuple (swap)
 import Swarm.Game.Entity (Entity, entityName)
 import Swarm.Game.Scenario (StaticStructureInfo (..))
+import Swarm.Game.Scenario.Topography.Area (Grid (Grid))
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
 import Swarm.Game.Scenario.Topography.Structure

src/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs

@@ -10,6 +10,7 @@ import Control.Monad (unless, when)
 import Data.Map qualified as M
 import Data.Set qualified as Set
 import Data.Text qualified as T
+import Swarm.Game.Scenario.Topography.Area (Grid (Grid))
 import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RotationalSymmetry (..), SymmetryAnnotatedGrid (..))
@@ -66,4 +67,4 @@ checkSymmetry ng = do
   halfTurnRows = applyOrientationTransform (Orientation DSouth False) originalRows
 
   suppliedOrientations = Structure.recognize ng
-  Structure.Grid originalRows = Structure.structure ng
+  Grid originalRows = Structure.structure ng

src/Swarm/Game/World/Render.hs

@@ -21,7 +21,7 @@ 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.Status (seedLaunchParams)
-import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions, isEmpty, upperLeftToBottomRight)
+import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Center
 import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)
@@ -62,10 +62,7 @@ getDisplayColor aMap c =
 mkPixelColor :: PreservableColor -> PixelRGBA8
 mkPixelColor h = PixelRGBA8 r g b 255
  where
-  RGB r g b = case fromHiFi h of
-    FgOnly c -> c
-    BgOnly c -> c
-    FgAndBg _ c -> c
+  RGB r g b = flattenBg $ fromHiFi h
 
 -- | Since terminals can customize these named
 -- colors using themes or explicit user overrides,
@@ -94,7 +91,7 @@ getDisplayGrid ::
   Scenario ->
   GameState ->
   Maybe AreaDimensions ->
-  [[PCell EntityFacade]]
+  Grid (PCell EntityFacade)
 getDisplayGrid myScenario gs maybeSize =
   getMapRectangle
     mkFacade
@@ -129,7 +126,7 @@ getDisplayGrid myScenario gs maybeSize =
 getRenderableGrid ::
   RenderOpts ->
   FilePath ->
-  IO ([[PCell EntityFacade]], M.Map WorldAttr PreservableColor)
+  IO (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor)
 getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize) fp = simpleErrorHandle $ do
   (myScenario, (worldDefs, entities, recipes)) <- loadStandaloneScenario fp
   appDataMap <- readAppData
@@ -152,12 +149,12 @@ doRenderCmd opts@(RenderOpts _ asPng _ _) mapPath =
 renderScenarioMap :: RenderOpts -> FilePath -> IO [String]
 renderScenarioMap opts fp = do
   (grid, _) <- getRenderableGrid opts fp
-  return $ map (map getDisplayChar) grid
+  return $ unGrid $ getDisplayChar <$> grid
 
 -- | Converts linked lists to vectors to facilitate
 -- random access when assembling the image
-gridToVec :: [[a]] -> V.Vector (V.Vector a)
-gridToVec = V.fromList . map V.fromList
+gridToVec :: Grid a -> V.Vector (V.Vector a)
+gridToVec (Grid g) = V.fromList . map V.fromList $ g
 
 renderScenarioPng :: RenderOpts -> FilePath -> IO ()
 renderScenarioPng opts fp = do
@@ -167,7 +164,7 @@ renderScenarioPng opts fp = do
   mkImg aMap g = generateImage (pixelRenderer vecGrid) (fromIntegral w) (fromIntegral h)
    where
     vecGrid = gridToVec g
-    AreaDimensions w h = getAreaDimensions g
+    AreaDimensions w h = getGridDimensions g
     pixelRenderer vg x y = getDisplayColor aMap $ (vg V.! y) V.! x
 
 printScenarioMap :: [String] -> IO ()

src/Swarm/TUI/Editor/Palette.hs

@@ -22,7 +22,7 @@ import Swarm.Game.Display (Display, defaultChar)
 import Swarm.Game.Entity (EntityName, entitiesByName)
 import Swarm.Game.Location
 import Swarm.Game.Scenario
-import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions)
+import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
@@ -112,8 +112,8 @@ makeSuggestedPalette maybeOriginalScenario cellGrid =
     f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing []))
 
 -- | Generate a \"skeleton\" scenario with placeholders for certain required fields
-constructScenario :: Maybe Scenario -> [[CellPaintDisplay]] -> SkeletonScenario
-constructScenario maybeOriginalScenario cellGrid =
+constructScenario :: Maybe Scenario -> Grid CellPaintDisplay -> SkeletonScenario
+constructScenario maybeOriginalScenario (Grid cellGrid) =
   SkeletonScenario
     (maybe 1 (^. scenarioVersion) maybeOriginalScenario)
     (maybe "My Scenario" (^. scenarioName) maybeOriginalScenario)

src/Swarm/TUI/Editor/Util.hs

@@ -106,8 +106,8 @@ getEditedMapRectangle ::
   WorldOverdraw ->
   Maybe (Cosmic W.BoundsRectangle) ->
   W.MultiWorld Int Entity ->
-  [[CellPaintDisplay]]
-getEditedMapRectangle _ Nothing _ = []
+  EA.Grid CellPaintDisplay
+getEditedMapRectangle _ Nothing _ = EA.Grid []
 getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w =
   getMapRectangle toFacade getContent coords
  where
@@ -117,9 +117,9 @@ getMapRectangle ::
   (d -> e) ->
   (W.Coords -> (TerrainType, Maybe d)) ->
   W.BoundsRectangle ->
-  [[PCell e]]
+  EA.Grid (PCell e)
 getMapRectangle paintTransform contentFunc coords =
-  map renderRow [yTop .. yBottom]
+  EA.Grid $ map renderRow [yTop .. yBottom]
  where
   (W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords
 

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,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Web.Worldview where
+
+import Control.Lens ((^.))
+import Control.Monad.Trans.State
+import Data.Aeson (ToJSON)
+import Data.Colour.Palette.BrewerSet (Kolor)
+import Data.Colour.SRGB (RGB (..), sRGB24, sRGB24show)
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Data.Tuple (swap)
+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)
+import Swarm.Game.World.Render
+import Swarm.TUI.View.CellDisplay (getTerrainEntityColor)
+
+data GridResponse = GridResponse
+  { isPlaying :: Bool
+  , grid :: Maybe CellGrid
+  }
+  deriving (Generic, ToJSON)
+
+getCellGrid ::
+  Scenario ->
+  GameState ->
+  AreaDimensions ->
+  CellGrid
+getCellGrid myScenario gs requestedSize =
+  CellGrid indexGrid invertedMap
+ where
+  dg = getDisplayGrid 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, indexMap) = runState (mapM (encodeOccurrence . f) dg) mempty
+  invertedMap = M.fromList . map swap . M.toList $ indexMap
+
+data CellGrid = CellGrid
+  { coords :: Grid Int
+  , colors :: Map Int HexColor
+  }
+  deriving (Generic, ToJSON)
+
+instance SD.ToSample GridResponse where
+  toSamples _ = SD.noSamples
+
+-- ** Utility
+
+type OccurrenceEncoder a = State (Map a Int)
+
+-- | Translate each the first occurrence in the
+-- world map 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
+  currentMap <- get
+  case M.lookup c currentMap of
+    Just entry -> return entry
+    Nothing -> do
+      put $ M.insert c newIdx currentMap
+      return newIdx
+     where
+      newIdx = M.size currentMap

swarm.cabal

@@ -288,6 +288,7 @@ library
                       Swarm.Util.Effect
                       Swarm.Version
                       Swarm.Web
+                      Swarm.Web.Worldview
 
     reexported-modules: Control.Carrier.Accum.FixedStrict
                       , Data.BoolExpr.Simplify
@@ -299,7 +300,6 @@ library
                       , Swarm.Util.UnitInterval
                       , Swarm.Util.WindowedCounter
                       , Swarm.Util.Yaml
-
     other-modules:    Paths_swarm
     autogen-modules:  Paths_swarm
 

web/index.html

@@ -4,7 +4,9 @@
     <title>Swarm server</title>
   </head>
   <body>
+    <img src="handwritten-logo.png"/>
     <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>