11{-# LANGUAGE OverloadedStrings #-}
2+ {-# LANGUAGE UndecidableInstances #-}
23
34-- |
45-- SPDX-License-Identifier: BSD-3-Clause
56module Swarm.Game.Scenario.Topography.Navigation.Portal where
67
78import Control.Monad (forM , forM_ , unless )
89import Data.Aeson (FromJSON )
10+ import Data.Bifunctor (first )
11+ import Data.Functor.Identity
912import Data.Int (Int32 )
1013import Data.List (intercalate )
1114import Data.List.NonEmpty (NonEmpty ((:|) ))
1215import Data.List.NonEmpty qualified as NE
1316import Data.Map qualified as M
14- import Data.Maybe (listToMaybe )
15- import Data.Text (Text )
17+ import Data.Maybe (fromMaybe , listToMaybe )
1618import Data.Text qualified as T
1719import GHC.Generics (Generic )
1820import Linear (V2 )
1921import Swarm.Game.Location
2022import Swarm.Game.Scenario.Topography.Navigation.Waypoint
23+ import Swarm.Game.Universe
2124import Swarm.Util (binTuples , quote )
2225
23- -- | Note: The primary overworld shall use
24- -- the reserved name \"root\".
25- newtype SubworldName = SubworldName Text
26- deriving (Show , Eq , Ord , Generic , FromJSON )
26+ type WaypointMap = M. MapWaypointName (NonEmpty Location )
2727
28- data Navigation = Navigation
29- { waypoints :: M. MapWaypointName (NonEmpty Location )
28+ -- | Parameterized on the portal specification method.
29+ -- At the subworld parsing level, we only can obtain the planar location
30+ -- for portal /entrances/. At the Scenario-parsing level, we finally have
31+ -- access to the waypoints across all subworlds, and can therefore translate
32+ -- the portal exits to concrete planar locations.
33+ data Navigation a b = Navigation
34+ { waypoints :: a WaypointMap
3035 -- ^ Note that waypoints defined at the "root" level are still relative to
3136 -- the top-left corner of the map rectangle; they are not in absolute world
3237 -- coordinates (as with applying the "ul" offset).
33- , portals :: M. MapLocation Location
38+ , portals :: M. Map( Cosmo Location ) ( Cosmo b )
3439 }
35- deriving (Eq , Show )
40+
41+ deriving instance (Eq a WaypointMap ), Eq b ) => Eq Navigation a b )
42+ deriving instance (Show a WaypointMap ), Show b ) => Show Navigation a b )
3643
3744data PortalExit = PortalExit
3845 { exit :: WaypointName
@@ -64,31 +71,59 @@ failUponDuplication message binnedMap =
6471 where
6572 duplicated = M. filter ((> 1 ) . NE. length ) binnedMap
6673
67- -- | Enforces the following constraints:
68- -- * portals can have multiple entrances but only a single exit
74+ failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a
75+ failWaypointLookup (WaypointName rawName) lookupResult = case lookupResult of
76+ Nothing ->
77+ fail $
78+ T. unpack $
79+ T. unwords
80+ [ " No waypoint named"
81+ , quote rawName
82+ ]
83+ Just xs -> return xs
84+
85+ -- |
86+ -- The following constraints must be enforced:
87+ -- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit
6988-- * no two portals share the same entrance location
70- -- * global waypoint uniqueness when the "unique" flag is specified
89+ -- * waypoint uniqueness within a subworld when the "unique" flag is specified
90+ --
91+ -- == Data flow:
92+ --
93+ -- Waypoints are defined within a subworld and are namespaced by it.
94+ -- Optional intra-subworld uniqueness of Waypoints is enforced at WorldDescription
95+ -- parse time.
96+ -- Portals are declared within a subworld. The portal entrance must be a waypoint
97+ -- within this subworld.
98+ -- They can reference waypoints in other subworlds as exits, but these references
99+ -- are not validated until the Scenario parse level.
100+ --
101+ -- * Since portal /entrances/ are specified at the subworld level, validation that
102+ -- no entrances overlap can also be performed at that level.
103+ -- * However, enforcement of single-multiplicity on portal /exits/ must be performed
104+ -- at scenario-parse level, because for a portal exit that references a waypoint in
105+ -- another subworld, we can't know at the single-WorldDescription level whether
106+ -- that waypoint has plural multiplicity.
71107validateNavigation ::
72108 (MonadFail m , Traversable t ) =>
109+ SubworldName ->
73110 V2 Int32 ->
74111 [Originated Waypoint ] ->
75112 t Portal ->
76- m Navigation
77- validateNavigation upperLeft unmergedWaypoints portalDefs = do
113+ m ( Navigation Identity WaypointName )
114+ validateNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do
78115 failUponDuplication " is required to be unique, but is duplicated in:"
79116
80- -- TODO(#144) Currently ignores subworld references
81- nestedPortalPairs <- forM portalDefs $ \ (Portal entranceName (PortalExit exitName@ (WaypointName rawExitName) _)) -> do
117+ nestedPortalPairs <- forM portalDefs $ \ (Portal entranceName (PortalExit exitName maybeExitSubworldName)) -> do
82118 -- Portals can have multiple entrances but only a single exit.
83119 -- That is, the pairings of entries to exits must form a proper mathematical "function".
84- -- Multiple occurrences of entrance waypoints of a given name will replicate portal entrances.
120+ -- Multiple occurrences of entrance waypoints of a given name will result in
121+ -- multiple portal entrances.
85122 entranceLocs <- getLocs entranceName
86- firstExitLoc :| otherExits <- getLocs exitName
87- unless (null otherExits)
88- . fail
89- . T. unpack
90- $ T. unwords [" Ambiguous exit waypoints named" " for portal"
91- return $ map ((,extractLoc firstExitLoc) . extractLoc) $ NE. toList entranceLocs
123+
124+ let sw = fromMaybe currentSubworldName maybeExitSubworldName
125+ f = (,Cosmo sw exitName) . extractLoc
126+ return $ map f $ NE. toList entranceLocs
92127
93128 let reconciledPortalPairs = concat nestedPortalPairs
94129
@@ -97,17 +132,10 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
97132 failUponDuplication " has overlapping portal entrances exiting to" $
98133 binTuples reconciledPortalPairs
99134
100- return $ Navigation bareWaypoints $ M. fromList reconciledPortalPairs
135+ return . Navigation (pure bareWaypoints) . M. fromList $
136+ map (first $ Cosmo currentSubworldName) reconciledPortalPairs
101137 where
102- getLocs wpWrapper@ (WaypointName rawName) = case M. lookup wpWrapper correctedWaypoints of
103- Nothing ->
104- fail $
105- T. unpack $
106- T. unwords
107- [ " No waypoint named"
108- , quote rawName
109- ]
110- Just xs -> return xs
138+ getLocs wpWrapper = failWaypointLookup wpWrapper $ M. lookup wpWrapper correctedWaypoints
111139
112140 extractLoc (Originated _ (Waypoint _ loc)) = loc
113141 correctedWaypoints =
@@ -116,5 +144,40 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
116144 (\ x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint upperLeft) x))
117145 unmergedWaypoints
118146 bareWaypoints = M. map (NE. map extractLoc) correctedWaypoints
119-
120147 waypointsWithUniqueFlag = M. filter (any $ wpUnique . wpConfig . value) correctedWaypoints
148+
149+ validatePortals ::
150+ MonadFail m =>
151+ Navigation (M. MapSubworldName ) WaypointName ->
152+ m (M. MapCosmo Location ) (Cosmo Location ))
153+ validatePortals (Navigation wpUniverse partialPortals) = do
154+ portalPairs <- forM (M. toList partialPortals) $ \ (portalEntrance, portalExit@ (Cosmo swName (WaypointName rawExitName))) -> do
155+ firstExitLoc :| otherExits <- getLocs portalExit
156+ unless (null otherExits)
157+ . fail
158+ . T. unpack
159+ $ T. unwords
160+ [ " Ambiguous exit waypoints named"
161+ , quote rawExitName
162+ , " for portal"
163+ ]
164+ return (portalEntrance, Cosmo swName firstExitLoc)
165+
166+ return $ M. fromList portalPairs
167+ where
168+ getLocs (Cosmo swName@ (SubworldName rawSwName) wpWrapper@ (WaypointName exitName)) = do
169+ subworldWaypoints <- case M. lookup swName wpUniverse of
170+ Just x -> return x
171+ Nothing ->
172+ fail $
173+ T. unpack $
174+ T. unwords
175+ [ " Could not lookup waypoint"
176+ , quote exitName
177+ , " for portal exit because subworld"
178+ , quote rawSwName
179+ , " does not exist"
180+ ]
181+
182+ failWaypointLookup wpWrapper $
183+ M. lookup wpWrapper subworldWaypoints
0 commit comments