From a7a9099568928b4668a875f833359b5ad81c37a9 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 1 Jul 2023 23:59:24 -0700 Subject: [PATCH] Add subworlds --- data/scenarios/Testing/00-ORDER.txt | 1 + .../Testing/144-subworlds/00-ORDER.txt | 2 + .../Testing/144-subworlds/basic-subworld.yaml | 107 ++++++++++ .../subworld-shared-structures.yaml | 192 ++++++++++++++++++ src/Swarm/Doc/Gen.hs | 9 +- src/Swarm/Game/Log.hs | 6 +- src/Swarm/Game/Robot.hs | 13 +- src/Swarm/Game/Scenario.hs | 46 ++++- .../Scenario/Topography/Navigation/Portal.hs | 156 ++++++++++---- .../Game/Scenario/Topography/Structure.hs | 12 +- .../Scenario/Topography/WorldDescription.hs | 41 +++- src/Swarm/Game/State.hs | 172 +++++++++++----- src/Swarm/Game/Step.hs | 181 ++++++++++------- src/Swarm/Game/Universe.hs | 69 +++++++ src/Swarm/Game/World.hs | 57 +++++- src/Swarm/Language/Syntax.hs | 3 +- src/Swarm/TUI/Controller.hs | 6 +- src/Swarm/TUI/Controller/Util.hs | 11 +- src/Swarm/TUI/Editor/Controller.hs | 11 +- src/Swarm/TUI/Editor/Masking.hs | 3 +- src/Swarm/TUI/Editor/Model.hs | 5 +- src/Swarm/TUI/Editor/Palette.hs | 4 +- src/Swarm/TUI/Editor/Util.hs | 30 +-- src/Swarm/TUI/Editor/View.hs | 3 +- src/Swarm/TUI/Model.hs | 3 +- src/Swarm/TUI/Model/Name.hs | 2 + src/Swarm/TUI/Model/StateUpdate.hs | 6 +- src/Swarm/TUI/Model/UI.hs | 5 +- src/Swarm/TUI/View.hs | 55 +++-- src/Swarm/TUI/View/CellDisplay.hs | 41 ++-- swarm.cabal | 1 + test/integration/Main.hs | 1 + 32 files changed, 980 insertions(+), 274 deletions(-) create mode 100644 data/scenarios/Testing/144-subworlds/00-ORDER.txt create mode 100644 data/scenarios/Testing/144-subworlds/basic-subworld.yaml create mode 100644 data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml create mode 100644 src/Swarm/Game/Universe.hs diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 4794967930..4f33ad1007 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -38,3 +38,4 @@ 1295-density-command.yaml 1138-structures 1356-portals +144-subworlds diff --git a/data/scenarios/Testing/144-subworlds/00-ORDER.txt b/data/scenarios/Testing/144-subworlds/00-ORDER.txt new file mode 100644 index 0000000000..a1e4ebe99c --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/00-ORDER.txt @@ -0,0 +1,2 @@ +basic-subworld.yaml +subworld-shared-structures.yaml diff --git a/data/scenarios/Testing/144-subworlds/basic-subworld.yaml b/data/scenarios/Testing/144-subworlds/basic-subworld.yaml new file mode 100644 index 0000000000..18b6e27dd7 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/basic-subworld.yaml @@ -0,0 +1,107 @@ +version: 1 +name: Subworlds demo +description: | + Surface and underground with portals. +objectives: + - goal: + - | + `place` the "flower" on the white cell. + condition: | + j <- robotnamed "judge"; + as j {ishere "flower"} +solution: | + run "scenarios/Testing/144-subworlds/_basic-subworld/solution.sw" +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: [1, 0] + system: true + display: + char: 'J' + invisible: true +known: [flower, boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + upperleft: [-1, 1] + map: | + b..b..b..b + .p..f...P. + b..b..b..b +world: + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 't': [ice, null, judge] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + map: | + .......... + .p.Bt...P. + .......... diff --git a/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml b/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml new file mode 100644 index 0000000000..69e2438e80 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml @@ -0,0 +1,192 @@ +version: 1 +name: Subworld shared structures +description: | + Traverse floors of the tower +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + loc: [0, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads +known: [flower] +structures: + - name: minibox + structure: + palette: + '.': [stone] + 'd': [dirt] + 'f': [stone, flower] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in + map: | + p.... + .ddd. + .d.d. + .ddd. + ....P + - name: flowers + structure: + mask: '.' + palette: + 'f': [stone, flower] + map: | + f.f + .f. + f.f +subworlds: + - name: floor1 + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in + placements: + - src: flowers + offset: [1, 1] + - src: minibox + offset: [0, 0] + orient: + up: west + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: floor2 + upperleft: [0, 0] + map: | + ..... + ..... + ..... + ..... + ..... + - name: floor2 + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in + placements: + - src: flowers + offset: [1, 0] + - src: minibox + offset: [0, 0] + orient: + up: south + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: floor3 + upperleft: [0, 0] + map: | + ..... + ..... + ..... + ..... + ..... + - name: floor3 + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in + placements: + - src: flowers + offset: [1, -2] + - src: minibox + offset: [0, 0] + orient: + up: east + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: root + upperleft: [0, 0] + map: | + ..... + ..... + ..... + ..... + ..... +world: + default: [blank] + palette: + '.': [grass] + upperleft: [0, 0] + placements: + - src: flowers + offset: [0, -2] + - src: minibox + offset: [0, 0] + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: floor1 + map: | + ..... + ..... + ..... + ..... + ..... diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs index f8ca2986c3..ebc2f1fbab 100644 --- a/src/Swarm/Doc/Gen.hs +++ b/src/Swarm/Doc/Gen.hs @@ -52,7 +52,7 @@ import Swarm.Game.Failure qualified as F import Swarm.Game.Failure.Render qualified as F import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight) import Swarm.Game.ResourceLoading (getDataFileNameSafe) -import Swarm.Game.Robot (equippedDevices, instantiateRobot, robotInventory) +import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory) import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots) import Swarm.Game.WorldGen (testWorld2Entites) import Swarm.Language.Capability (Capability) @@ -551,11 +551,14 @@ classicScenario = do entities <- loadEntities >>= guardRight "load entities" fst <$> loadScenario "data/scenarios/classic.yaml" entities +startingHelper :: Scenario -> Robot +startingHelper = instantiateRobot 0 . head . view scenarioRobots + startingDevices :: Scenario -> Set Entity -startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . instantiateRobot 0 . head . view scenarioRobots +startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . startingHelper startingInventory :: Scenario -> Map Entity Int -startingInventory = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot 0 . head . view scenarioRobots +startingInventory = Map.fromList . map swap . E.elems . view robotInventory . startingHelper -- | Ignore utility entities that are just used for tutorials and challenges. ignoredEntities :: Set Text diff --git a/src/Swarm/Game/Log.hs b/src/Swarm/Game/Log.hs index ec2dd56eeb..fb80189f7c 100644 --- a/src/Swarm/Game/Log.hs +++ b/src/Swarm/Game/Log.hs @@ -34,6 +34,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Swarm.Game.CESK (TickNumber) import Swarm.Game.Location (Location) +import Swarm.Game.Universe (Cosmo) -- | Severity of the error - critical errors are bugs -- and should be reported as Issues. @@ -61,8 +62,11 @@ data LogEntry = LogEntry -- ^ The name of the robot that generated the entry. , _leRobotID :: Int -- ^ The ID of the robot that generated the entry. - , _leLocation :: Location + , _leLocation :: Maybe (Cosmo Location) -- ^ Location of the robot at log entry creation. + -- "Nothing" represents omnipresence for the purpose of proximity. + -- TODO: Define a type isomorphic to Maybe that makes this explict. + -- C.f. "cosmoMeasure" which will have its own type that means the opposite. , _leText :: Text -- ^ The text of the log entry. } diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index 01c0664de9..a30fa1d18b 100644 --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -95,6 +95,7 @@ import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisib import Swarm.Game.Entity hiding (empty) import Swarm.Game.Location (Heading, Location, toDirection) import Swarm.Game.Log +import Swarm.Game.Universe import Swarm.Language.Capability (Capability) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Requirement (ReqCtx) @@ -167,8 +168,8 @@ data RobotPhase -- | With a robot template, we may or may not have a location. With a -- concrete robot we must have a location. type family RobotLocation (phase :: RobotPhase) :: Data.Kind.Type where - RobotLocation 'TemplateRobot = Maybe Location - RobotLocation 'ConcreteRobot = Location + RobotLocation 'TemplateRobot = Maybe (Cosmo Location) + RobotLocation 'ConcreteRobot = Cosmo Location -- | Robot templates have no ID; concrete robots definitely do. type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where @@ -270,19 +271,19 @@ robotDisplay = lens getDisplay setDisplay -- a getter, since when changing a robot's location we must remember -- to update the 'robotsByLocation' map as well. You can use the -- 'updateRobotLocation' function for this purpose. -robotLocation :: Getter Robot Location +robotLocation :: Getter Robot (Cosmo Location) -- | Set a robot's location. This is unsafe and should never be -- called directly except by the 'updateRobotLocation' function. -- The reason is that we need to make sure the 'robotsByLocation' -- map stays in sync. -unsafeSetRobotLocation :: Location -> Robot -> Robot +unsafeSetRobotLocation :: Cosmo Location -> Robot -> Robot unsafeSetRobotLocation loc r = r {_robotLocation = loc} -- | A template robot's location. Unlike 'robotLocation', this is a -- lens, since when dealing with robot templates there is as yet no -- 'robotsByLocation' map to keep up-to-date. -trobotLocation :: Lens' TRobot (Maybe Location) +trobotLocation :: Lens' TRobot (Maybe (Cosmo Location)) trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l}) -- | Which way the robot is currently facing. @@ -313,7 +314,7 @@ instantiateRobot :: RID -> TRobot -> Robot instantiateRobot i r = r { _robotID = i - , _robotLocation = fromMaybe zero (_robotLocation r) + , _robotLocation = fromMaybe defaultCosmoLocation $ _robotLocation r } -- | The ID number of the robot's parent, that is, the robot that diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 67e442f7ee..607da4a09a 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -33,7 +33,8 @@ module Swarm.Game.Scenario ( scenarioEntities, scenarioRecipes, scenarioKnown, - scenarioWorld, + scenarioWorlds, + scenarioNavigation, scenarioRobots, scenarioObjectives, scenarioSolution, @@ -45,6 +46,7 @@ module Swarm.Game.Scenario ( getScenarioPath, ) where +import Control.Arrow ((&&&)) import Control.Lens hiding (from, (.=), (<.>)) import Control.Monad (filterM) import Control.Monad.Except (ExceptT (..), runExceptT, withExceptT) @@ -52,12 +54,16 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (except) import Data.Aeson import Data.Either.Extra (eitherToMaybe, maybeToEither) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M import Data.Maybe (catMaybes, isNothing, listToMaybe) import Data.Text (Text) import Data.Text qualified as T import Swarm.Game.Entity import Swarm.Game.Failure import Swarm.Game.Failure.Render +import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Robot (TRobot) @@ -66,7 +72,10 @@ import Swarm.Game.Scenario.Objective.Validation import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Style import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Navigation.Portal +import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldDescription +import Swarm.Game.Universe import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Util (failT) import Swarm.Util.Lens (makeLensesNoSigs) @@ -92,7 +101,8 @@ data Scenario = Scenario , _scenarioEntities :: EntityMap , _scenarioRecipes :: [Recipe Entity] , _scenarioKnown :: [Text] - , _scenarioWorld :: WorldDescription + , _scenarioWorlds :: NonEmpty WorldDescription + , _scenarioNavigation :: Navigation (M.Map SubworldName) Location , _scenarioRobots :: [TRobot] , _scenarioObjectives :: [Objective] , _scenarioSolution :: Maybe ProcessedTerm @@ -123,6 +133,28 @@ instance FromJSONE EntityMap Scenario where rs <- v ..: "robots" let rsMap = buildRobotMap rs + rootLevelSharedStructures <- localE (,rsMap) $ v ..:? "structures" ..!= [] + -- fail $ show rootLevelSharedStructures + + allWorlds <- localE (\x -> (rootLevelSharedStructures :: Structure.InheritedStructureDefs, (x, rsMap))) $ do + rootWorld <- v ..: "world" + subworlds <- v ..:? "subworlds" ..!= [] + return $ rootWorld :| subworlds + + let mergedWaypoints = + M.fromList $ + map (worldName &&& runIdentity . waypoints . navigation) $ + NE.toList allWorlds + + mergedPortals <- + validatePortals + . Navigation mergedWaypoints + . M.unions + $ map (portals . navigation) + $ NE.toList allWorlds + + let mergedNavigation = Navigation mergedWaypoints mergedPortals + Scenario <$> liftE (v .: "version") <*> liftE (v .: "name") @@ -134,7 +166,8 @@ instance FromJSONE EntityMap Scenario where <*> pure em <*> v ..:? "recipes" ..!= [] <*> pure known - <*> localE (,rsMap) (v ..: "world") + <*> pure allWorlds + <*> pure mergedNavigation <*> pure rs <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives) <*> liftE (v .:? "solution") @@ -179,8 +212,11 @@ scenarioRecipes :: Lens' Scenario [Recipe Entity] -- not have to scan them. scenarioKnown :: Lens' Scenario [Text] --- | The starting world for the scenario. -scenarioWorld :: Lens' Scenario WorldDescription +-- | The subworlds of the scenario. +scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription) + +-- | Waypoints and inter-world portals +scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location) -- | The starting robots for the scenario. Note this should -- include the base. diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs index 5a012e2c19..9f81225233 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -6,33 +7,39 @@ module Swarm.Game.Scenario.Topography.Navigation.Portal where import Control.Monad (forM, forM_, unless) import Data.Aeson (FromJSON) +import Data.Bifunctor (first) +import Data.Functor.Identity import Data.Int (Int32) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (listToMaybe) -import Data.Text (Text) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Text qualified as T import GHC.Generics (Generic) import Linear (V2) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Navigation.Waypoint +import Swarm.Game.Universe import Swarm.Util (binTuples, quote) --- | Note: The primary overworld shall use --- the reserved name \"root\". -newtype SubworldName = SubworldName Text - deriving (Show, Eq, Ord, Generic, FromJSON) +type WaypointMap = M.Map WaypointName (NonEmpty Location) -data Navigation = Navigation - { waypoints :: M.Map WaypointName (NonEmpty Location) +-- | Parameterized on the portal specification method. +-- At the subworld parsing level, we only can obtain the planar location +-- for portal /entrances/. At the Scenario-parsing level, we finally have +-- access to the waypoints across all subworlds, and can therefore translate +-- the portal exits to concrete planar locations. +data Navigation a b = Navigation + { waypoints :: a WaypointMap -- ^ Note that waypoints defined at the "root" level are still relative to -- the top-left corner of the map rectangle; they are not in absolute world -- coordinates (as with applying the "ul" offset). - , portals :: M.Map Location Location + , portals :: M.Map (Cosmo Location) (Cosmo b) } - deriving (Eq, Show) + +deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) +deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b) data PortalExit = PortalExit { exit :: WaypointName @@ -44,6 +51,7 @@ data PortalExit = PortalExit data Portal = Portal { entrance :: WaypointName , exitInfo :: PortalExit + , consistent :: Maybe Bool } deriving (Show, Eq, Generic, FromJSON) @@ -64,31 +72,59 @@ failUponDuplication message binnedMap = where duplicated = M.filter ((> 1) . NE.length) binnedMap --- | Enforces the following constraints: --- * portals can have multiple entrances but only a single exit +failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a +failWaypointLookup (WaypointName rawName) lookupResult = case lookupResult of + Nothing -> + fail $ + T.unpack $ + T.unwords + [ "No waypoint named" + , quote rawName + ] + Just xs -> return xs + +-- | +-- The following constraints must be enforced: +-- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit -- * no two portals share the same entrance location --- * global waypoint uniqueness when the "unique" flag is specified -validateNavigation :: +-- * waypoint uniqueness within a subworld when the "unique" flag is specified +-- +-- == Data flow: +-- +-- Waypoints are defined within a subworld and are namespaced by it. +-- Optional intra-subworld uniqueness of Waypoints is enforced at WorldDescription +-- parse time. +-- Portals are declared within a subworld. The portal entrance must be a waypoint +-- within this subworld. +-- They can reference waypoints in other subworlds as exits, but these references +-- are not validated until the Scenario parse level. +-- +-- * Since portal /entrances/ are specified at the subworld level, validation that +-- no entrances overlap can also be performed at that level. +-- * However, enforcement of single-multiplicity on portal /exits/ must be performed +-- at scenario-parse level, because for a portal exit that references a waypoint in +-- another subworld, we can't know at the single-WorldDescription level whether +-- that waypoint has plural multiplicity. +validatePartialNavigation :: (MonadFail m, Traversable t) => + SubworldName -> V2 Int32 -> [Originated Waypoint] -> t Portal -> - m Navigation -validateNavigation upperLeft unmergedWaypoints portalDefs = do + m (Navigation Identity WaypointName) +validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag - -- TODO(#144) Currently ignores subworld references - nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName@(WaypointName rawExitName) _)) -> do + nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName maybeExitSubworldName) _) -> do -- Portals can have multiple entrances but only a single exit. -- That is, the pairings of entries to exits must form a proper mathematical "function". - -- Multiple occurrences of entrance waypoints of a given name will replicate portal entrances. + -- Multiple occurrences of entrance waypoints of a given name will result in + -- multiple portal entrances. entranceLocs <- getLocs entranceName - firstExitLoc :| otherExits <- getLocs exitName - unless (null otherExits) - . fail - . T.unpack - $ T.unwords ["Ambiguous exit waypoints named", quote rawExitName, "for portal"] - return $ map ((,extractLoc firstExitLoc) . extractLoc) $ NE.toList entranceLocs + + let sw = fromMaybe currentSubworldName maybeExitSubworldName + f = (,Cosmo sw exitName) . extractLoc + return $ map f $ NE.toList entranceLocs let reconciledPortalPairs = concat nestedPortalPairs @@ -97,17 +133,10 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do failUponDuplication "has overlapping portal entrances exiting to" $ binTuples reconciledPortalPairs - return $ Navigation bareWaypoints $ M.fromList reconciledPortalPairs + return . Navigation (pure bareWaypoints) . M.fromList $ + map (first $ Cosmo currentSubworldName) reconciledPortalPairs where - getLocs wpWrapper@(WaypointName rawName) = case M.lookup wpWrapper correctedWaypoints of - Nothing -> - fail $ - T.unpack $ - T.unwords - [ "No waypoint named" - , quote rawName - ] - Just xs -> return xs + getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints extractLoc (Originated _ (Waypoint _ loc)) = loc correctedWaypoints = @@ -116,5 +145,60 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint upperLeft) x)) unmergedWaypoints bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints - waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints + +validatePortals :: + MonadFail m => + Navigation (M.Map SubworldName) WaypointName -> + m (M.Map (Cosmo Location) (Cosmo Location)) +validatePortals (Navigation wpUniverse partialPortals) = do + portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, portalExit@(Cosmo swName (WaypointName rawExitName))) -> do + firstExitLoc :| otherExits <- getLocs portalExit + unless (null otherExits) + . fail + . T.unpack + $ T.unwords + [ "Ambiguous exit waypoints named" + , quote rawExitName + , "for portal" + ] + return (portalEntrance, Cosmo swName firstExitLoc) + + return $ M.fromList portalPairs + where + getLocs (Cosmo swName@(SubworldName rawSwName) wpWrapper@(WaypointName exitName)) = do + subworldWaypoints <- case M.lookup swName wpUniverse of + Just x -> return x + Nothing -> + fail $ + T.unpack $ + T.unwords + [ "Could not lookup waypoint" + , quote exitName + , "for portal exit because subworld" + , quote rawSwName + , "does not exist" + ] + + failWaypointLookup wpWrapper $ + M.lookup wpWrapper subworldWaypoints + +-- | A portal can be marked as \"consistent\", meaning that it represents +-- a conventional physical passage rather than a "magical" teleportation. +-- +-- If there exists more than one \"consistent\" portal between the same +-- two subworlds, then the portal locations must be spatially consistent +-- between the two worlds. I.e. the space comprising the two subworlds +-- forms a "conservative vector field". +-- +-- Verifying this is simple: +-- For all of the portals between Subworlds A and B: +-- * The coordinates of all \"consistent\" portal locations in Subworld A +-- are subtracted from the corresponding coordinates in Subworld B. It +-- does not matter which are exits vs. entrances. +-- * The resulting "vector" from every pair must be equal. +ensureSpatialConsistency :: + MonadFail m => + -- Navigation (M.Map SubworldName) WaypointName -> + m () +ensureSpatialConsistency = return () -- TODO diff --git a/src/Swarm/Game/Scenario/Topography/Structure.hs b/src/Swarm/Game/Scenario/Topography/Structure.hs index da2bac566a..0351b4d195 100644 --- a/src/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/Swarm/Game/Scenario/Topography/Structure.hs @@ -31,11 +31,13 @@ data NamedStructure c = NamedStructure } deriving (Eq, Show) +type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))] + instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where parseJSONE = withObjectE "named structure" $ \v -> do - sName <- liftE $ v .: "name" - NamedStructure sName - <$> v + NamedStructure + <$> liftE (v .: "name") + <*> v ..: "structure" data PStructure c = Structure @@ -111,12 +113,12 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= WorldPalette mempty - structureDefs <- v ..:? "structures" ..!= [] + localStructureDefs <- v ..:? "structures" ..!= [] placementDefs <- liftE $ v .:? "placements" .!= [] waypointDefs <- liftE $ v .:? "waypoints" .!= [] maybeMaskChar <- liftE $ v .:? "mask" (maskedArea, mapWaypoints) <- liftE $ (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal - return $ Structure maskedArea structureDefs placementDefs $ waypointDefs <> mapWaypoints + return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints -- | "Paint" a world map using a 'WorldPalette', turning it from a raw -- string into a nested list of 'Cell' values by looking up each diff --git a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs index a2a24efdcb..5603e7f9ec 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -6,6 +6,7 @@ module Swarm.Game.Scenario.Topography.WorldDescription where import Data.Coerce +import Data.Functor.Identity import Data.Maybe (catMaybes) import Data.Yaml as Y import Swarm.Game.Entity @@ -14,8 +15,13 @@ import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Portal +import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( + WaypointName, + ) +import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure)) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldPalette +import Swarm.Game.Universe import Swarm.Util.Yaml ------------------------------------------------------------ @@ -32,36 +38,49 @@ data PWorldDescription e = WorldDescription , palette :: WorldPalette e , ul :: Location , area :: [[PCell e]] - , navigation :: Navigation + , navigation :: Navigation Identity WaypointName + , worldName :: SubworldName } deriving (Eq, Show) type WorldDescription = PWorldDescription Entity -instance FromJSONE (EntityMap, RobotMap) WorldDescription where +instance FromJSONE (InheritedStructureDefs, (EntityMap, RobotMap)) WorldDescription where parseJSONE = withObjectE "world description" $ \v -> do - pal <- v ..:? "palette" ..!= WorldPalette mempty - structureDefs <- v ..:? "structures" ..!= [] + (scnenarioLevelStructureDefs, (em, rm)) <- getE + (pal, terr, rootWorldStructureDefs) <- localE (const (em, rm)) $ do + pal <- v ..:? "palette" ..!= WorldPalette mempty + terr <- v ..:? "default" + rootWorldStructs <- v ..:? "structures" ..!= [] + return (pal, terr, rootWorldStructs) + waypointDefs <- liftE $ v .:? "waypoints" .!= [] portalDefs <- liftE $ v .:? "portals" .!= [] placementDefs <- liftE $ v .:? "placements" .!= [] (initialArea, mapWaypoints) <- liftE ((v .:? "map" .!= "") >>= Structure.paintMap Nothing pal) upperLeft <- liftE (v .:? "upperleft" .!= origin) + subWorldName <- liftE (v .:? "name" .!= defaultRootSubworldName) - let struc = Structure.Structure initialArea structureDefs placementDefs $ waypointDefs <> mapWaypoints - Structure.MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc + let initialStructureDefs = scnenarioLevelStructureDefs <> rootWorldStructureDefs + struc = Structure initialArea initialStructureDefs placementDefs $ waypointDefs <> mapWaypoints + MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc - validatedLandmarks <- validateNavigation (coerce upperLeft) unmergedWaypoints portalDefs + validatedNavigation <- + validatePartialNavigation + subWorldName + (coerce upperLeft) + unmergedWaypoints + portalDefs - WorldDescription - <$> v ..:? "default" - <*> liftE (v .:? "offset" .!= False) + WorldDescription terr + <$> liftE (v .:? "offset" .!= False) <*> liftE (v .:? "scrollable" .!= True) <*> pure pal <*> pure upperLeft <*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells. - <*> pure validatedLandmarks + <*> pure validatedNavigation + <*> pure subWorldName ------------------------------------------------------------ -- World editor diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 63650e030d..afadac2762 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -61,7 +61,7 @@ module Swarm.Game.State ( currentScenarioPath, knownEntities, worldNavigation, - world, + multiWorld, worldScrollable, viewCenterRule, viewCenter, @@ -107,6 +107,7 @@ module Swarm.Game.State ( focusedRange, clearFocusedRobotLogUpdated, addRobot, + addRobotToLocation, addTRobot, emitMessage, wakeWatchingRobots, @@ -114,6 +115,7 @@ module Swarm.Game.State ( sleepForever, wakeUpRobotsDoneSleeping, deleteRobot, + removeRobotFromLocationMap, activateRobot, toggleRunStatus, messageIsRecent, @@ -174,6 +176,7 @@ import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.ScenarioInfo import Swarm.Game.Terrain (TerrainType (..)) +import Swarm.Game.Universe as U import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray) import Swarm.Game.World qualified as W import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray) @@ -185,7 +188,7 @@ import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst) import Swarm.Language.Typed (Typed (Typed)) import Swarm.Language.Types import Swarm.Language.Value (Value) -import Swarm.Util (uniq, (<+=), (<<.=), (?)) +import Swarm.Util (binTuples, uniq, (<+=), (<<.=), (?)) import Swarm.Util.Lens (makeLensesExcluding) import System.Clock qualified as Clock import System.Random (StdGen, mkStdGen, randomRIO) @@ -198,7 +201,7 @@ import System.Random (StdGen, mkStdGen, randomRIO) -- world viewport. data ViewCenterRule = -- | The view should be centered on an absolute position. - VCLocation Location + VCLocation (Cosmo Location) | -- | The view should be centered on a certain robot. VCRobot RID deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) @@ -381,11 +384,11 @@ data GameState = GameState -- Waiting robots for a given time are a list because it is cheaper to -- prepend to a list than insert into a Set. _waitingRobots :: Map TickNumber [RID] - , _robotsByLocation :: Map Location IntSet + , _robotsByLocation :: Map SubworldName (Map Location IntSet) , -- This member exists as an optimization so -- that we do not have to iterate over all "waiting" robots, -- since there may be many. - _robotsWatching :: Map Location (S.Set RID) + _robotsWatching :: Map (Cosmo Location) (S.Set RID) , _allDiscoveredEntities :: Inventory , _availableRecipes :: Notifications (Recipe Entity) , _availableCommands :: Notifications Const @@ -401,11 +404,11 @@ data GameState = GameState , _recipesReq :: IntMap [Recipe Entity] , _currentScenarioPath :: Maybe FilePath , _knownEntities :: [Text] - , _worldNavigation :: Navigation - , _world :: W.World Int Entity + , _worldNavigation :: Navigation (M.Map SubworldName) Location + , _multiWorld :: W.MultiWorld Int Entity , _worldScrollable :: Bool , _viewCenterRule :: ViewCenterRule - , _viewCenter :: Location + , _viewCenter :: Cosmo Location , _needsRedraw :: Bool , _replStatus :: REPLStatus , _replNextValueIndex :: Integer @@ -473,28 +476,32 @@ robotMap :: Lens' GameState (IntMap Robot) -- location of a robot changes, or a robot is created or destroyed. -- Fortunately, there are relatively few ways for these things to -- happen. -robotsByLocation :: Lens' GameState (Map Location IntSet) +robotsByLocation :: Lens' GameState (Map SubworldName (Map Location IntSet)) -- | Get a list of all the robots at a particular location. -robotsAtLocation :: Location -> GameState -> [Robot] +robotsAtLocation :: Cosmo Location -> GameState -> [Robot] robotsAtLocation loc gs = mapMaybe (`IM.lookup` (gs ^. robotMap)) . maybe [] IS.toList - . M.lookup loc + . M.lookup (loc ^. planar) + . M.findWithDefault mempty (loc ^. subworld) . view robotsByLocation $ gs -- | Get a list of all the robots that are "watching" by location. -robotsWatching :: Lens' GameState (Map Location (S.Set RID)) +robotsWatching :: Lens' GameState (Map (Cosmo Location) (S.Set RID)) -- | Get all the robots within a given Manhattan distance from a -- location. -robotsInArea :: Location -> Int32 -> GameState -> [Robot] -robotsInArea o d gs = map (rm IM.!) rids +robotsInArea :: Cosmo Location -> Int32 -> GameState -> [Robot] +robotsInArea (Cosmo subworldName o) d gs = map (rm IM.!) rids where rm = gs ^. robotMap rl = gs ^. robotsByLocation - rids = concatMap IS.elems $ getElemsInArea o d rl + rids = + concatMap IS.elems $ + getElemsInArea o d $ + M.findWithDefault mempty subworldName rl -- | The base robot, if it exists. baseRobot :: Traversal' GameState Robot @@ -559,28 +566,28 @@ recipesReq :: Lens' GameState (IntMap [Recipe Entity]) -- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'. currentScenarioPath :: Lens' GameState (Maybe FilePath) --- | The names of entities that should be considered "known", that is, +-- | The names of entities that should be considered \"known\", that is, -- robots know what they are without having to scan them. knownEntities :: Lens' GameState [Text] --- | Includes a Map of named locations and an +-- | Includes a "Map" of named locations and an -- "Edge list" (graph) that maps portal entrances to exits -worldNavigation :: Lens' GameState Navigation +worldNavigation :: Lens' GameState (Navigation (M.Map SubworldName) Location) -- | The current state of the world (terrain and entities only; robots --- are stored in the 'robotMap'). Int is used instead of --- TerrainType because we need to be able to store terrain values in +-- are stored in the "robotMap"). "Int" is used instead of +-- "TerrainType" because we need to be able to store terrain values in -- unboxed tile arrays. -world :: Lens' GameState (W.World Int Entity) +multiWorld :: Lens' GameState (W.MultiWorld Int Entity) -- | Whether the world map is supposed to be scrollable or not. worldScrollable :: Lens' GameState Bool -- | The current center of the world view. Note that this cannot be -- modified directly, since it is calculated automatically from the --- 'viewCenterRule'. To modify the view center, either set the --- 'viewCenterRule', or use 'modifyViewCenter'. -viewCenter :: Getter GameState Location +-- "viewCenterRule". To modify the view center, either set the +-- "viewCenterRule", or use "modifyViewCenter". +viewCenter :: Getter GameState (Cosmo Location) viewCenter = to _viewCenter -- | Whether the world view needs to be redrawn. @@ -638,14 +645,14 @@ viewCenterRule = lens getter setter setter :: GameState -> ViewCenterRule -> GameState setter g rule = case rule of - VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2} + VCLocation loc -> g {_viewCenterRule = rule, _viewCenter = loc} VCRobot rid -> let robotcenter = g ^? robotMap . ix rid . robotLocation in -- retrieve the loc of the robot if it exists, Nothing otherwise. -- sometimes, lenses are amazing... case robotcenter of Nothing -> g - Just v2 -> g {_viewCenterRule = rule, _viewCenter = v2, _focusedRobotID = rid} + Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid} -- | Whether the repl is currently working. replWorking :: Getter GameState Bool @@ -686,14 +693,17 @@ messageNotifications = to getNotif messageIsRecent :: GameState -> LogEntry -> Bool messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. ticks -messageIsFromNearby :: Location -> LogEntry -> Bool -messageIsFromNearby l e = manhattan l (e ^. leLocation) <= hearingDistance +-- | If the log location is "Nothing", consider it omnipresent. +messageIsFromNearby :: Cosmo Location -> LogEntry -> Bool +messageIsFromNearby l e = maybe True f (e ^. leLocation) + where + f logLoc = maybe False (<= hearingDistance) $ cosmoMeasure manhattan l logLoc -- | Given a current mapping from robot names to robots, apply a -- 'ViewCenterRule' to derive the location it refers to. The result -- is @Maybe@ because the rule may refer to a robot which does not -- exist. -applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe Location +applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmo Location) applyViewCenterRule (VCLocation l) _ = Just l applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation @@ -710,13 +720,15 @@ recalcViewCenter g = & (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id) where oldViewCenter = g ^. viewCenter - newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap)) + newViewCenter = + fromMaybe oldViewCenter $ + applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap) -- | Modify the 'viewCenter' by applying an arbitrary function to the -- current value. Note that this also modifies the 'viewCenterRule' -- to match. After calling this function the 'viewCenterRule' will -- specify a particular location, not a robot. -modifyViewCenter :: (Location -> Location) -> GameState -> GameState +modifyViewCenter :: (Cosmo Location -> Cosmo Location) -> GameState -> GameState modifyViewCenter update g = g & case g ^. viewCenterRule of @@ -732,10 +744,10 @@ 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.BoundsRectangle -viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) +viewingRegion :: GameState -> (Int32, Int32) -> Cosmo W.BoundsRectangle +viewingRegion g (w, h) = Cosmo sw (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) where - Location cx cy = g ^. viewCenter + Cosmo sw (Location cx cy) = g ^. viewCenter (rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1) (cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1) @@ -783,9 +795,10 @@ focusedRange g = computedRange <$ focusedRobot g | otherwise = MidRange $ (r - minRadius) / (maxRadius - minRadius) -- Euclidean distance from the base to the view center. - r = case g ^. robotMap . at 0 of - Just br -> euclidean (g ^. viewCenter) (br ^. robotLocation) - _ -> 1000000000 -- if the base doesn't exist, we have bigger problems + r = fromMaybe 1000000000 $ do + -- if the base doesn't exist, we have bigger problems + br <- g ^. robotMap . at 0 + cosmoMeasure euclidean (g ^. viewCenter) (br ^. robotLocation) -- See whether the base or focused robot have antennas installed. baseInv, focInv :: Maybe Inventory @@ -827,10 +840,18 @@ addRobot r = do let rid = r ^. robotID robotMap %= IM.insert rid r - robotsByLocation - %= M.insertWith IS.union (r ^. robotLocation) (IS.singleton rid) + addRobotToLocation rid $ r ^. robotLocation internalActiveRobots %= IS.insert rid +-- | Helper function for updating the "robotsByLocation" bookkeeping +addRobotToLocation :: (Has (State GameState) sig m) => RID -> Cosmo Location -> m () +addRobotToLocation rid rLoc = + robotsByLocation + %= M.insertWith + (M.unionWith IS.union) + (rLoc ^. subworld) + (M.singleton (rLoc ^. planar) (IS.singleton rid)) + maxMessageQueueSize :: Int maxMessageQueueSize = 1000 @@ -889,7 +910,7 @@ clearWatchingRobots rids = do -- -- NOTE: Clearing "TickNumber" map entries from "internalWaitingRobots" -- upon wakeup is handled by "wakeUpRobotsDoneSleeping" in State.hs -wakeWatchingRobots :: (Has (State GameState) sig m) => Location -> m () +wakeWatchingRobots :: (Has (State GameState) sig m) => Cosmo Location -> m () wakeWatchingRobots loc = do currentTick <- use ticks waitingMap <- use waitingRobots @@ -948,7 +969,29 @@ deleteRobot rn = do mrobot <- robotMap . at rn <<.= Nothing mrobot `forM_` \robot -> do -- Delete the robot from the index of robots by location. - robotsByLocation . ix (robot ^. robotLocation) %= IS.delete rn + removeRobotFromLocationMap (robot ^. robotLocation) rn + +-- | Makes sure empty sets don't hang around in the +-- robotsByLocation map. We don't want a key with an +-- empty set at every location any robot has ever +-- visited! +removeRobotFromLocationMap :: + (Has (State GameState) sig m) => + Cosmo Location -> + RID -> + m () +removeRobotFromLocationMap (Cosmo oldSubworld oldPlanar) rid = + robotsByLocation %= M.update (tidyDelete rid) oldSubworld + where + nullToNothing :: (a -> Bool) -> a -> Maybe a + nullToNothing isEmptyFunc t + | isEmptyFunc t = Nothing + | otherwise = Just t + + deleteOne x = nullToNothing IS.null . IS.delete x + + tidyDelete robID = + nullToNothing M.null . M.update (deleteOne robID) oldPlanar ------------------------------------------------------------ -- Initialization @@ -1004,10 +1047,10 @@ initGameState gsc = , _currentScenarioPath = Nothing , _knownEntities = [] , _worldNavigation = Navigation mempty mempty - , _world = W.emptyWorld (fromEnum StoneT) + , _multiWorld = mempty , _worldScrollable = True , _viewCenterRule = VCRobot 0 - , _viewCenter = origin + , _viewCenter = defaultCosmoLocation , _needsRedraw = False , _replStatus = REPLDone Nothing , _replNextValueIndex = 0 @@ -1045,10 +1088,7 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) & winCondition .~ theWinCondition & winSolution .~ scenario ^. scenarioSolution & robotMap .~ IM.fromList (map (view robotID &&& id) robotList') - & robotsByLocation - .~ M.fromListWith - IS.union - (map (view robotLocation &&& (IS.singleton . view robotID)) robotList') + & robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld robotList') & internalActiveRobots .~ setOf (traverse . robotID) robotList' & availableCommands .~ Notifications 0 initialCommands & gensym .~ initGensym @@ -1060,9 +1100,12 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) & recipesIn %~ addRecipesWith inRecipeMap & recipesReq %~ addRecipesWith reqRecipeMap & knownEntities .~ scenario ^. scenarioKnown - & worldNavigation .~ navigation (scenario ^. scenarioWorld) - & world .~ theWorld theSeed - & worldScrollable .~ scenario ^. scenarioWorld . to scrollable + & worldNavigation .~ scenario ^. scenarioNavigation + & multiWorld .~ allSubworldsMap theSeed + -- TODO: Should we allow subworlds to have their own scrollability? + -- Leaning toward yes, but for now just adopt the root world scrollability + -- as being universal. + & worldScrollable .~ NE.head (scenario ^. scenarioWorlds) ^. to scrollable & viewCenterRule .~ VCRobot baseID & replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working, -- otherwise the store of definition cells is not saved (see #333, #838) @@ -1070,6 +1113,14 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) True -> REPLWorking (Typed Nothing PolyUnit mempty) & robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick) where + groupRobotsBySubworld = + binTuples . map (view (robotLocation . subworld) &&& id) + + groupRobotsByPlanarLocation rs = + M.fromListWith + IS.union + (map (view (robotLocation . planar) &&& (IS.singleton . view robotID)) rs) + em = initEntities gsc <> scenario ^. scenarioEntities baseID = 0 (things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em)) @@ -1145,8 +1196,17 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) (maybe True (`S.member` initialCaps) . constCaps) allConst - (genRobots, wf) = buildWorld em (scenario ^. scenarioWorld) - theWorld = W.newWorld . wf + -- TODO: We currently only utilize genRobots on the root world. + (genRobots, _wf) = buildWorld em $ NE.head $ scenario ^. scenarioWorlds + + allSubworldsMap s = + M.fromList + . map (worldName &&& genWorld) + . NE.toList + $ scenario ^. scenarioWorlds + where + genWorld x = W.newWorld $ snd (buildWorld em x) s + theWinCondition = maybe NoWinCondition @@ -1159,7 +1219,7 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) -- | Take a world description, parsed from a scenario file, and turn -- it into a list of located robots and a world function. buildWorld :: EntityMap -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) -buildWorld em WorldDescription {..} = (robots, first fromEnum . wf) +buildWorld em WorldDescription {..} = (robots worldName, first fromEnum . wf) where rs = fromIntegral $ length area cs = fromIntegral $ length (head area) @@ -1177,13 +1237,13 @@ buildWorld em WorldDescription {..} = (robots, first fromEnum . wf) Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e)) -- Get all the robots described in cells and set their locations appropriately - robots :: [IndexedTRobot] - robots = + robots :: SubworldName -> [IndexedTRobot] + robots swName = area & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices & concat & concatMap ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) -> - let robotWithLoc = trobotLocation ?~ W.coordsToLoc (Coords (ulr + r, ulc + c)) + let robotWithLoc = trobotLocation ?~ Cosmo swName (W.coordsToLoc (Coords (ulr + r, ulc + c))) in map (fmap robotWithLoc) robotList ) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index d8fd9f4315..26a784545e 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -30,7 +30,7 @@ import Control.Effect.Error import Control.Effect.Lens import Control.Effect.Lift import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (foldM, forM, forM_, guard, msum, unless, when, zipWithM) +import Control.Monad (foldM, forM, forM_, guard, join, msum, unless, when, zipWithM) import Control.Monad.Except (runExceptT) import Data.Array (bounds, (!)) import Data.Bifunctor (second) @@ -78,6 +78,7 @@ import Swarm.Game.Scenario.Objective.WinCheck qualified as WC import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.Value import Swarm.Game.World qualified as W import Swarm.Language.Capability @@ -378,7 +379,20 @@ getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic -- -- Use ID (-1) so it won't conflict with any robots currently in the robot map. hypotheticalRobot :: CESK -> TimeSpec -> Robot -hypotheticalRobot c = mkRobot (-1) Nothing "hypothesis" [] zero zero defaultRobotDisplay c [] [] True False +hypotheticalRobot c = + mkRobot + (-1) + Nothing + "hypothesis" + [] + defaultCosmoLocation + zero + defaultRobotDisplay + c + [] + [] + True + False evaluateCESK :: (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => @@ -413,24 +427,36 @@ flagRedraw = needsRedraw .= True -- | Perform an action requiring a 'W.World' state component in a -- larger context with a 'GameState'. -zoomWorld :: (Has (State GameState) sig m) => StateC (W.World Int Entity) Identity b -> m b -zoomWorld n = do - w <- use world - let (w', a) = run (runState w n) - world .= w' - return a +zoomWorld :: + (Has (State GameState) sig m) => + SubworldName -> + StateC (W.World Int Entity) Identity b -> + m (Maybe b) +zoomWorld swName n = do + mw <- use multiWorld + forM (M.lookup swName mw) $ \w -> do + let (w', a) = run (runState w n) + multiWorld %= M.insert swName w' + return a -- | Get the entity (if any) at a given location. -entityAt :: (Has (State GameState) sig m) => Location -> m (Maybe Entity) -entityAt loc = zoomWorld (W.lookupEntityM @Int (W.locToCoords loc)) +entityAt :: (Has (State GameState) sig m) => Cosmo Location -> m (Maybe Entity) +entityAt (Cosmo subworldName loc) = + join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc)) -- | Modify the entity (if any) at a given location. updateEntityAt :: - (Has (State GameState) sig m) => Location -> (Maybe Entity -> Maybe Entity) -> m () -updateEntityAt loc upd = do - didChange <- zoomWorld $ W.updateM @Int (W.locToCoords loc) upd + (Has (State GameState) sig m) => + Cosmo Location -> + (Maybe Entity -> Maybe Entity) -> + m () +updateEntityAt cLoc@(Cosmo subworldName loc) upd = do + didChange <- + fmap (fromMaybe False) $ + zoomWorld subworldName $ + W.updateM @Int (W.locToCoords loc) upd when didChange $ - wakeWatchingRobots loc + wakeWatchingRobots cLoc -- | Get the robot with a given ID. robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot) @@ -483,13 +509,17 @@ randomName = do -- | Create a log entry given current robot and game time in ticks noting whether it has been said. -- -- This is the more generic version used both for (recorded) said messages and normal logs. -createLogEntry :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry +createLogEntry :: + (Has (State GameState) sig m, Has (State Robot) sig m) => + LogSource -> + Text -> + m LogEntry createLogEntry source msg = do rid <- use robotID rn <- use robotName time <- use ticks loc <- use robotLocation - pure $ LogEntry time source rn rid loc msg + pure $ LogEntry time source rn rid (Just loc) msg -- | Print some text via the robot's log. traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry @@ -608,8 +638,8 @@ updateWorld :: WorldUpdate Entity -> m () updateWorld c (ReplaceEntity loc eThen down) = do - w <- use world - let eNow = W.lookupEntity (W.locToCoords loc) w + w <- use multiWorld + let eNow = W.lookupCosmoEntity (fmap W.locToCoords loc) w -- Can fail if a robot started a multi-tick "drill" operation on some entity -- and meanwhile another entity swaps it out from under them. if Just eThen /= eNow @@ -1034,7 +1064,13 @@ seedProgram minTime randTime thing = -- | Construct a "seed robot" from entity, time range and position, -- and add it to the world. It has low priority and will be covered -- by placed entities. -addSeedBot :: Has (State GameState) sig m => Entity -> (Integer, Integer) -> Location -> TimeSpec -> m () +addSeedBot :: + Has (State GameState) sig m => + Entity -> + (Integer, Integer) -> + Cosmo Location -> + TimeSpec -> + m () addSeedBot e (minT, maxT) loc ts = void $ addTRobot $ @@ -1095,7 +1131,7 @@ execConst c vs s k = do -- Figure out where we're going loc <- use robotLocation orient <- use robotOrientation - let nextLoc = loc .+^ (orient ? zero) + let nextLoc = offsetBy loc $ orient ? zero checkMoveAhead nextLoc $ MoveFailure { failIfBlocked = ThrowExn @@ -1107,9 +1143,9 @@ execConst c vs s k = do -- Figure out where we're going loc <- use robotLocation orient <- use robotOrientation - let heading = orient ? zero - nextLoc = loc .+^ heading - placementLoc = nextLoc .+^ heading + let applyHeading = (`offsetBy` (orient ? zero)) + nextLoc = applyHeading loc + placementLoc = applyHeading nextLoc -- If unobstructed, the robot will move even if -- there is nothing to push. @@ -1153,11 +1189,11 @@ execConst c vs s k = do let heading = orient ? zero -- Excludes the base location. - let locsInDirection :: [Location] + let locsInDirection :: [Cosmo Location] locsInDirection = take (min (fromIntegral d) maxStrideRange) $ drop 1 $ - iterate (.+^ heading) loc + iterate (`offsetBy` heading) loc failureMaybes <- mapM checkMoveFailure locsInDirection let maybeFirstFailure = asum failureMaybes @@ -1182,7 +1218,7 @@ execConst c vs s k = do target <- getRobotWithinTouch rid -- either change current robot or one in robot map let oldLoc = target ^. robotLocation - nextLoc = Location (fromIntegral x) (fromIntegral y) + nextLoc = fmap (const $ Location (fromIntegral x) (fromIntegral y)) oldLoc onTarget rid $ do checkMoveAhead nextLoc $ @@ -1364,24 +1400,26 @@ execConst c vs s k = do selfRid <- use robotID -- Includes the base location, so we exclude the base robot later. - let locsInDirection :: [Location] - locsInDirection = take maxScoutRange $ iterate (.+^ heading) myLoc + let locsInDirection :: [Cosmo Location] + locsInDirection = take maxScoutRange $ iterate (`offsetBy` heading) myLoc let hasOpaqueEntity = fmap (maybe False (`hasProperty` E.Opaque)) . entityAt - let hasVisibleBot :: Location -> Bool + let hasVisibleBot :: Cosmo Location -> Bool hasVisibleBot = any botIsVisible . IS.toList . excludeSelf . botsHere where excludeSelf = (`IS.difference` IS.singleton selfRid) - botsHere loc = M.findWithDefault mempty loc botsByLocs + botsHere (Cosmo swName loc) = + M.findWithDefault mempty loc $ + M.findWithDefault mempty swName botsByLocs botIsVisible = maybe False canSee . (`IM.lookup` rMap) canSee = not . (^. robotDisplay . invisible) -- A robot on the same cell as an opaque entity is considered hidden. -- Returns (Just Bool) if the result is conclusively visible or opaque, -- or Nothing if we don't have a conclusive answer yet. - let isConclusivelyVisible :: Bool -> Location -> Maybe Bool + let isConclusivelyVisible :: Bool -> Cosmo Location -> Maybe Bool isConclusivelyVisible isOpaque loc | isOpaque = Just False | hasVisibleBot loc = Just True @@ -1400,11 +1438,12 @@ execConst c vs s k = do _ -> badConst Whereami -> do loc <- use robotLocation - return $ Out (asValue loc) s k + return $ Out (asValue $ loc ^. planar) s k Waypoint -> case vs of [VText name, VInt idx] -> do lm <- use worldNavigation - case M.lookup (WaypointName name) (waypoints lm) of + Cosmo swName _ <- use robotLocation + case M.lookup (WaypointName name) $ M.findWithDefault mempty swName $ waypoints lm of Nothing -> throwError $ CmdFailed Waypoint (T.unwords ["No waypoint named", name]) Nothing Just wps -> return $ Out (asValue (NE.length wps, indexWrapNonEmpty wps idx)) s k _ -> badConst @@ -1413,8 +1452,9 @@ execConst c vs s k = do loc <- use robotLocation let locs = rectCells x1 y1 x2 y2 -- sort offsets by (Manhattan) distance so that we return the closest occurrence - let sortedLocs = sortOn (\(V2 x y) -> abs x + abs y) locs - firstOne <- findM (fmap (maybe False $ isEntityNamed name) . entityAt . (loc .+^)) sortedLocs + let sortedOffsets = sortOn (\(V2 x y) -> abs x + abs y) locs + let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc + firstOne <- findM f sortedOffsets return $ Out (asValue firstOne) s k _ -> badConst Resonate -> case vs of @@ -1436,7 +1476,8 @@ execConst c vs s k = do _ -> badConst Surveil -> case vs of [VPair (VInt x) (VInt y)] -> do - let loc = Location (fromIntegral x) (fromIntegral y) + Cosmo swName _ <- use robotLocation + let loc = Cosmo swName $ Location (fromIntegral x) (fromIntegral y) addWatchedLocation loc return $ Out VUnit s k _ -> badConst @@ -1485,7 +1526,7 @@ execConst c vs s k = do Blocked -> do loc <- use robotLocation orient <- use robotOrientation - let nextLoc = loc .+^ (orient ? zero) + let nextLoc = offsetBy loc (orient ? zero) me <- entityAt nextLoc return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) s k Scan -> case vs of @@ -1576,12 +1617,25 @@ execConst c vs s k = do loc <- use robotLocation m <- traceLog Said msg -- current robot will inserted to robot set, so it needs the log emitMessage m - let addLatestClosest rl = \case + let manhattanToLog :: Cosmo Location -> Maybe (Cosmo Location) -> Maybe Int32 + -- Measures the Manhattan distance between a robot and a (Maybe) log location. + -- If log location is Nothing, it is "omnipresent" and therefore distance is zero. + manhattanToLog robLoc maybeLogLoc = case maybeLogLoc of + Just logLoc -> cosmoMeasure manhattan robLoc logLoc + Nothing -> Just 0 + addLatestClosest rl = \case Seq.Empty -> Seq.singleton m es Seq.:|> e | e ^. leTime < m ^. leTime -> es |> e |> m - | manhattan rl (e ^. leLocation) > manhattan rl (m ^. leLocation) -> es |> m + | (cmpManhattan `on` (manhattanToLog rl . view leLocation)) e m -> es |> m | otherwise -> es |> e + where + -- Returns True if M1 is not smaller than M2. "Nothing" is treated as infinite. + -- TODO: Should probably define a new, parameterized datatype isomorphic to + -- Maybe that makes this convention explicit. + cmpManhattan maybeM1 maybeM2 = case maybeM1 of + Nothing -> True + Just m1 -> maybe False (m1 >) maybeM2 let addToRobotLog :: Has (State GameState) sgn m => Robot -> m () addToRobotLog r = do r' <- execState r $ do @@ -1725,7 +1779,7 @@ execConst c vs s k = do g <- get @GameState let neighbor = find ((/= rid) . (^. robotID)) -- pick one other than ourself - . sortOn (manhattan loc . (^. robotLocation)) -- prefer closer + . sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer $ robotsInArea loc 1 g -- all robots within Manhattan distance 1 return $ Out (asValue neighbor) s k MeetAll -> case vs of @@ -1836,7 +1890,8 @@ execConst c vs s k = do -- a robot can program adjacent robots -- privileged bots ignore distance checks loc <- use robotLocation - (isPrivileged || (childRobot ^. robotLocation) `manhattan` loc <= 1) + + isNearbyOrExempt isPrivileged loc (childRobot ^. robotLocation) `holdsOrFail` ["You can only reprogram an adjacent robot."] -- Figure out if we can supply what the target robot requires, @@ -2173,8 +2228,8 @@ execConst c vs s k = do m CESK doResonate p x1 y1 x2 y2 = do loc <- use robotLocation - let locs = rectCells x1 y1 x2 y2 - hits <- mapM (fmap (fromEnum . p) . entityAt . (loc .+^)) locs + let offsets = rectCells x1 y1 x2 y2 + hits <- mapM (fmap (fromEnum . p) . entityAt . offsetBy loc) offsets return $ Out (VInt $ fromIntegral $ sum hits) s k rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32] @@ -2197,10 +2252,11 @@ execConst c vs s k = do m (Maybe (Int32, V2 Int32)) findNearest name = do loc <- use robotLocation - findM (fmap (maybe False $ isEntityNamed name) . entityAt . (loc .+^) . snd) sortedLocs + let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc . snd + findM f sortedOffsets where - sortedLocs :: [(Int32, V2 Int32)] - sortedLocs = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange] + sortedOffsets :: [(Int32, V2 Int32)] + sortedOffsets = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange] -- Grow a list of locations in a diamond shape outward, such that the nearest cells -- are searched first by construction, rather than having to sort. @@ -2235,11 +2291,11 @@ execConst c vs s k = do when (isCardinal d) $ hasCapabilityFor COrient $ TDir d return $ applyTurn d $ orient ? zero - lookInDirection :: HasRobotStepState sig m => Direction -> m (Location, Maybe Entity) + lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmo Location, Maybe Entity) lookInDirection d = do newHeading <- deriveHeading d loc <- use robotLocation - let nextLoc = loc .+^ newHeading + let nextLoc = offsetBy loc newHeading (nextLoc,) <$> entityAt nextLoc ensureEquipped :: HasRobotStepState sig m => Text -> m Entity @@ -2417,7 +2473,7 @@ execConst c vs s k = do -- Make sure nothing is in the way. Note that system robots implicitly ignore -- and base throws on failure. - checkMoveFailure :: HasRobotStepState sig m => Location -> m (Maybe MoveFailureDetails) + checkMoveFailure :: HasRobotStepState sig m => Cosmo Location -> m (Maybe MoveFailureDetails) checkMoveFailure nextLoc = do me <- entityAt nextLoc systemRob <- use systemRobot @@ -2459,7 +2515,7 @@ execConst c vs s k = do IgnoreFail -> return () -- Determine the move failure mode and apply the corresponding effect. - checkMoveAhead :: HasRobotStepState sig m => Location -> MoveFailure -> m () + checkMoveAhead :: HasRobotStepState sig m => Cosmo Location -> MoveFailure -> m () checkMoveAhead nextLoc failureHandlers = do maybeFailure <- checkMoveFailure nextLoc applyMoveFailureEffect maybeFailure failureHandlers @@ -2567,7 +2623,7 @@ execConst c vs s k = do addWatchedLocation :: HasRobotStepState sig m => - Location -> + Cosmo Location -> m () addWatchedLocation loc = do rid <- use robotID @@ -2600,9 +2656,9 @@ isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode -- | Requires that the target location is within one cell. -- Requirement is waived if the bot is privileged. -isNearbyOrExempt :: Bool -> Location -> Location -> Bool +isNearbyOrExempt :: Bool -> Cosmo Location -> Cosmo Location -> Bool isNearbyOrExempt privileged myLoc otherLoc = - privileged || otherLoc `manhattan` myLoc <= 1 + privileged || maybe False (<= 1) (cosmoMeasure manhattan myLoc otherLoc) grantAchievement :: (Has (State GameState) sig m, Has (Lift IO) sig m) => @@ -2683,16 +2739,16 @@ provisionChild childID toEquip toGive = do -- Also implements teleportation by portals. updateRobotLocation :: (HasRobotStepState sig m) => - Location -> - Location -> + Cosmo Location -> + Cosmo Location -> m () updateRobotLocation oldLoc newLoc | oldLoc == newLoc = return () | otherwise = do newlocWithPortal <- applyPortal newLoc rid <- use robotID - robotsByLocation . at oldLoc %= deleteOne rid - robotsByLocation . at newlocWithPortal . non Empty %= IS.insert rid + removeRobotFromLocationMap oldLoc rid + addRobotToLocation rid newlocWithPortal modify (unsafeSetRobotLocation newlocWithPortal) flagRedraw where @@ -2700,17 +2756,6 @@ updateRobotLocation oldLoc newLoc lms <- use worldNavigation return $ M.findWithDefault loc loc $ portals lms - -- Make sure empty sets don't hang around in the - -- robotsByLocation map. We don't want a key with an - -- empty set at every location any robot has ever - -- visited! - deleteOne _ Nothing = Nothing - deleteOne x (Just s) - | IS.null s' = Nothing - | otherwise = Just s' - where - s' = IS.delete x s - -- | Execute a stateful action on a target robot --- whether the -- current one or another. onTarget :: diff --git a/src/Swarm/Game/Universe.hs b/src/Swarm/Game/Universe.hs new file mode 100644 index 0000000000..0aa6e9d55a --- /dev/null +++ b/src/Swarm/Game/Universe.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Universe where + +import Control.Lens (makeLenses, view) +import Control.Monad (guard) +import Data.Function (on) +import Data.Int (Int32) +import Data.Text (Text) +import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, (.:)) +import GHC.Generics (Generic) +import Linear (V2 (..)) +import Swarm.Game.Location + +-- TODO: It would be better not to use this as +-- an "in-band" reserved name. Preferably its use +-- should be eliminated entirely. +-- E.g., robot locations specified within a toplevel robot +-- definition (instead of on a map) should require the subworld +-- to be specified. Currently, the subworld name is optional +-- for backwards compatibility. +-- If, after all, a "default" is still required, should +-- use a dedicated sum type member to designate +-- the "default" for cases in which it is required. +defaultRootSubworldName :: SubworldName +defaultRootSubworldName = SubworldName "root" + +-- | Note: The primary overworld shall use +-- the reserved name \"root\". +newtype SubworldName = SubworldName Text + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) + +-- | The swarm universe consists of locations +-- indexed by subworld. +-- Not only is this datatype useful for planar (2D) +-- coordinates, but is also used for named waypoints. +data Cosmo a = Cosmo + { _subworld :: SubworldName + , _planar :: a + } + deriving (Show, Eq, Ord, Functor, Generic, ToJSON) + +makeLenses ''Cosmo + +instance (FromJSON a) => FromJSON (Cosmo a) where + parseJSON x = case x of + Object v -> objParse v + _ -> Cosmo defaultRootSubworldName <$> parseJSON x + where + objParse v = + Cosmo + <$> v .: "subworld" + <*> v .: "loc" + +defaultCosmoLocation :: Cosmo Location +defaultCosmoLocation = Cosmo defaultRootSubworldName origin + +-- | Returns "Nothing" if not within the same subworld. +-- TODO: Define a new datatype isomorphic to Maybe for this. +cosmoMeasure :: (a -> a -> b) -> Cosmo a -> Cosmo a -> Maybe b +cosmoMeasure f a b = do + guard $ ((==) `on` view subworld) a b + pure $ (f `on` view planar) a b + +offsetBy :: Cosmo Location -> V2 Int32 -> Cosmo Location +offsetBy loc v = fmap (.+^ v) loc diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index c32e919b1b..2e999c15bc 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -23,6 +23,7 @@ module Swarm.Game.World ( WorldFun (..), worldFunFromArray, World, + MultiWorld, -- ** Tile management loadCell, @@ -31,7 +32,9 @@ module Swarm.Game.World ( -- ** World functions newWorld, emptyWorld, + lookupCosmosTerrain, lookupTerrain, + lookupCosmoEntity, lookupEntity, update, @@ -55,11 +58,14 @@ import Data.Bits import Data.Foldable (foldl') import Data.Function (on) import Data.Int (Int32) +import Data.Map (Map) import Data.Map.Strict qualified as M import Data.Yaml (FromJSON, ToJSON) import GHC.Generics (Generic) import Swarm.Game.Entity (Entity, entityHash) import Swarm.Game.Location +import Swarm.Game.Terrain (TerrainType (BlankT)) +import Swarm.Game.Universe import Swarm.Util ((?)) import Prelude hiding (lookup) @@ -187,6 +193,8 @@ type TerrainTile t = U.UArray TileOffset t -- which have to be boxed. type EntityTile e = A.Array TileOffset (Maybe e) +type MultiWorld t e = Map SubworldName (World t e) + -- | A 'World' consists of a 'WorldFun' that specifies the initial -- world, a cache of loaded square tiles to make lookups faster, and -- a map storing locations whose entities have changed from their @@ -214,6 +222,14 @@ newWorld f = World f M.empty M.empty emptyWorld :: t -> World t e emptyWorld t = newWorld (WF $ const (t, Nothing)) +lookupCosmosTerrain :: + IArray U.UArray Int => + Cosmo Coords -> + MultiWorld Int e -> + TerrainType +lookupCosmosTerrain (Cosmo subworldName i) multiWorld = + maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName multiWorld + -- | Look up the terrain value at certain coordinates: try looking it -- up in the tile cache first, and fall back to running the 'WorldFun' -- otherwise. @@ -225,31 +241,43 @@ lookupTerrain i (World f t _) = ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t) ? fst (runWF f i) --- | A stateful variant of 'lookupTerrain', which first loads the tile +-- | A stateful variant of "lookupTerrain", which first loads the tile -- containing the given coordinates if it is not already loaded, -- then looks up the terrain value. -lookupTerrainM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m t +lookupTerrainM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m t lookupTerrainM c = do modify @(World t e) $ loadCell c lookupTerrain c <$> get @(World t e) +lookupCosmoEntity :: Cosmo Coords -> MultiWorld t e -> Maybe e +lookupCosmoEntity (Cosmo subworldName i) multiWorld = + lookupEntity i =<< M.lookup subworldName multiWorld + -- | Look up the entity at certain coordinates: first, see if it is in -- the map of locations with changed entities; then try looking it -- up in the tile cache first; and finally fall back to running the --- 'WorldFun'. +-- "WorldFun". -- -- This function does /not/ ensure that the tile containing the --- given coordinates is loaded. For that, see 'lookupEntityM'. +-- given coordinates is loaded. For that, see "lookupEntityM". lookupEntity :: Coords -> World t e -> Maybe e lookupEntity i (World f t m) = M.lookup i m ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t) ? snd (runWF f i) --- | A stateful variant of 'lookupTerrain', which first loads the tile +-- | A stateful variant of "lookupEntity", which first loads the tile -- containing the given coordinates if it is not already loaded, -- then looks up the terrain value. -lookupEntityM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m (Maybe e) +lookupEntityM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m (Maybe e) lookupEntityM c = do modify @(World t e) $ loadCell c lookupEntity c <$> get @(World t e) @@ -258,7 +286,11 @@ lookupEntityM c = do -- returning an updated 'World' and a Boolean indicating whether -- the update changed the entity here. -- See also 'updateM'. -update :: Coords -> (Maybe Entity -> Maybe Entity) -> World t Entity -> (World t Entity, Bool) +update :: + Coords -> + (Maybe Entity -> Maybe Entity) -> + World t Entity -> + (World t Entity, Bool) update i g w@(World f t m) = (wNew, ((/=) `on` fmap (view entityHash)) entityAfter entityBefore) where @@ -266,7 +298,7 @@ update i g w@(World f t m) = entityBefore = lookupEntity i w entityAfter = g entityBefore --- | A stateful variant of 'update', which also ensures the tile +-- | A stateful variant of "update", which also ensures the tile -- containing the given coordinates is loaded. updateM :: forall t sig m. @@ -283,7 +315,12 @@ loadCell c = loadRegion (c, c) -- | Load all the tiles which overlap the given rectangular region -- (specified as an upper-left and lower-right corner, inclusive). -loadRegion :: forall t e. (IArray U.UArray t) => (Coords, Coords) -> World t e -> World t e +loadRegion :: + forall t e. + (IArray U.UArray t) => + (Coords, Coords) -> + World t e -> + World t e loadRegion reg (World f t m) = World f t' m where tiles = range (over both tileCoords reg) @@ -308,7 +345,7 @@ loadRegion reg (World f t m) = World f t' m -- This type is used for changes by e.g. the drill command at later -- tick. Using ADT allows us to serialize and inspect the updates. data WorldUpdate e = ReplaceEntity - { updatedLoc :: Location + { updatedLoc :: Cosmo Location , originalEntity :: e , newEntity :: Maybe e } diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index a7f066d88b..808277c047 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -697,7 +697,8 @@ constInfo c = case c of Whereami -> command 0 Intangible "Get the current x and y coordinates." Waypoint -> command 2 Intangible . doc "Get the x, y coordinates of a named waypoint, by index" $ - [ "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))." + [ "Return only the waypoints in the same subworld as the calling robot." + , "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))." , "The supplied index will be wrapped automatically, modulo the waypoint count." , "A robot can use the count to know whether they have iterated over the full waypoint circuit." ] diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index bc38749967..0b6f96934a 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -78,6 +78,7 @@ import Swarm.Game.Robot import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.Step (finishGameTick, gameTick) +import Swarm.Game.Universe import Swarm.Language.Capability (Capability (CDebug, CMake)) import Swarm.Language.Context import Swarm.Language.Key (KeyCombo, mkKeyCombo) @@ -377,6 +378,7 @@ handleMainEvent ev = do | s ^. uiState . uiCheatMode -> do uiState . uiWorldEditor . isWorldEditorEnabled %= not setFocus WorldEditorPanel + MouseDown WorldPositionIndicator _ _ _ -> uiState . uiWorldCursor .= Nothing MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> -- Eye Dropper tool EC.handleMiddleClick mouseLoc @@ -394,7 +396,7 @@ handleMainEvent ev = do case n of FocusablePanel WorldPanel -> do mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - shouldUpdateCursor <- EC.updateAreaBounds mouseCoordsM + shouldUpdateCursor <- EC.updateAreaBounds $ fmap (^. planar) mouseCoordsM when shouldUpdateCursor $ uiState . uiWorldCursor .= mouseCoordsM REPLInput -> handleREPLEvent ev @@ -1340,7 +1342,7 @@ scrollView update = do -- always work, but there seems to be some sort of race condition -- where 'needsRedraw' gets reset before the UI drawing code runs. invalidateCacheEntry WorldCache - gameState %= modifyViewCenter update + gameState %= modifyViewCenter (fmap update) -- | Convert a directional key into a direction. keyToDir :: V.Key -> Heading diff --git a/src/Swarm/TUI/Controller/Util.hs b/src/Swarm/TUI/Controller/Util.hs index ec69c8d426..628150bace 100644 --- a/src/Swarm/TUI/Controller/Util.hs +++ b/src/Swarm/TUI/Controller/Util.hs @@ -9,8 +9,10 @@ import Brick.Focus import Control.Lens import Control.Monad (forM_, unless) import Control.Monad.IO.Class (liftIO) +import Data.Map qualified as M import Graphics.Vty qualified as V import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Model import Swarm.TUI.Model.UI @@ -77,17 +79,18 @@ loadVisibleRegion = do mext <- lookupExtent WorldExtent forM_ mext $ \(Extent _ _ size) -> do gs <- use gameState - gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size)) + let vr = viewingRegion gs (over both fromIntegral size) + gameState . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld) -mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe W.Coords) +mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmo W.Coords)) mouseLocToWorldCoords (Brick.Location mouseLoc) = do mext <- lookupExtent WorldExtent case mext of Nothing -> pure Nothing Just ext -> do region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) - let regionStart = W.unCoords (fst region) + let regionStart = W.unCoords (fst $ region ^. planar) mouseLoc' = bimap fromIntegral fromIntegral mouseLoc mx = snd mouseLoc' + fst regionStart my = fst mouseLoc' + snd regionStart - in pure . Just $ W.Coords (mx, my) + in pure . Just $ Cosmo (region ^. subworld) $ W.Coords (mx, my) diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index f31440f689..34429f2050 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -16,6 +16,7 @@ import Data.Yaml qualified as Y import Graphics.Vty qualified as V import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Model @@ -56,7 +57,7 @@ handleCtrlLeftClick mouseLoc = do -- TODO (#1151): Use hoistMaybe when available terrain <- MaybeT . pure $ maybeTerrainType mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiWorldEditor . paintedTerrain %= M.insert mouseCoords (terrain, maybeEntityPaint) + uiState . uiWorldEditor . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeEntityPaint) uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing immediatelyRedrawWorld return () @@ -67,7 +68,7 @@ handleRightClick mouseLoc = do _ <- runMaybeT $ do guard $ worldEditor ^. isWorldEditorEnabled mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiWorldEditor . paintedTerrain %= M.delete mouseCoords + uiState . uiWorldEditor . paintedTerrain %= M.delete (mouseCoords ^. planar) immediatelyRedrawWorld return () @@ -76,7 +77,7 @@ handleMiddleClick :: B.Location -> EventM Name AppState () handleMiddleClick mouseLoc = do worldEditor <- use $ uiState . uiWorldEditor when (worldEditor ^. isWorldEditorEnabled) $ do - w <- use $ gameState . world + w <- use $ gameState . multiWorld let setTerrainPaint coords = do let (terrain, maybeElementPaint) = EU.getContentAt @@ -120,7 +121,7 @@ updateAreaBounds = \case -- TODO (#1152): Validate that the lower-right click is below and to the right of the top-left coord LowerRightPending upperLeftMouseCoords -> do uiState . uiWorldEditor . editingBounds . boundsRect - .= Just (upperLeftMouseCoords, mouseCoords) + .= Just (Cosmo defaultRootSubworldName (upperLeftMouseCoords, mouseCoords)) uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete t <- liftIO $ getTime Monotonic @@ -133,7 +134,7 @@ saveMapFile :: EventM Name AppState () saveMapFile = do worldEditor <- use $ uiState . uiWorldEditor maybeBounds <- use $ uiState . uiWorldEditor . editingBounds . boundsRect - w <- use $ gameState . world + w <- use $ gameState . multiWorld let mapCellGrid = EU.getEditedMapRectangle worldEditor maybeBounds w let fp = worldEditor ^. outputFilePath diff --git a/src/Swarm/TUI/Editor/Masking.hs b/src/Swarm/TUI/Editor/Masking.hs index 93274e5e5f..f2988ed90b 100644 --- a/src/Swarm/TUI/Editor/Masking.hs +++ b/src/Swarm/TUI/Editor/Masking.hs @@ -2,6 +2,7 @@ module Swarm.TUI.Editor.Masking where import Control.Lens hiding (Const, from) import Data.Maybe (fromMaybe) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.Util qualified as EU @@ -20,7 +21,7 @@ shouldHideWorldCell ui coords = False ( do bounds <- we ^. editingBounds . boundsRect - pure $ EU.isOutsideRegion bounds coords + pure $ EU.isOutsideRegion (bounds ^. planar) coords ) isOutsideSingleSelectedCorner = fromMaybe False $ do diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs index 7b50f13fd1..fd88defa9f 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ b/src/Swarm/TUI/Editor/Model.hs @@ -13,6 +13,7 @@ import Swarm.Game.Entity qualified as E import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Model.Name import Swarm.Util @@ -42,7 +43,7 @@ getEntityName :: EntityFacade -> EntityName getEntityName (EntityFacade name _) = name data MapEditingBounds = MapEditingBounds - { _boundsRect :: Maybe W.BoundsRectangle + { _boundsRect :: Maybe (Cosmo W.BoundsRectangle) -- ^ Upper-left and lower-right coordinates -- of the map to be saved. , _boundsPersistDisplayUntil :: TimeSpec @@ -82,6 +83,6 @@ initialWorldEditor ts = MapEditingBounds -- Note that these are in "world coordinates", -- not in player-facing "Location" coordinates - (Just (W.Coords (-10, -20), W.Coords (10, 20))) + (Just $ Cosmo defaultRootSubworldName (W.Coords (-10, -20), W.Coords (10, 20))) (ts - 1) SelectionComplete diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs index 4f2f42152d..d416a1d4a8 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ b/src/Swarm/TUI/Editor/Palette.hs @@ -27,6 +27,7 @@ import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Terrain (TerrainType (BlankT), getTerrainDefaultPaletteChar) +import Swarm.Game.Universe import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) import Swarm.Util (binTuples, histogram) import Swarm.Util qualified as U @@ -86,7 +87,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = originalPalette :: KM.KeyMap CellPaintDisplay originalPalette = KM.map (toCellPaintDisplay . standardCell) $ - maybe mempty (unPalette . palette . (^. scenarioWorld)) maybeOriginalScenario + maybe mempty (unPalette . palette . NE.head . (^. scenarioWorlds)) maybeOriginalScenario pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain @@ -128,6 +129,7 @@ constructScenario maybeOriginalScenario cellGrid = , ul = upperLeftCoord , area = cellGrid , navigation = Navigation mempty mempty + , worldName = defaultRootSubworldName } suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs index 86a3d8861f..9b9806f3c6 100644 --- a/src/Swarm/TUI/Editor/Util.hs +++ b/src/Swarm/TUI/Editor/Util.hs @@ -14,6 +14,7 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Editor.Model import Swarm.TUI.Model @@ -24,19 +25,19 @@ getEntitiesForList em = where entities = M.elems $ entitiesByName em -getEditingBounds :: WorldDescription -> (Bool, W.BoundsRectangle) +getEditingBounds :: WorldDescription -> (Bool, Cosmo W.BoundsRectangle) getEditingBounds myWorld = (EA.isEmpty a, newBounds) where - newBounds = (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) + newBounds = Cosmo defaultRootSubworldName (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) upperLeftLoc = ul myWorld a = EA.getAreaDimensions $ area myWorld lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc getContentAt :: WorldEditor Name -> - W.World Int Entity -> - W.Coords -> + W.MultiWorld Int Entity -> + Cosmo W.Coords -> (TerrainType, Maybe EntityPaint) getContentAt editor w coords = (terrainWithOverride, entityWithOverride) @@ -51,20 +52,21 @@ getContentAt editor w coords = maybePaintedCell = do guard $ editor ^. isWorldEditorEnabled - Map.lookup coords pm + Map.lookup (coords ^. planar) pm pm = editor ^. paintedTerrain entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride - underlyingCellEntity = W.lookupEntity coords w - underlyingCellTerrain = toEnum $ W.lookupTerrain coords w + underlyingCellEntity = W.lookupCosmoEntity coords w + underlyingCellTerrain = W.lookupCosmosTerrain coords w getTerrainAt :: WorldEditor Name -> - W.World Int Entity -> - W.Coords -> + W.MultiWorld Int Entity -> + Cosmo W.Coords -> TerrainType -getTerrainAt editor w coords = fst $ getContentAt editor w coords +getTerrainAt editor w coords = + fst $ getContentAt editor w coords isOutsideTopLeftCorner :: -- | top left corner coords @@ -95,16 +97,16 @@ isOutsideRegion (tl, br) coord = getEditedMapRectangle :: WorldEditor Name -> - Maybe W.BoundsRectangle -> - W.World Int Entity -> + Maybe (Cosmo W.BoundsRectangle) -> + W.MultiWorld Int Entity -> [[CellPaintDisplay]] getEditedMapRectangle _ Nothing _ = [] -getEditedMapRectangle worldEditor (Just coords) w = +getEditedMapRectangle worldEditor (Just (Cosmo subworldName coords)) w = map renderRow [yTop .. yBottom] where (W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords - getContent = getContentAt worldEditor w + getContent = getContentAt worldEditor w . Cosmo subworldName drawCell :: Int32 -> Int32 -> CellPaintDisplay drawCell rowIndex colIndex = diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs index cee307b696..51fba78f0d 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ b/src/Swarm/TUI/Editor/View.hs @@ -9,6 +9,7 @@ import Data.List qualified as L import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Attr import Swarm.TUI.Border @@ -92,7 +93,7 @@ drawWorldEditor toplevelFocusRing uis = areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of UpperLeftPending -> str "Click top-left" LowerRightPending _wcoords -> str "Click bottom-right" - SelectionComplete -> maybe emptyWidget renderBounds maybeAreaBounds + SelectionComplete -> maybe emptyWidget (renderBounds . view planar) maybeAreaBounds areaWidget = mkFormControl (WorldEditorPanelControl AreaSelector) $ diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs index 65cd7fbd75..20ffcf050e 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -133,7 +133,6 @@ import Data.Text.IO qualified as T (readFile) import Data.Vector qualified as V import GitHash (GitInfo) import Graphics.Vty (ColorMode (..)) -import Linear (zero) import Network.Wai.Handler.Warp (Port) import Swarm.Game.CESK (TickNumber (..)) import Swarm.Game.Entity as E @@ -273,7 +272,7 @@ logEvent src (who, rid) msg el = & notificationsCount %~ succ & notificationsContent %~ (l :) where - l = LogEntry (TickNumber 0) src who rid zero msg + l = LogEntry (TickNumber 0) src who rid Nothing msg -- | Create a 'GameStateConfig' record from the 'RuntimeState'. mkGameStateConfig :: RuntimeState -> GameStateConfig diff --git a/src/Swarm/TUI/Model/Name.hs b/src/Swarm/TUI/Model/Name.hs index ca5310680b..f58c0bf731 100644 --- a/src/Swarm/TUI/Model/Name.hs +++ b/src/Swarm/TUI/Model/Name.hs @@ -62,6 +62,8 @@ data Name WorldCache | -- | The cached extent for the world view. WorldExtent + | -- | The cursor/viewCenter display in the bottom left of the World view + WorldPositionIndicator | -- | The list of possible entities to paint a map with. EntityPaintList | -- | The entity paint item position in the EntityPaintList. diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index 56a69f4552..db43d2e7fc 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -24,6 +24,7 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execStateT) import Data.List qualified as List +import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) @@ -33,7 +34,7 @@ import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Persistence import Swarm.Game.Failure.Render (prettyFailure) import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace)) -import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorld) +import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorlds) import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics @@ -207,8 +208,7 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do where entityList = EU.getEntitiesForList $ gs ^. entityMap - myWorld = scenario ^. scenarioWorld - (isEmptyArea, newBounds) = EU.getEditingBounds myWorld + (isEmptyArea, newBounds) = EU.getEditingBounds $ NE.head $ scenario ^. scenarioWorlds setNewBounds maybeOldBounds = if isEmptyArea then maybeOldBounds diff --git a/src/Swarm/TUI/Model/UI.hs b/src/Swarm/TUI/Model/UI.hs index 5aedef1694..7f217d5555 100644 --- a/src/Swarm/TUI/Model/UI.hs +++ b/src/Swarm/TUI/Model/UI.hs @@ -75,6 +75,7 @@ import Swarm.Game.ResourceLoading (getSwarmHistoryPath, readAppData) import Swarm.Game.ScenarioInfo ( ScenarioInfoPair, ) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Attr (swarmAttrMap) import Swarm.TUI.Editor.Model @@ -101,7 +102,7 @@ data UIState = UIState , _uiCheatMode :: Bool , _uiFocusRing :: FocusRing Name , _uiLaunchConfig :: LaunchOptions - , _uiWorldCursor :: Maybe W.Coords + , _uiWorldCursor :: Maybe (Cosmo W.Coords) , _uiWorldEditor :: WorldEditor Name , _uiREPL :: REPLState , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry) @@ -159,7 +160,7 @@ uiLaunchConfig :: Lens' UIState LaunchOptions uiFocusRing :: Lens' UIState (FocusRing Name) -- | The last clicked position on the world view. -uiWorldCursor :: Lens' UIState (Maybe W.Coords) +uiWorldCursor :: Lens' UIState (Maybe (Cosmo W.Coords)) -- | State of all World Editor widgets uiWorldEditor :: Lens' UIState (WorldEditor Name) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index ce55ddb610..9a566a0a37 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -87,6 +87,7 @@ import Swarm.Game.ScenarioInfo ( scenarioItemName, ) import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Language.Capability (Capability (..), constCaps) import Swarm.Language.Pretty (prettyText) @@ -415,11 +416,11 @@ drawGameUI s = ] ] where - addCursorPos = case s ^. uiState . uiWorldCursor of - Nothing -> id - Just coord -> - let worldCursorInfo = drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord - in bottomLabels . leftLabel ?~ padLeftRight 1 worldCursorInfo + addCursorPos = bottomLabels . leftLabel ?~ padLeftRight 1 widg + where + widg = case s ^. uiState . uiWorldCursor of + Nothing -> str $ renderCoordsString $ s ^. gameState . viewCenter + Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord -- Add clock display in top right of the world view if focused robot -- has a clock equipped addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (s ^. uiState . lgTicksPerSecond) $ s ^. gameState) @@ -461,14 +462,24 @@ drawGameUI s = ) ] -drawWorldCursorInfo :: WorldEditor Name -> GameState -> W.Coords -> Widget Name -drawWorldCursorInfo worldEditor g coords = +renderCoordsString :: Cosmo Location -> String +renderCoordsString cCoords = + unwords + [ VU.locationToString coords + , "in" + , T.unpack swName + ] + where + Cosmo (SubworldName swName) coords = cCoords + +drawWorldCursorInfo :: WorldEditor Name -> GameState -> Cosmo W.Coords -> Widget Name +drawWorldCursorInfo worldEditor g cCoords = case getStatic g coords of Just s -> renderDisplay $ displayStatic s Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget] where - coordsWidget = - str $ VU.locationToString $ W.coordsToLoc coords + Cosmo _ coords = cCoords + coordsWidget = str $ renderCoordsString $ fmap W.coordsToLoc cCoords tileMembers = terrain : mapMaybe merge [entity, robot] tileMemberWidgets = @@ -480,9 +491,9 @@ drawWorldCursorInfo worldEditor g coords = where f cell preposition = [renderDisplay cell, txt preposition] - terrain = displayTerrainCell worldEditor g coords - entity = displayEntityCell worldEditor g coords - robot = displayRobotCell g coords + terrain = displayTerrainCell worldEditor g cCoords + entity = displayEntityCell worldEditor g cCoords + robot = displayRobotCell g cCoords merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible)) @@ -646,15 +657,16 @@ robotsListWidget s = hCenter table | robot ^. robotLogUpdated = "x" | otherwise = " " - locWidget = hBox [worldCell, txt $ " " <> locStr] + locWidget = hBox [worldCell, str $ " " <> locStr] where - rloc@(Location x y) = robot ^. robotLocation + rCoords = fmap W.locToCoords rLoc + rLoc = robot ^. robotLocation worldCell = drawLoc (s ^. uiState) g - (W.locToCoords rloc) - locStr = from (show x) <> " " <> from (show y) + rCoords + locStr = renderCoordsString rLoc statusWidget = case robot ^. machine of Waiting {} -> txt "waiting" @@ -663,11 +675,11 @@ robotsListWidget s = hCenter table | otherwise -> withAttr greenAttr $ txt "idle" basePos :: Point V2 Double - basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation) + basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation . planar) -- Keep the base and non system robot (e.g. no seed) isRelevant robot = robot ^. robotID == 0 || not (robot ^. systemRobot) -- Keep the robot that are less than 32 unit away from the base - isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation) basePos < 32 + isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation . planar) basePos < 32 robots :: [Robot] robots = filter (\robot -> debugging || (isRelevant robot && isNear robot)) @@ -997,8 +1009,9 @@ drawWorld ui g = ctx <- getContext let w = ctx ^. availWidthL h = ctx ^. availHeightL - ixs = range (viewingRegion g (fromIntegral w, fromIntegral h)) - render . vBox . map hBox . chunksOf w . map (drawLoc ui g) $ ixs + vr = viewingRegion g (fromIntegral w, fromIntegral h) + ixs = range $ vr ^. planar + render . vBox . map hBox . chunksOf w . map (drawLoc ui g . Cosmo (vr ^. subworld)) $ ixs ------------------------------------------------------------ -- Robot inventory panel @@ -1014,7 +1027,7 @@ drawRobotPanel s -- away and a robot that does not exist. | Just r <- s ^. gameState . to focusedRobot , Just (_, lst) <- s ^. uiState . uiInventory = - let Location x y = r ^. robotLocation + let Cosmo _subworldName (Location x y) = r ^. robotLocation drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb in padBottom Max $ vBox diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs index 36b3712a4d..76c5451332 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ b/src/Swarm/TUI/View/CellDisplay.hs @@ -24,6 +24,7 @@ import Swarm.Game.Robot import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State import Swarm.Game.Terrain +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Attr import Swarm.TUI.Editor.Masking @@ -39,30 +40,37 @@ renderDisplay :: Display -> Widget n renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] -- | Render the 'Display' for a specific location. -drawLoc :: UIState -> GameState -> W.Coords -> Widget Name -drawLoc ui g coords = +drawLoc :: UIState -> GameState -> Cosmo W.Coords -> Widget Name +drawLoc ui g cCoords@(Cosmo _ coords) = if shouldHideWorldCell ui coords then str " " else drawCell where showRobots = ui ^. uiShowRobots we = ui ^. uiWorldEditor - drawCell = renderDisplay $ displayLoc showRobots we g coords + drawCell = renderDisplay $ displayLoc showRobots we g cCoords -displayTerrainCell :: WorldEditor Name -> GameState -> W.Coords -> Display +displayTerrainCell :: + WorldEditor Name -> + GameState -> + Cosmo W.Coords -> + Display displayTerrainCell worldEditor g coords = - terrainMap M.! EU.getTerrainAt worldEditor (g ^. world) coords + terrainMap M.! EU.getTerrainAt worldEditor (g ^. multiWorld) coords -displayRobotCell :: GameState -> W.Coords -> [Display] +displayRobotCell :: + GameState -> + Cosmo W.Coords -> + [Display] displayRobotCell g coords = map (view robotDisplay) $ - robotsAtLocation (W.coordsToLoc coords) g + robotsAtLocation (fmap W.coordsToLoc coords) g -displayEntityCell :: WorldEditor Name -> GameState -> W.Coords -> [Display] +displayEntityCell :: WorldEditor Name -> GameState -> Cosmo W.Coords -> [Display] displayEntityCell worldEditor g coords = maybeToList $ displayForEntity <$> maybeEntity where - (_, maybeEntity) = EU.getContentAt worldEditor (g ^. world) coords + (_, maybeEntity) = EU.getContentAt worldEditor (g ^. multiWorld) coords displayForEntity :: EntityPaint -> Display displayForEntity e = (if known e then id else hidden) $ getDisplay e @@ -89,14 +97,19 @@ hidingMode g -- 'Display's for the terrain, entity, and robots at the location, and -- taking into account "static" based on the distance to the robot -- being @view@ed. -displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display -displayLoc showRobots we g coords = +displayLoc :: Bool -> WorldEditor Name -> GameState -> Cosmo W.Coords -> Display +displayLoc showRobots we g cCoords@(Cosmo _ coords) = staticDisplay g coords - <> displayLocRaw showRobots we g coords + <> displayLocRaw showRobots we g cCoords -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. -displayLocRaw :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display +displayLocRaw :: + Bool -> + WorldEditor Name -> + GameState -> + Cosmo W.Coords -> + Display displayLocRaw showRobots worldEditor g coords = sconcat $ terrain NE.:| entity <> robots where terrain = displayTerrainCell worldEditor g coords @@ -152,7 +165,7 @@ getStatic g coords where -- Offset from the location of the view center to the location under -- consideration for display. - offset = W.coordsToLoc coords .-. (g ^. viewCenter) + offset = W.coordsToLoc coords .-. (g ^. viewCenter . planar) -- Hash. h = diff --git a/swarm.cabal b/swarm.cabal index 067a41d002..930e88c663 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -103,6 +103,7 @@ library Swarm.Game.Robot Swarm.Game.Scenario Swarm.Game.Scenario.Topography.Cell + Swarm.Game.Universe Swarm.TUI.Launch.Controller Swarm.TUI.Launch.Model Swarm.TUI.Launch.Prep diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 933677b1b4..5affd337f9 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -297,6 +297,7 @@ testScenarioSolution _ci _em = , testSolution Default "Testing/1256-halt-command" , testSolution Default "Testing/1295-density-command" , testSolution Default "Testing/1356-portals/portals-flip-and-rotate.yaml" + , testSolution Default "Testing/144-subworlds/basic-subworld.yaml" ] ] where