world editor prototype

src/Swarm/Game/Scenario.hs

@@ -20,7 +20,7 @@ module Swarm.Game.Scenario (
   IndexedTRobot,
 
   -- * Scenario
-  Scenario,
+  Scenario (..),
 
   -- ** Fields
   scenarioVersion,
@@ -45,7 +45,7 @@ module Swarm.Game.Scenario (
   getScenarioPath,
 ) where
 
-import Control.Lens hiding (from, (<.>))
+import Control.Lens hiding (from, (.=), (<.>))
 import Control.Monad (filterM)
 import Control.Monad.Except (ExceptT (..), MonadIO, liftIO, runExceptT, withExceptT)
 import Control.Monad.Trans.Except (except)

src/Swarm/Game/Scenario/Cell.hs

@@ -6,15 +6,18 @@
 module Swarm.Game.Scenario.Cell (
   PCell (..),
   Cell,
+  CellPaintDisplay,
 ) where
 
-import Control.Lens hiding (from, (<.>))
+import Control.Lens hiding (from, (.=), (<.>))
 import Control.Monad (when)
 import Control.Monad.Extra (mapMaybeM)
+import Data.Maybe (catMaybes, listToMaybe)
 import Data.Text (Text)
 import Data.Vector qualified as V
 import Data.Yaml as Y
 import Swarm.Game.Entity
+import Swarm.Game.Scenario.EntityFacade
 import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Terrain
 import Swarm.Util.Yaml
@@ -38,6 +41,19 @@ data PCell e = Cell
 --   and optionally an entity and robot.
 type Cell = PCell Entity
 
+-- | Re-usable serialization for variants of "PCell"
+mkPCellJson :: ToJSON b => (a -> b) -> PCell a -> Value
+mkPCellJson modifier x =
+  toJSON $
+    catMaybes
+      [ Just . toJSON . getTerrainWord $ cellTerrain x
+      , toJSON . modifier <$> cellEntity x
+      , listToMaybe []
+      ]
+
+instance ToJSON Cell where
+  toJSON = mkPCellJson $ view entityName
+
 -- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'.  The
 --   entity and robot, if present, are immediately looked up and
 --   converted into 'Entity' and 'TRobot' values.  If they are not
@@ -62,3 +78,16 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
     robs <- mapMaybeM name2rob (drop 2 tup)
 
     return $ Cell terr ent robs
+
+------------------------------------------------------------
+-- World editor
+------------------------------------------------------------
+
+-- | Stateless cells used for the World Editor.
+-- These cells contain the bare minimum display information
+-- for rendering.
+type CellPaintDisplay = PCell EntityFacade
+
+-- Note: This instance is used only for the purpose of WorldPalette
+instance ToJSON CellPaintDisplay where
+  toJSON = mkPCellJson id

src/Swarm/Game/Scenario/EntityFacade.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE DerivingVia #-}
+
+-- | Stand-in type for an "Entity" for purposes
+-- that do not require carrying around the entire state
+-- of an Entity.
+--
+-- Useful for simplified serialization, debugging,
+-- and equality checking, particularly for the World Editor.
+module Swarm.Game.Scenario.EntityFacade where
+
+import Control.Lens hiding (from, (.=), (<.>))
+import Data.Text (Text)
+import Data.Yaml as Y
+import Swarm.Game.Display (Display)
+import Swarm.Game.Entity qualified as E
+
+type EntityName = Text
+
+-- | This datatype is a lightweight stand-in for the
+-- full-fledged "Entity" type without the baggage of all
+-- of its other fields.
+-- It contains the bare minimum display information
+-- for rendering.
+data EntityFacade = EntityFacade EntityName Display
+  deriving (Eq)
+
+-- Note: This instance is used only for the purpose of WorldPalette
+instance ToJSON EntityFacade where
+  toJSON (EntityFacade eName _display) = toJSON eName
+
+mkFacade :: E.Entity -> EntityFacade
+mkFacade e =
+  EntityFacade
+    (e ^. E.entityName)
+    (e ^. E.entityDisplay)

src/Swarm/Game/Scenario/WorldDescription.hs

@@ -6,30 +6,23 @@
 module Swarm.Game.Scenario.WorldDescription where
 
 import Data.Aeson.Key qualified as Key
-import Data.Aeson.KeyMap (KeyMap)
 import Data.Aeson.KeyMap qualified as KeyMap
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Yaml as Y
 import Swarm.Game.Entity
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Cell
+import Swarm.Game.Scenario.EntityFacade
 import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Scenario.WorldPalette
 import Swarm.Util.Yaml
 import Witch (into)
 
 ------------------------------------------------------------
 -- World description
 ------------------------------------------------------------
 
--- | A world palette maps characters to 'Cell' values.
-newtype WorldPalette e = WorldPalette
-  {unPalette :: KeyMap (PCell e)}
-  deriving (Eq, Show)
-
-instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
-  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
-
 -- | A description of a world parsed from a YAML file.
 -- This type is parameterized to accommodate Cells that
 -- utilize a less stateful Entity type.
@@ -66,3 +59,25 @@ paintMap pal = traverse (traverse toCell . into @String) . T.lines
   toCell c = case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of
     Nothing -> fail $ "Char not in world palette: " ++ show c
     Just cell -> return cell
+
+------------------------------------------------------------
+-- World editor
+------------------------------------------------------------
+
+-- | A pared-down (stateless) version of "WorldDescription" just for
+-- the purpose of rendering a Scenario file
+type WorldDescriptionPaint = PWorldDescription EntityFacade
+
+instance ToJSON WorldDescriptionPaint where
+  toJSON w =
+    object
+      [ "default" .= defaultTerrain w
+      , "offset" .= offsetOrigin w
+      , "palette" .= Y.toJSON paletteKeymap
+      , "upperleft" .= ul w
+      , "map" .= Y.toJSON mapText
+      ]
+   where
+    cellGrid = area w
+    suggestedPalette = palette w
+    (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid

src/Swarm/Game/Scenario/WorldPalette.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Game.Scenario.WorldPalette where
+
+import Control.Arrow (first)
+import Control.Lens hiding (from, (.=), (<.>))
+import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.KeyMap qualified as KM
+import Data.Map qualified as M
+import Data.Set qualified as Set
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Tuple (swap)
+import Swarm.Game.Entity
+import Swarm.Game.Scenario.Cell
+import Swarm.Game.Scenario.EntityFacade
+import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Terrain (TerrainType)
+import Swarm.Util.Yaml
+
+-- | A world palette maps characters to 'Cell' values.
+newtype WorldPalette e = WorldPalette
+  {unPalette :: KeyMap (PCell e)}
+  deriving (Eq, Show)
+
+instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
+  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
+
+type TerrainWith a = (TerrainType, Maybe a)
+
+cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
+cellToTerrainPair (Cell terrain maybeEntity _) = (terrain, maybeEntity)
+
+toCellPaintDisplay :: Cell -> CellPaintDisplay
+toCellPaintDisplay (Cell terrain maybeEntity r) =
+  Cell terrain (mkFacade <$> maybeEntity) r
+
+toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
+toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName)
+
+-- | We want to identify all of the unique (terrain, entity facade) pairs.
+-- However, "EntityFacade" includes a "Display" record, which contains more
+-- fields than desirable for use as a unique key.
+-- Therefore, we extract just the entity name for use in a
+-- (terrain, entity name) key, and couple it with the original
+-- (terrain, entity facade) pair in a Map.
+getUniqueTerrainFacadePairs ::
+  [[CellPaintDisplay]] ->
+  M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
+getUniqueTerrainFacadePairs cellGrid =
+  M.fromList $ concatMap (map genTuple) cellGrid
+ where
+  genTuple c =
+    (toKey terrainEfd, terrainEfd)
+   where
+    terrainEfd = cellToTerrainPair c
+
+constructPalette ::
+  [(Char, TerrainWith EntityFacade)] ->
+  KM.KeyMap CellPaintDisplay
+constructPalette mappedPairs =
+  KM.fromMapText terrainEntityPalette
+ where
+  g (terrain, maybeEfd) = Cell terrain maybeEfd []
+  terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs
+
+constructWorldMap ::
+  [(Char, TerrainWith EntityFacade)] ->
+  [[CellPaintDisplay]] ->
+  Text
+constructWorldMap mappedPairs =
+  T.unlines . map (T.pack . map renderMapCell)
+ where
+  invertedMappedPairs = map (swap . fmap toKey) mappedPairs
+
+  renderMapCell c =
+    -- NOTE: This lookup should never fail
+    M.findWithDefault (error "Palette lookup failed!") k $
+      M.fromList invertedMappedPairs
+   where
+    k = toKey $ cellToTerrainPair c
+
+-- | All alphanumeric characters. These are used as supplemental
+-- map placeholders in case a pre-existing display character is
+-- not available to re-use.
+genericCharacterPool :: Set.Set Char
+genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9']
+
+-- | Note that display characters are not unique
+-- across different entities! However, the palette KeyMap
+-- as a conveyance serves to dedupe them.
+prepForJson ::
+  WorldPalette EntityFacade ->
+  [[CellPaintDisplay]] ->
+  (Text, KM.KeyMap CellPaintDisplay)
+prepForJson (WorldPalette suggestedPalette) cellGrid =
+  (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs)
+ where
+  preassignments :: [(Char, TerrainWith EntityFacade)]
+  preassignments =
+    map (first T.head . fmap cellToTerrainPair) $
+      M.toList $
+        KM.toMapText suggestedPalette
+
+  entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
+  entityCells = getUniqueTerrainFacadePairs cellGrid
+
+  unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
+  unassignedCells =
+    M.withoutKeys entityCells $
+      Set.fromList $
+        map (toKey . snd) preassignments
+
+  unassignedCharacters :: Set.Set Char
+  unassignedCharacters =
+    -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char")
+    -- to generate this pool?
+    Set.difference genericCharacterPool $
+      Set.fromList $
+        map fst preassignments
+
+  newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
+  newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells
+
+  mappedPairs = preassignments <> newlyAssignedPairs

src/Swarm/Game/State.hs

@@ -719,7 +719,7 @@ unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id
 
 -- | Given a width and height, compute the region, centered on the
 --   'viewCenter', that should currently be in view.
-viewingRegion :: GameState -> (Int32, Int32) -> (W.Coords, W.Coords)
+viewingRegion :: GameState -> (Int32, Int32) -> W.BoundsRectangle
 viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax))
  where
   Location cx cy = g ^. viewCenter

src/Swarm/Game/Terrain.hs

@@ -8,6 +8,8 @@ module Swarm.Game.Terrain (
   -- * Terrain
   TerrainType (..),
   terrainMap,
+  getTerrainDefaultPaletteChar,
+  getTerrainWord,
 ) where
 
 import Data.Aeson (FromJSON (..), withText)
@@ -35,6 +37,12 @@ instance FromJSON TerrainType where
       Just ter -> return ter
       Nothing -> failT ["Unknown terrain type:", t]
 
+getTerrainDefaultPaletteChar :: TerrainType -> Char
+getTerrainDefaultPaletteChar = head . show
+
+getTerrainWord :: TerrainType -> T.Text
+getTerrainWord = T.toLower . T.pack . init . show
+
 -- | A map containing a 'Display' record for each different 'TerrainType'.
 terrainMap :: Map TerrainType Display
 terrainMap =

src/Swarm/Game/World.hs

@@ -17,6 +17,7 @@ module Swarm.Game.World (
   Coords (..),
   locToCoords,
   coordsToLoc,
+  BoundsRectangle,
 
   -- * Worlds
   WorldFun (..),
@@ -87,6 +88,10 @@ locToCoords (Location x y) = Coords (-y, x)
 coordsToLoc :: Coords -> Location
 coordsToLoc (Coords (r, c)) = Location c (-r)
 
+-- | Represents the top-left and bottom-right coordinates
+-- of a bounding rectangle of cells in the world map
+type BoundsRectangle = (Coords, Coords)
+
 ------------------------------------------------------------
 -- World function
 ------------------------------------------------------------