From 1ebe7fa8f55cad6b76c1f17498e6cba159133630 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 15 Jun 2024 11:21:39 -0700 Subject: [PATCH] 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 ``` --- .../standalone-topography/checkerboard.png | Bin 0 -> 138 bytes .../standalone-topography/checkerboard.yaml | 59 +++++++++++++ .../circle-and-crosses.png | Bin 0 -> 158 bytes .../circle-and-crosses.yaml | 66 ++++++++++++++ scripts/normalize/all.sh | 11 +++ scripts/validate/json-schemas.sh | 7 +- .../Structure/Recognition/Tracking.hs | 2 +- src/swarm-engine/Swarm/Game/State.hs | 2 +- src/swarm-scenario/Swarm/Game/Scenario.hs | 3 +- .../Swarm/Game/Scenario/Topography/Cell.hs | 28 ++---- .../Structure/Recognition/Precompute.hs | 2 +- .../Scenario/Topography/WorldDescription.hs | 16 ++-- .../Game/Scenario/Topography/WorldPalette.hs | 16 +--- src/swarm-scenario/Swarm/Game/World/Render.hs | 15 +--- .../Game/Scenario/Topography/ProtoCell.hs | 41 +++++++++ .../Game/Scenario/Topography/Rasterize.hs | 22 +++++ .../Game/Scenario/Topography/Structure.hs | 81 ++++++++++++++---- .../Scenario/Topography/Structure/Assembly.hs | 2 +- .../Structure/Recognition/Registry.hs | 2 +- .../Structure/Recognition/Symmetry.hs | 2 +- .../Topography/Structure/Recognition/Type.hs | 2 +- .../Scenario/Topography/Structure/Type.hs | 63 -------------- src/swarm-tui/Swarm/TUI/Editor/Palette.hs | 5 +- src/swarm-tui/Swarm/TUI/View/Structure.hs | 2 +- swarm.cabal | 38 +++++++- test/standalone-topography/src/Lib.hs | 61 +++++++++++++ test/standalone-topography/src/Main.hs | 23 +++++ 27 files changed, 417 insertions(+), 154 deletions(-) create mode 100644 data/test/standalone-topography/checkerboard.png create mode 100644 data/test/standalone-topography/checkerboard.yaml create mode 100644 data/test/standalone-topography/circle-and-crosses.png create mode 100644 data/test/standalone-topography/circle-and-crosses.yaml create mode 100755 scripts/normalize/all.sh create mode 100644 src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs create mode 100644 src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs rename src/{swarm-scenario => swarm-topography}/Swarm/Game/Scenario/Topography/Structure.hs (51%) delete mode 100644 src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs create mode 100644 test/standalone-topography/src/Lib.hs create mode 100644 test/standalone-topography/src/Main.hs diff --git a/data/test/standalone-topography/checkerboard.png b/data/test/standalone-topography/checkerboard.png new file mode 100644 index 0000000000000000000000000000000000000000..4c91a148ee8e5e9bfd23ec816643378ed6023a03 GIT binary patch literal 138 zcmeAS@N?(olHy`uVBq!ia0vp^3LwnE1|*BCs=ffJKu;IPkcv5PFI#glDDbdc-1~p& z)^C^9CMU71=Gb>2?^@|3neA2o_6S_yd-3msu{Z;BLvQ<52L?GOMhk`;6%pJl4-`cj d5P~KN%{&n-gd_gQu&X%Q~loCIEN=F6RIM literal 0 HcmV?d00001 diff --git a/data/test/standalone-topography/checkerboard.yaml b/data/test/standalone-topography/checkerboard.yaml new file mode 100644 index 00000000..ebb4f670 --- /dev/null +++ b/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: "" diff --git a/data/test/standalone-topography/circle-and-crosses.png b/data/test/standalone-topography/circle-and-crosses.png new file mode 100644 index 0000000000000000000000000000000000000000..2ca5a9857c04e019c92e182608e812128033df70 GIT binary patch literal 158 zcmeAS@N?(olHy`uVBq!ia0vp^5+KaM1|%Pp+x`Gjsh%#5Ar*6y6C7CoPc&HBpt0Ba zGSdzgy@ty!cU}eRNdFQ`xY}?!AW3JjkKkGz1(BR77JTs$!F(GeJwm-XSWjNq*pTMf zlBaMrh+EOydj$`VMEE3D6+A%DeI<;NyzlI^uLIzJ)KbLh* G2~7YL5H^(n literal 0 HcmV?d00001 diff --git a/data/test/standalone-topography/circle-and-crosses.yaml b/data/test/standalone-topography/circle-and-crosses.yaml new file mode 100644 index 00000000..052f4daf --- /dev/null +++ b/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: "" diff --git a/scripts/normalize/all.sh b/scripts/normalize/all.sh new file mode 100755 index 00000000..56321421 --- /dev/null +++ b/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 . diff --git a/scripts/validate/json-schemas.sh b/scripts/validate/json-schemas.sh index 95bf25a1..a85512f5 100755 --- a/scripts/validate/json-schemas.sh +++ b/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 \ No newline at end of file +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 diff --git a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs index 948b3702..b9d2e78a 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs +++ b/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 diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs index 5c1f1ce2..7d286c68 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/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 diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index 4a73c816..c93048b4 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/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" ..!= [] diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs index 4fd1c946..4b0aa421 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs +++ b/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 ------------------------------------------------------------ diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs index e9b2a433..0bcf9211 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ b/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) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 0540ddf5..8adcb0cc 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/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" ..!= [] diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs index 704a445b..cd18deb8 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/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)] diff --git a/src/swarm-scenario/Swarm/Game/World/Render.hs b/src/swarm-scenario/Swarm/Game/World/Render.hs index 8c25147d..8bd415f3 100644 --- a/src/swarm-scenario/Swarm/Game/World/Render.hs +++ b/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 = diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs new file mode 100644 index 00000000..5f472674 --- /dev/null +++ b/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 {..} diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs new file mode 100644 index 00000000..a51ded72 --- /dev/null +++ b/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 diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs similarity index 51% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index 076eb7bf..370c2a0c 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index ab70be3d..a5864848 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/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) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs index 67b26c2d..5d4d3a20 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs +++ b/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) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs index d7eee1e0..758cd733 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs +++ b/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) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs index 99607637..ec69a1ac 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs +++ b/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) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs deleted file mode 100644 index f7a452a7..00000000 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs +++ /dev/null @@ -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] diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs index 194aec86..5ff9347b 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/View/Structure.hs b/src/swarm-tui/Swarm/TUI/View/Structure.hs index 26c79e39..095645fa 100644 --- a/src/swarm-tui/Swarm/TUI/View/Structure.hs +++ b/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) diff --git a/swarm.cabal b/swarm.cabal index 4e3897d8..4954a142 100644 --- a/swarm.cabal +++ b/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 diff --git a/test/standalone-topography/src/Lib.hs b/test/standalone-topography/src/Lib.hs new file mode 100644 index 00000000..0004a3ab --- /dev/null +++ b/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 diff --git a/test/standalone-topography/src/Main.hs b/test/standalone-topography/src/Main.hs new file mode 100644 index 00000000..ae6a1e3b --- /dev/null +++ b/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