From 9761ea5a479e0424c567677c88e5f69b41fec843 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 19 Oct 2024 08:04:07 -0700 Subject: [PATCH] expose waypoint and portal info to web API (#2185) ## Demo ``` scripts/play.sh -i scenarios/Testing/1356-portals/portals-and-waypoints.yaml ``` Then visit: http://localhost:5357/navigation --- .../Scenario/Topography/Navigation/Portal.hs | 3 ++- .../Scenario/Topography/Navigation/Waypoint.hs | 3 ++- src/swarm-topography/Swarm/Game/Universe.hs | 5 +++-- src/swarm-web/Swarm/Web.hs | 17 +++++++++++++++++ 4 files changed, 24 insertions(+), 4 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs index 5db64fc72..1138529c2 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -46,7 +46,7 @@ data AnnotatedDestination a = AnnotatedDestination , reorientation :: Direction , destination :: Cosmic a } - deriving (Show, Eq) + deriving (Show, Eq, Generic, ToJSON) -- | Parameterized on waypoint dimensionality ('additionalDimension') and -- on the portal location specification method ('portalExitLoc'). @@ -71,6 +71,7 @@ data Navigation additionalDimension portalExitLoc = Navigation -- coordinates (as with applying the "ul" offset). , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc) } + deriving (Generic) deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs index a72f0be09..f68622578 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs @@ -21,6 +21,7 @@ -- precise control of ordering. module Swarm.Game.Scenario.Topography.Navigation.Waypoint where +import Data.Aeson (ToJSONKey) import Data.Text qualified as T import Data.Yaml as Y import GHC.Generics (Generic) @@ -42,7 +43,7 @@ data Originated a = Originated deriving (Show, Eq, Functor) newtype WaypointName = WaypointName T.Text - deriving (Show, Eq, Ord, Generic, FromJSON) + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, ToJSONKey) -- | Metadata about a waypoint data WaypointConfig = WaypointConfig diff --git a/src/swarm-topography/Swarm/Game/Universe.hs b/src/swarm-topography/Swarm/Game/Universe.hs index 0ebd702ed..b34d63e90 100644 --- a/src/swarm-topography/Swarm/Game/Universe.hs +++ b/src/swarm-topography/Swarm/Game/Universe.hs @@ -10,6 +10,7 @@ module Swarm.Game.Universe where import Control.Lens (makeLenses, view) +import Data.Aeson (ToJSONKey) import Data.Function (on) import Data.Int (Int32) import Data.Text (Text) @@ -23,7 +24,7 @@ import Swarm.Util (quote) -- * Referring to subworlds data SubworldName = DefaultRootSubworld | SubworldName Text - deriving (Show, Eq, Ord, Generic, ToJSON) + deriving (Show, Eq, Ord, Generic, ToJSON, ToJSONKey) instance FromJSON SubworldName where parseJSON = withText "subworld name" $ return . SubworldName @@ -48,7 +49,7 @@ data Cosmic a = Cosmic { _subworld :: SubworldName , _planar :: a } - deriving (Show, Eq, Ord, Functor, Generic, ToJSON) + deriving (Show, Eq, Ord, Functor, Generic, ToJSON, ToJSONKey) makeLenses ''Cosmic diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 8769aa61b..5760b1716 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -41,6 +41,7 @@ import Control.Exception (Exception (displayException), IOException, catch, thro import Control.Lens import Control.Monad (void) import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) import Data.ByteString.Lazy (ByteString) import Data.Foldable (toList) import Data.IntMap qualified as IM @@ -63,18 +64,22 @@ import Servant.Docs qualified as SD import Servant.Docs.Internal qualified as SD (renderCurlBasePath) import Servant.Types.SourceT qualified as S import Swarm.Game.Entity (EntityName, entityName) +import Swarm.Game.Location (Location) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph import Swarm.Game.Scenario.Objective.WinCheck import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) +import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.State +import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Type +import Swarm.Game.Universe (SubworldName) import Swarm.Language.Pipeline (processTermEither) import Swarm.Pretty (prettyTextLine) import Swarm.TUI.Model hiding (SwarmKeyDispatchers (..)) @@ -104,6 +109,7 @@ type SwarmAPI = :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking :<|> "goals" :> Get '[JSON] WinCondition + :<|> "navigation" :> Get '[JSON] (Navigation (M.Map SubworldName) Location) :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog EntityName] :<|> "recognize" :> "found" :> Get '[JSON] [StructureLocation] :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text @@ -160,6 +166,7 @@ mkApp state events = :<|> goalsGraphHandler state :<|> uiGoalHandler state :<|> goalsHandler state + :<|> navigationHandler state :<|> recogLogHandler state :<|> recogFoundHandler state :<|> codeRenderHandler @@ -209,6 +216,16 @@ goalsHandler appStateRef = do appState <- liftIO appStateRef return $ appState ^. gameState . winCondition +deriving instance ToJSON (Navigation (M.Map SubworldName) Location) + +instance SD.ToSample (Navigation (M.Map SubworldName) Location) where + toSamples _ = SD.noSamples + +navigationHandler :: IO AppState -> Handler (Navigation (M.Map SubworldName) Location) +navigationHandler appStateRef = do + appState <- liftIO appStateRef + return $ appState ^. gameState . landscape . worldNavigation + recogLogHandler :: IO AppState -> Handler [SearchLog EntityName] recogLogHandler appStateRef = do appState <- liftIO appStateRef