diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index b1f3e898b..ff94592b0 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -14,11 +14,6 @@ -- tutorials and for standalone puzzles and scenarios. module Swarm.Game.Scenario ( -- * WorldDescription - PCell (..), - Cell, - PWorldDescription (..), - WorldDescription, - IndexedTRobot, StructureCells, -- * Scenario diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 782228f47..99d837c93 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -14,30 +14,32 @@ import Data.Coerce import Data.Functor.Identity import Data.Text qualified as T import Data.Yaml as Y -import Swarm.Game.Entity +import Swarm.Game.Entity (Entity) import Swarm.Game.Land import Swarm.Game.Location -import Swarm.Game.Scenario.RobotLookup +import Swarm.Game.Scenario.RobotLookup (RobotMap) import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.Grid (Grid (EmptyGrid)) +import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade) import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( Parentage (Root), WaypointName, ) -import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Scenario.Topography.ProtoCell ( + StructurePalette (StructurePalette), + ) import Swarm.Game.Scenario.Topography.Structure ( LocatedStructure, MergedStructure (MergedStructure), NamedStructure, - PStructure (Structure), - paintMap, + parseStructure, ) import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly -import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Overlay ( + PositionedGrid (..), + ) import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Universe +import Swarm.Game.Universe (SubworldName (DefaultRootSubworld)) import Swarm.Game.World.Parse () import Swarm.Game.World.Syntax import Swarm.Game.World.Typecheck @@ -55,10 +57,11 @@ data PWorldDescription e = WorldDescription { offsetOrigin :: Bool , scrollable :: Bool , palette :: WorldPalette e - , ul :: Location , area :: PositionedGrid (Maybe (PCell e)) , navigation :: Navigation Identity WaypointName , placedStructures :: [LocatedStructure] + -- ^ statically-placed structures to pre-populate + -- the structure recognizer , worldName :: SubworldName , worldProg :: Maybe (TTerm '[] (World CellVal)) } @@ -76,25 +79,6 @@ data WorldParseDependencies -- | last for the benefit of partial application TerrainEntityMaps -integrateArea :: - WorldPalette e -> - [NamedStructure (Maybe (PCell e))] -> - Object -> - Parser (MergedStructure (Maybe (PCell e))) -integrateArea palette initialStructureDefs v = do - placementDefs <- v .:? "placements" .!= [] - waypointDefs <- v .:? "waypoints" .!= [] - rawMap <- v .:? "map" .!= EmptyGrid - (initialArea, mapWaypoints) <- paintMap Nothing palette rawMap - let unflattenedStructure = - Structure - (PositionedGrid origin initialArea) - initialStructureDefs - placementDefs - (waypointDefs <> mapWaypoints) - either (fail . T.unpack) return $ - Assembly.mergeStructures mempty Root unflattenedStructure - instance FromJSONE WorldParseDependencies WorldDescription where parseJSONE = withObjectE "world description" $ \v -> do WorldParseDependencies worldMap scenarioLevelStructureDefs rm tem <- getE @@ -107,32 +91,41 @@ instance FromJSONE WorldParseDependencies WorldDescription where withDeps $ v ..:? "structures" ..!= [] - let structureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs - MergedStructure area staticStructurePlacements unmergedWaypoints <- - liftE $ integrateArea palette structureDefs v - - worldName <- liftE $ v .:? "name" .!= DefaultRootSubworld - ul <- liftE $ v .:? "upperleft" .!= origin - portalDefs <- liftE $ v .:? "portals" .!= [] - navigation <- - validatePartialNavigation - worldName - ul - unmergedWaypoints - portalDefs - - mwexp <- liftE $ v .:? "dsl" - worldProg <- forM mwexp $ \wexp -> do - let checkResult = - run . runThrow @CheckErr . runReader worldMap . runReader tem $ - check CNil (TTyWorld TTyCell) wexp - either (fail . prettyString) return checkResult - - offsetOrigin <- liftE $ v .:? "offset" .!= False - scrollable <- liftE $ v .:? "scrollable" .!= True - let placedStructures = - map (offsetLoc $ coerce ul) staticStructurePlacements - return $ WorldDescription {..} + let initialStructureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs + liftE $ mkWorld tem worldMap palette initialStructureDefs v + where + mkWorld tem worldMap palette initialStructureDefs v = do + MergedStructure mergedGrid staticStructurePlacements unmergedWaypoints <- do + unflattenedStructure <- parseStructure palette initialStructureDefs v + either (fail . T.unpack) return $ + Assembly.mergeStructures mempty Root unflattenedStructure + + worldName <- v .:? "name" .!= DefaultRootSubworld + ul <- v .:? "upperleft" .!= origin + portalDefs <- v .:? "portals" .!= [] + navigation <- + validatePartialNavigation + worldName + ul + unmergedWaypoints + portalDefs + + mwexp <- v .:? "dsl" + worldProg <- forM mwexp $ \wexp -> do + let checkResult = + run . runThrow @CheckErr . runReader worldMap . runReader tem $ + check CNil (TTyWorld TTyCell) wexp + either (fail . prettyString) return checkResult + + offsetOrigin <- v .:? "offset" .!= False + scrollable <- v .:? "scrollable" .!= True + let placedStructures = + map (offsetLoc $ coerce ul) staticStructurePlacements + + -- Override upper-left corner with explicit location + let area = mergedGrid {gridPosition = ul} + + return $ WorldDescription {..} ------------------------------------------------------------ -- World editor @@ -147,7 +140,7 @@ instance ToJSON WorldDescriptionPaint where object [ "offset" .= offsetOrigin w , "palette" .= Y.toJSON paletteKeymap - , "upperleft" .= ul w + , "upperleft" .= gridPosition (area w) , "map" .= Y.toJSON mapText ] where diff --git a/src/swarm-scenario/Swarm/Game/State/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs index b97bd051c..3ab7dad22 100644 --- a/src/swarm-scenario/Swarm/Game/State/Landscape.hs +++ b/src/swarm-scenario/Swarm/Game/State/Landscape.hs @@ -39,10 +39,13 @@ import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Robot (TRobot, trobotLocation) import Swarm.Game.Scenario +import Swarm.Game.Scenario.RobotLookup (IndexedTRobot) import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.State.Config import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName) import Swarm.Game.Universe as U @@ -134,9 +137,6 @@ buildWorld tem WorldDescription {..} = g = gridContent area - ulOffset = origin .-. gridPosition area - ulModified = ul .+^ ulOffset - worldGrid :: Grid (TerrainType, Erasable Entity) worldGrid = maybe (BlankT, ENothing) (cellTerrain &&& cellEntity) <$> g @@ -144,7 +144,7 @@ buildWorld tem WorldDescription {..} = offsetCoordsByArea x a = x `addTuple` swap (asTuple a) - coords = locToCoords ulModified + coords = locToCoords $ gridPosition area arrayMaxBound = both (subtract 1) diff --git a/src/swarm-scenario/Swarm/Game/World/Render.hs b/src/swarm-scenario/Swarm/Game/World/Render.hs index 491e78c5b..4aba2c3da 100644 --- a/src/swarm-scenario/Swarm/Game/World/Render.hs +++ b/src/swarm-scenario/Swarm/Game/World/Render.hs @@ -29,6 +29,7 @@ import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade) import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Rasterize import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.State.Landscape import Swarm.Game.Universe import Swarm.Game.World.Coords @@ -106,7 +107,7 @@ getBoundingBox vc scenarioWorld maybeSize = where upperLeftLocation = if null maybeSize && not (isEmpty mapAreaDims) - then ul scenarioWorld + then gridPosition $ area scenarioWorld else vc .+^ ((`div` 2) <$> V2 (negate w) h) mkBoundingBox areaDimens upperLeftLoc = diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index c59af5c5c..63ffb447a 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs @@ -100,19 +100,26 @@ instance FromJSON (Grid Char) where fail "Grid is not rectangular!" return g +parseStructure :: + StructurePalette c -> + [NamedStructure (Maybe c)] -> + Object -> + Parser (PStructure (Maybe c)) +parseStructure pal structures v = do + placements <- v .:? "placements" .!= [] + waypointDefs <- v .:? "waypoints" .!= [] + maybeMaskChar <- v .:? "mask" + rawGrid <- v .:? "map" .!= EmptyGrid + (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid + let area = PositionedGrid origin maskedArea + waypoints = waypointDefs <> mapWaypoints + return Structure {..} + instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= StructurePalette mempty structures <- v ..:? "structures" ..!= [] - liftE $ do - placements <- v .:? "placements" .!= [] - waypointDefs <- v .:? "waypoints" .!= [] - maybeMaskChar <- v .:? "mask" - rawGrid <- v .:? "map" .!= EmptyGrid - (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid - let area = PositionedGrid origin maskedArea - waypoints = waypointDefs <> mapWaypoints - return Structure {..} + liftE $ parseStructure pal structures v -- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw -- string into a nested list of 'PCell' values by looking up each diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs index b6ee30d08..86444ed5a 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -20,6 +20,7 @@ import Swarm.Util (applyWhen) data PositionedGrid a = PositionedGrid { gridPosition :: Location + -- ^ location of the upper-left cell , gridContent :: Grid a } deriving (Eq) diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs index 3452345a3..d562d6003 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -30,6 +30,7 @@ import Swarm.Game.Scenario.Topography.Grid 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.WorldDescription import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName) import Swarm.Game.Universe @@ -139,7 +140,6 @@ constructScenario maybeOriginalScenario cellGrid = { offsetOrigin = False , scrollable = True , palette = StructurePalette suggestedPalette - , ul = upperLeftCoord , area = PositionedGrid upperLeftCoord cellGrid , navigation = Navigation mempty mempty , placedStructures = mempty diff --git a/src/swarm-tui/Swarm/TUI/Editor/Util.hs b/src/swarm-tui/Swarm/TUI/Editor/Util.hs index 0485303ee..65e991bcb 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Util.hs @@ -35,7 +35,7 @@ getEditingBounds myWorld = (EA.isEmpty a, newBounds) where newBounds = Cosmic DefaultRootSubworld (locToCoords upperLeftLoc, locToCoords lowerRightLoc) - upperLeftLoc = ul myWorld + upperLeftLoc = gridPosition $ area myWorld a = EA.getGridDimensions $ gridContent $ area myWorld lowerRightLoc = EA.computeBottomRightFromUpperLeft a upperLeftLoc