Make structures parseable independently of entity definitions (#1924)

This refactoring makes structures parseable independently of `Entity` and `Robot `definitions.

We can define a `Palette` that maps to an arbitrary type, for example `RGBColor` instead of `Cell Entity`.

## Testing
```
scripts/test/run-tests.sh standalone-topography
```

data/test/standalone-topography/checkerboard.yaml

@@ -0,0 +1,59 @@
+structures:
+  - name: checker pair
+    structure:
+      palette:
+        't': true
+        'f': false
+      map: |
+        ttttffff
+        ttttffff
+        ttttffff
+        ttttffff
+  - name: checker quad
+    structure:
+      palette:
+        't': true
+        'f': false
+      map: ""
+      placements:
+        - src: checker pair
+          offset: [0, 0]
+          truncate: false
+        - src: checker pair
+          offset: [0, -4]
+          truncate: false
+          orient:
+            up: south
+  - name: checker octo
+    structure:
+      palette:
+        't': true
+        'f': false
+      map: ""
+      placements:
+        - src: checker quad
+          offset: [0, 0]
+          truncate: false
+        - src: checker quad
+          offset: [8, 0]
+          truncate: false
+        - src: checker quad
+          offset: [0, -8]
+          truncate: false
+        - src: checker quad
+          offset: [8, -8]
+          truncate: false
+placements:
+  - src: checker octo
+    offset: [0, 0]
+    truncate: false
+  - src: checker octo
+    offset: [16, 0]
+    truncate: false
+  - src: checker octo
+    offset: [0, -16]
+    truncate: false
+  - src: checker octo
+    offset: [16, -16]
+    truncate: false
+map: ""

data/test/standalone-topography/circle-and-crosses.yaml

@@ -0,0 +1,66 @@
+structures:
+  - name: cross
+    structure:
+      structures:
+        - name: beam
+          structure:
+            palette:
+              't': true
+              'f': false
+            map: |
+              ttt
+              ttt
+              ttt
+              ttt
+              ttt
+              ttt
+              fff
+              fff
+              fff
+      placements:
+        - src: beam
+          offset: [0, 3]
+          truncate: false
+        - src: beam
+          offset: [-3, -3]
+          truncate: false
+          orient:
+            up: east
+      map: ""
+  - name: disc
+    structure:
+      mask: '.'
+      palette:
+        't': true
+      map: |
+        ..tttt..
+        .tttttt.
+        ttt..ttt
+        tt....tt
+        tt....tt
+        ttt..ttt
+        .tttttt.
+        ..tttt..
+placements:
+  - src: cross
+    offset: [0, -15]
+    truncate: false
+  - src: cross
+    offset: [0, 0]
+    truncate: false
+    orient:
+      up: east
+  - src: cross
+    offset: [15, 0]
+    truncate: false
+    orient:
+      up: south
+  - src: cross
+    offset: [15, -15]
+    truncate: false
+    orient:
+      up: west
+  - src: disc
+    offset: [8, -8]
+    truncate: false
+map: ""

scripts/normalize/all.sh

@@ -0,0 +1,11 @@
+#!/bin/bash -xe
+
+# Run this locally before pushing a branch to save some CI cycles
+
+SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )
+cd $SCRIPT_DIR/../..
+
+scripts/normalize/cabal.sh
+scripts/normalize/code-format.sh
+scripts/normalize/yaml.sh
+hlint .

scripts/validate/json-schemas.sh

@@ -5,6 +5,7 @@ cd $SCRIPT_DIR/../..
 
 find data/scenarios -name "*.yaml" -type f -print0 | xargs -0 check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/scenario.json --schemafile data/schema/scenario.json
 
-check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/terrains.json --schemafile data/schema/terrains.json data/terrains.yaml
-check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/entities.json --schemafile data/schema/entities.json data/entities.yaml
-check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/recipes.json --schemafile data/schema/recipes.json data/recipes.yaml
+for STEM in terrains entities recipes
+do
+  check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/$STEM.json --schemafile data/schema/$STEM.json data/$STEM.yaml
+done

src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs

@@ -27,11 +27,11 @@ import Linear (V2 (..))
 import Swarm.Game.Entity
 import Swarm.Game.Location
 import Swarm.Game.Scenario (Cell)
+import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure
 import Swarm.Game.State
 import Swarm.Game.State.Substate
 import Swarm.Game.Universe

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

@@ -117,11 +117,11 @@ import Swarm.Game.Robot.Concrete
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Status
+import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure
 import Swarm.Game.State.Landscape
 import Swarm.Game.State.Robot
 import Swarm.Game.State.Substate

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

@@ -102,7 +102,6 @@ import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..))
-import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure
 import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.Terrain
 import Swarm.Game.Universe
@@ -320,7 +319,7 @@ instance FromJSONE ScenarioInputs Scenario where
       let rsMap = buildRobotMap rs
 
       -- NOTE: These have not been merged with their children yet.
-      rootLevelSharedStructures :: Structure.InheritedStructureDefs <-
+      rootLevelSharedStructures :: InheritedStructureDefs <-
         localE (,rsMap) $
           v ..:? "structures" ..!= []
 

src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs

@@ -6,7 +6,7 @@
 module Swarm.Game.Scenario.Topography.Cell (
   PCell (..),
   Cell,
-  AugmentedCell (..),
+  AugmentedCell,
   CellPaintDisplay,
 ) where
 
@@ -23,7 +23,7 @@ import Swarm.Game.Entity hiding (empty)
 import Swarm.Game.Land
 import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Scenario.Topography.EntityFacade
-import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
+import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Terrain
 import Swarm.Util (quote, showT)
 import Swarm.Util.Erasable (Erasable (..))
@@ -49,11 +49,7 @@ data PCell e = Cell
 type Cell = PCell Entity
 
 -- | Supplements a cell with waypoint information
-data AugmentedCell e = AugmentedCell
-  { waypointCfg :: Maybe WaypointConfig
-  , standardCell :: PCell e
-  }
-  deriving (Eq, Show)
+type AugmentedCell e = SignpostableCell (PCell e)
 
 -- | Re-usable serialization for variants of 'PCell'
 mkPCellJson :: ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
@@ -71,6 +67,10 @@ instance ToJSON Cell where
     ENothing -> Nothing
     EJust e -> Just (e ^. 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
+--   found, a parse error results.
 instance FromJSONE (TerrainEntityMaps, RobotMap) Cell where
   parseJSONE = withArrayE "tuple" $ \v -> do
     let tupRaw = V.toList v
@@ -107,20 +107,6 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) Cell where
 
     return $ Cell terr ent robs
 
--- | 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
---   found, a parse error results.
-instance FromJSONE (TerrainEntityMaps, RobotMap) (AugmentedCell Entity) where
-  parseJSONE x = case x of
-    Object v -> objParse v
-    z -> AugmentedCell Nothing <$> parseJSONE z
-   where
-    objParse v =
-      AugmentedCell
-        <$> liftE (v .:? "waypoint")
-        <*> v ..: "cell"
-
 ------------------------------------------------------------
 -- World editor
 ------------------------------------------------------------

src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs

@@ -57,9 +57,9 @@ import Swarm.Game.Scenario (StaticStructureInfo (..))
 import Swarm.Game.Scenario.Topography.Area (Grid (Grid))
 import Swarm.Game.Scenario.Topography.Cell (PCell, cellEntity)
 import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
+import Swarm.Game.Scenario.Topography.Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-import Swarm.Game.Scenario.Topography.Structure.Type
 import Swarm.Game.Universe (Cosmic (..))
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
 import Swarm.Util (binTuples, histogram)

src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs

@@ -26,18 +26,16 @@ import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
   Parentage (Root),
   WaypointName,
  )
+import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Scenario.Topography.Structure (
-  InheritedStructureDefs,
- )
-import Swarm.Game.Scenario.Topography.Structure qualified as Structure
-import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
-import Swarm.Game.Scenario.Topography.Structure.Overlay
-import Swarm.Game.Scenario.Topography.Structure.Type (
   LocatedStructure,
   MergedStructure (MergedStructure),
   NamedStructure,
   PStructure (Structure),
+  paintMap,
  )
+import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Universe
 import Swarm.Game.World.Parse ()
@@ -68,6 +66,8 @@ data PWorldDescription e = WorldDescription
 
 type WorldDescription = PWorldDescription Entity
 
+type InheritedStructureDefs = [NamedStructure (Maybe Cell)]
+
 data WorldParseDependencies
   = WorldParseDependencies
       WorldMap
@@ -85,7 +85,7 @@ integrateArea palette initialStructureDefs v = do
   placementDefs <- v .:? "placements" .!= []
   waypointDefs <- v .:? "waypoints" .!= []
   rawMap <- v .:? "map" .!= ""
-  (initialArea, mapWaypoints) <- Structure.paintMap Nothing palette rawMap
+  (initialArea, mapWaypoints) <- paintMap Nothing palette rawMap
   let unflattenedStructure =
         Structure
           (PositionedGrid origin $ Grid initialArea)
@@ -102,7 +102,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where
     let withDeps = localE (const (tem, rm))
     palette <-
       withDeps $
-        v ..:? "palette" ..!= WorldPalette mempty
+        v ..:? "palette" ..!= StructurePalette mempty
     subworldLocalStructureDefs <-
       withDeps $
         v ..:? "structures" ..!= []

src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs

@@ -6,7 +6,6 @@ module Swarm.Game.Scenario.Topography.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.Maybe (catMaybes)
@@ -15,24 +14,15 @@ import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Tuple (swap)
 import Swarm.Game.Entity
-import Swarm.Game.Land
-import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
+import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Terrain (TerrainType)
 import Swarm.Util.Erasable
-import Swarm.Util.Yaml
 
 -- | A world palette maps characters to 'Cell' values.
-newtype WorldPalette e = WorldPalette
-  {unPalette :: KeyMap (AugmentedCell e)}
-  deriving (Eq, Show)
-
-instance FromJSONE (TerrainEntityMaps, RobotMap) (WorldPalette Entity) where
-  parseJSONE =
-    withObjectE "palette" $
-      fmap WorldPalette . mapM parseJSONE
+type WorldPalette e = StructurePalette (PCell e)
 
 type TerrainWith a = (TerrainType, Erasable a)
 
@@ -111,7 +101,7 @@ prepForJson ::
   PaletteAndMaskChar ->
   Grid (Maybe CellPaintDisplay) ->
   (Text, KM.KeyMap CellPaintDisplay)
-prepForJson (PaletteAndMaskChar (WorldPalette suggestedPalette) maybeMaskChar) cellGrid =
+prepForJson (PaletteAndMaskChar (StructurePalette suggestedPalette) maybeMaskChar) cellGrid =
   (constructWorldMap mappedPairs maskCharacter cellGrid, constructPalette mappedPairs)
  where
   preassignments :: [(Char, TerrainWith EntityFacade)]

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

@@ -15,7 +15,6 @@ import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
 import Data.Tuple.Extra (both)
-import Data.Vector qualified as V
 import Linear (V2 (..))
 import Swarm.Game.Display (defaultChar)
 import Swarm.Game.Entity.Cosmetic
@@ -27,6 +26,7 @@ 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)
+import Swarm.Game.Scenario.Topography.Rasterize
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.State.Landscape
 import Swarm.Game.Universe
@@ -167,11 +167,6 @@ renderScenarioMap opts fp = simpleErrorHandle $ do
   (grid, _) <- getRenderableGrid opts fp
   return $ unGrid $ getDisplayChar <$> grid
 
--- | Converts linked lists to vectors to facilitate
--- random access when assembling the image
-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
   result <- runThrow $ getRenderableGrid opts fp
@@ -185,14 +180,8 @@ renderScenarioPng opts fp = do
      where
       errorMsg :: String
       errorMsg = prettyString err
-    Right (grid, aMap) -> return $ mkImg aMap grid
+    Right (grid, aMap) -> return $ (makeImage . getDisplayColor) aMap grid
   writePng (outputFilepath opts) img
- where
-  mkImg aMap g = generateImage (pixelRenderer vecGrid) (fromIntegral w) (fromIntegral h)
-   where
-    vecGrid = gridToVec g
-    AreaDimensions w h = getGridDimensions g
-    pixelRenderer vg x y = getDisplayColor aMap $ (vg V.! y) V.! x
 
 printScenarioMap :: [String] -> IO ()
 printScenarioMap =

src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Game.Scenario.Topography.ProtoCell (
+  SignpostableCell (..),
+  StructurePalette (..),
+) where
+
+import Control.Applicative ((<|>))
+import Data.Aeson.KeyMap (KeyMap)
+import Data.Yaml as Y
+import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
+import Swarm.Util.Yaml
+
+newtype StructurePalette e = StructurePalette
+  {unPalette :: KeyMap (SignpostableCell e)}
+  deriving (Eq, Show)
+
+instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where
+  parseJSONE =
+    withObjectE "palette" $
+      fmap StructurePalette . mapM parseJSONE
+
+-- | Supplements a cell with waypoint information
+data SignpostableCell c = SignpostableCell
+  { waypointCfg :: Maybe WaypointConfig
+  , standardCell :: c
+  }
+  deriving (Eq, Show)
+
+instance (FromJSONE e a) => FromJSONE e (SignpostableCell a) where
+  parseJSONE x =
+    withObjectE "SignpostableCell" objParse x
+      <|> (SignpostableCell Nothing <$> parseJSONE x)
+   where
+    objParse v = do
+      waypointCfg <- liftE $ v .:? "waypoint"
+      standardCell <- v ..: "cell"
+      pure $ SignpostableCell {..}

src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs

@@ -0,0 +1,22 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Convenience functions for rendering topographical structures
+module Swarm.Game.Scenario.Topography.Rasterize where
+
+import Codec.Picture
+import Data.Vector qualified as V
+import Swarm.Game.Scenario.Topography.Area
+
+-- | Converts linked lists to vectors to facilitate
+-- random access when assembling the image
+gridToVec :: Grid a -> V.Vector (V.Vector a)
+gridToVec (Grid g) = V.fromList . map V.fromList $ g
+
+makeImage :: Pixel px => (a -> px) -> Grid a -> Image px
+makeImage computeColor g =
+  generateImage (pixelRenderer vecGrid) (fromIntegral w) (fromIntegral h)
+ where
+  vecGrid = gridToVec g
+  AreaDimensions w h = getGridDimensions g
+  pixelRenderer vg x y = computeColor $ (vg V.! y) V.! x

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -12,38 +11,82 @@ module Swarm.Game.Scenario.Topography.Structure where
 import Data.Aeson.Key qualified as Key
 import Data.Aeson.KeyMap qualified as KeyMap
 import Data.Maybe (catMaybes)
+import Data.Set (Set)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Yaml as Y
-import Swarm.Game.Land
 import Swarm.Game.Location
-import Swarm.Game.Scenario.RobotLookup (RobotMap)
 import Swarm.Game.Scenario.Topography.Area
-import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
+import Swarm.Game.Scenario.Topography.Placement
+import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Scenario.Topography.Structure.Overlay
-import Swarm.Game.Scenario.Topography.Structure.Type
-import Swarm.Game.Scenario.Topography.WorldPalette
+import Swarm.Language.Syntax.Direction (AbsoluteDir)
 import Swarm.Util (failT, showT)
 import Swarm.Util.Yaml
 import Witch (into)
 
-type InheritedStructureDefs = [NamedStructure (Maybe Cell)]
+data NamedArea a = NamedArea
+  { name :: StructureName
+  , recognize :: Set AbsoluteDir
+  -- ^ whether this structure should be registered for automatic recognition
+  -- and which orientations shall be recognized.
+  -- The supplied direction indicates which cardinal direction the
+  -- original map's "North" has been re-oriented to.
+  -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise.
+  , description :: Maybe Text
+  -- ^ will be UI-facing only if this is a recognizable structure
+  , structure :: a
+  }
+  deriving (Eq, Show, Functor)
 
-instance FromJSONE (TerrainEntityMaps, RobotMap) (NamedArea (PStructure (Maybe Cell))) where
+isRecognizable :: NamedArea a -> Bool
+isRecognizable = not . null . recognize
+
+type NamedGrid c = NamedArea (Grid c)
+
+type NamedStructure c = NamedArea (PStructure c)
+
+data PStructure c = Structure
+  { area :: PositionedGrid c
+  , structures :: [NamedStructure c]
+  -- ^ structure definitions from parents shall be accessible by children
+  , placements :: [Placement]
+  -- ^ earlier placements will be overlaid on top of later placements in the YAML file
+  , waypoints :: [Waypoint]
+  }
+  deriving (Eq, Show)
+
+data Placed c = Placed Placement (NamedStructure c)
+  deriving (Show)
+
+-- | For use in registering recognizable pre-placed structures
+data LocatedStructure = LocatedStructure
+  { placedName :: StructureName
+  , upDirection :: AbsoluteDir
+  , cornerLoc :: Location
+  }
+  deriving (Show)
+
+instance HasLocation LocatedStructure where
+  modifyLoc f (LocatedStructure x y originalLoc) =
+    LocatedStructure x y $ f originalLoc
+
+data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint]
+
+instance (FromJSONE e a) => FromJSONE e (NamedStructure (Maybe a)) where
   parseJSONE = withObjectE "named structure" $ \v -> do
-    NamedArea
-      <$> liftE (v .: "name")
-      <*> liftE (v .:? "recognize" .!= mempty)
-      <*> liftE (v .:? "description")
-      <*> v
-        ..: "structure"
+    structure <- v ..: "structure"
+    liftE $ do
+      name <- v .: "name"
+      recognize <- v .:? "recognize" .!= mempty
+      description <- v .:? "description"
+      return $ NamedArea {..}
 
-instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where
+instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
-    pal <- v ..:? "palette" ..!= WorldPalette mempty
+    pal <- v ..:? "palette" ..!= StructurePalette mempty
     structures <- v ..:? "structures" ..!= []
-
     liftE $ do
       placements <- v .:? "placements" .!= []
       waypointDefs <- v .:? "waypoints" .!= []
@@ -60,9 +103,9 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where
 paintMap ::
   MonadFail m =>
   Maybe Char ->
-  WorldPalette e ->
+  StructurePalette c ->
   Text ->
-  m ([[Maybe (PCell e)]], [Waypoint])
+  m ([[Maybe c]], [Waypoint])
 paintMap maskChar pal a = do
   nestedLists <- readMap toCell a
   let cells = map (map $ fmap standardCell) nestedLists

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs

@@ -25,8 +25,8 @@ import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
+import Swarm.Game.Scenario.Topography.Structure
 import Swarm.Game.Scenario.Topography.Structure.Overlay
-import Swarm.Game.Scenario.Topography.Structure.Type
 import Swarm.Language.Syntax.Direction (directionJsonModifier)
 import Swarm.Util (commaList, quote, showT)
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs

@@ -29,8 +29,8 @@ import Data.Map.NonEmpty (NEMap)
 import Data.Map.NonEmpty qualified as NEM
 import Swarm.Game.Location (Location)
 import Swarm.Game.Scenario.Topography.Placement (StructureName)
+import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure
 import Swarm.Game.Universe (Cosmic)
 import Swarm.Util (binTuples, deleteKeys)
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs

@@ -12,8 +12,8 @@ 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 (..))
-import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure
 import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), getCoordinateOrientation)
 import Swarm.Util (commaList, failT, histogram, showT)
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs

@@ -34,7 +34,7 @@ import Linear (V2 (..))
 import Swarm.Game.Location (Location)
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Placement (StructureName)
-import Swarm.Game.Scenario.Topography.Structure.Type (NamedGrid)
+import Swarm.Game.Scenario.Topography.Structure (NamedGrid)
 import Swarm.Game.Universe (Cosmic, offsetBy)
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
 import Text.AhoCorasick (StateMachine)

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs

@@ -1,63 +0,0 @@
--- |
--- SPDX-License-Identifier: BSD-3-Clause
---
--- Definitions of "structures" for use within a map
--- as well as logic for combining them.
-module Swarm.Game.Scenario.Topography.Structure.Type where
-
-import Data.Set (Set)
-import Data.Text (Text)
-import Swarm.Game.Location
-import Swarm.Game.Scenario.Topography.Area
-import Swarm.Game.Scenario.Topography.Navigation.Waypoint
-import Swarm.Game.Scenario.Topography.Placement
-import Swarm.Game.Scenario.Topography.Structure.Overlay
-import Swarm.Language.Syntax.Direction (AbsoluteDir)
-
-data NamedArea a = NamedArea
-  { name :: StructureName
-  , recognize :: Set AbsoluteDir
-  -- ^ whether this structure should be registered for automatic recognition
-  -- and which orientations shall be recognized.
-  -- The supplied direction indicates which cardinal direction the
-  -- original map's "North" has been re-oriented to.
-  -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise.
-  , description :: Maybe Text
-  -- ^ will be UI-facing only if this is a recognizable structure
-  , structure :: a
-  }
-  deriving (Eq, Show, Functor)
-
-isRecognizable :: NamedArea a -> Bool
-isRecognizable = not . null . recognize
-
-type NamedGrid c = NamedArea (Grid c)
-
-type NamedStructure c = NamedArea (PStructure c)
-
-data PStructure c = Structure
-  { area :: PositionedGrid c
-  , structures :: [NamedStructure c]
-  -- ^ structure definitions from parents shall be accessible by children
-  , placements :: [Placement]
-  -- ^ earlier placements will be overlaid on top of later placements in the YAML file
-  , waypoints :: [Waypoint]
-  }
-  deriving (Eq, Show)
-
-data Placed c = Placed Placement (NamedStructure c)
-  deriving (Show)
-
--- | For use in registering recognizable pre-placed structures
-data LocatedStructure = LocatedStructure
-  { placedName :: StructureName
-  , upDirection :: AbsoluteDir
-  , cornerLoc :: Location
-  }
-  deriving (Show)
-
-instance HasLocation LocatedStructure where
-  modifyLoc f (LocatedStructure x y originalLoc) =
-    LocatedStructure x y $ f originalLoc
-
-data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint]

src/swarm-tui/Swarm/TUI/Editor/Palette.hs

@@ -27,6 +27,7 @@ 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 (..))
+import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName)
@@ -43,7 +44,7 @@ makeSuggestedPalette ::
   KM.KeyMap (AugmentedCell EntityFacade)
 makeSuggestedPalette tm originalScenarioPalette cellGrid =
   KM.fromMapText
-    . M.map (AugmentedCell Nothing)
+    . M.map (SignpostableCell Nothing)
     . M.fromList
     . M.elems
     -- NOTE: the left-most maps take precedence!
@@ -136,7 +137,7 @@ constructScenario maybeOriginalScenario cellGrid =
     WorldDescription
       { offsetOrigin = False
       , scrollable = True
-      , palette = WorldPalette suggestedPalette
+      , palette = StructurePalette suggestedPalette
       , ul = upperLeftCoord
       , area = PositionedGrid upperLeftCoord cellGrid
       , navigation = Navigation mempty mempty

src/swarm-tui/Swarm/TUI/View/Structure.hs

@@ -23,11 +23,11 @@ import Swarm.Game.Entity (Entity, entityDisplay)
 import Swarm.Game.Scenario (Cell)
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Placement
+import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (getEntityGrid)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure
 import Swarm.Game.State
 import Swarm.Game.State.Substate
 import Swarm.Language.Syntax.Direction (directionJsonModifier)

swarm.cabal

@@ -55,6 +55,8 @@ data-files:
   scenarios/**/*.txt
   scenarios/**/*.yaml
   test/language-snippets/**/*.sw
+  test/standalone-topography/*.png
+  test/standalone-topography/*.yaml
   worlds/*.world
 
 source-repository head
@@ -209,6 +211,9 @@ library swarm-topography
     Swarm.Game.Scenario.Topography.Area
     Swarm.Game.Scenario.Topography.Navigation.Waypoint
     Swarm.Game.Scenario.Topography.Placement
+    Swarm.Game.Scenario.Topography.ProtoCell
+    Swarm.Game.Scenario.Topography.Rasterize
+    Swarm.Game.Scenario.Topography.Structure
     Swarm.Game.Scenario.Topography.Structure.Assembly
     Swarm.Game.Scenario.Topography.Structure.Overlay
     Swarm.Game.Scenario.Topography.Structure.Recognition
@@ -216,13 +221,13 @@ library swarm-topography
     Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
     Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry
     Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-    Swarm.Game.Scenario.Topography.Structure.Type
     Swarm.Game.Universe
 
   other-modules: Paths_swarm
   autogen-modules: Paths_swarm
   build-depends:
     AhoCorasick >=0.0.4 && <0.0.5,
+    JuicyPixels >=3.3 && <3.4,
     aeson >=2.2 && <2.3,
     base >=4.14 && <4.20,
     containers >=0.6.2 && <0.8,
@@ -232,6 +237,8 @@ library swarm-topography
     nonempty-containers >=0.3.4 && <0.3.5,
     servant-docs >=0.12 && <0.14,
     text >=1.2.4 && <2.2,
+    vector >=0.12 && <0.14,
+    witch,
     yaml >=0.11 && <0.11.12.0,
 
   build-depends:
@@ -274,7 +281,6 @@ library swarm-scenario
     Swarm.Game.Scenario.Topography.Center
     Swarm.Game.Scenario.Topography.EntityFacade
     Swarm.Game.Scenario.Topography.Navigation.Portal
-    Swarm.Game.Scenario.Topography.Structure
     Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
     Swarm.Game.Scenario.Topography.WorldDescription
     Swarm.Game.Scenario.Topography.WorldPalette
@@ -938,6 +944,34 @@ test-suite tournament-host
   default-language: Haskell2010
   ghc-options: -threaded
 
+test-suite standalone-topography
+  import: stan-config, common, ghc2021-extensions
+  main-is: Main.hs
+  type: exitcode-stdio-1.0
+  other-modules:
+    Lib
+
+  other-modules: Paths_swarm
+  autogen-modules: Paths_swarm
+  build-depends:
+    JuicyPixels >=3.3 && <3.4,
+    MissingH,
+    aeson,
+    base,
+    bytestring,
+    filepath,
+    tasty,
+    tasty-hunit,
+    yaml,
+
+  build-depends:
+    swarm:swarm-topography,
+    swarm:swarm-util,
+
+  hs-source-dirs: test/standalone-topography/src
+  default-language: Haskell2010
+  ghc-options: -threaded
+
 benchmark benchmark
   import: stan-config, common, ghc2021-extensions
   main-is: Benchmark.hs

test/standalone-topography/src/Lib.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Lib (compareToReferenceImage) where
+
+import Codec.Picture
+import Control.Arrow (left)
+import Data.Aeson
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either.Utils (forceEither)
+import Data.Yaml (prettyPrintParseException)
+import GHC.Generics (Generic)
+import Paths_swarm (getDataDir)
+import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
+  Parentage (Root),
+ )
+import Swarm.Game.Scenario.Topography.Rasterize
+import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Game.Scenario.Topography.Structure.Assembly
+import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Util.Yaml
+import System.FilePath
+import Test.Tasty.HUnit (Assertion, assertEqual)
+
+newtype CustomCell = CustomCell Bool
+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
+
+instance FromJSONE e CustomCell
+
+parseStructures :: FilePath -> FilePath -> IO (PStructure (Maybe CustomCell))
+parseStructures dataDir baseFilename = do
+  eitherResult <-
+    decodeFileEitherE () $
+      dataDir </> "test/standalone-topography" </> baseFilename
+  return $ forceEither $ left prettyPrintParseException eitherResult
+
+getDisplayColor :: Maybe CustomCell -> PixelRGBA8
+getDisplayColor = maybe transparent mkPixelColor
+ where
+  mkPixelColor (CustomCell b) = case b of
+    False -> PixelRGBA8 0 0 0 255
+    True -> PixelRGBA8 255 255 255 255
+
+  transparent = PixelRGBA8 0 0 0 0
+
+compareToReferenceImage :: String -> Assertion
+compareToReferenceImage fileStem = do
+  dataDir <- getDataDir
+  parentStruct <- parseStructures dataDir $ fileStem <.> "yaml"
+  let MergedStructure overlayArea _ _ = forceEither $ mergeStructures mempty Root parentStruct
+  let encodedImgBytestring = encodePng $ makeImage getDisplayColor $ gridContent overlayArea
+
+  let referenceFilepath = dataDir </> "test/standalone-topography" </> fileStem <.> "png"
+  if refreshReferenceImage
+    then LBS.writeFile referenceFilepath encodedImgBytestring
+    else do
+      decodedImg <- LBS.readFile referenceFilepath
+      assertEqual "Generated image must equal reference image!" decodedImg encodedImgBytestring
+ where
+  refreshReferenceImage = False

test/standalone-topography/src/Main.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Main where
+
+import Test.Tasty (defaultMain, testGroup)
+import Test.Tasty.HUnit (testCase)
+
+import Lib
+
+main :: IO ()
+main = do
+  defaultMain
+    $ testGroup
+      "Test structure assembly"
+    $ map
+      doTest
+      [ "circle-and-crosses"
+      , "checkerboard"
+      ]
+ where
+  doTest stem = testCase (unwords ["Image equality:", stem]) $ compareToReferenceImage stem