world editor prototype

src/Swarm/App.hs

@@ -23,6 +23,7 @@ import Swarm.Game.Robot (LogSource (ErrorTrace, Said))
 import Swarm.TUI.Attr
 import Swarm.TUI.Controller
 import Swarm.TUI.Model
+import Swarm.TUI.Model.ScenarioState
 import Swarm.TUI.View
 import Swarm.Version (getNewerReleaseVersion)
 import Swarm.Web

src/Swarm/Game/Scenario.hs

@@ -23,12 +23,15 @@ module Swarm.Game.Scenario (
   objectiveCondition,
 
   -- * WorldDescription
-  Cell (..),
-  WorldDescription (..),
+  ProtoCell (..),
+  Cell,
+  ProtoWorldDescription (..),
+  WorldDescription,
+  WorldPalette (..),
   IndexedTRobot,
 
   -- * Scenario
-  Scenario,
+  Scenario (..),
 
   -- ** Fields
   scenarioVersion,
@@ -55,26 +58,20 @@ module Swarm.Game.Scenario (
 import Control.Algebra (Has)
 import Control.Carrier.Lift (Lift, sendIO)
 import Control.Carrier.Throw.Either (Throw, throwError)
-import Control.Lens hiding (from, (<.>))
-import Control.Monad (filterM, when)
-import Control.Monad.Extra (mapMaybeM)
-import Data.Aeson.Key qualified as Key
-import Data.Aeson.KeyMap (KeyMap)
-import Data.Aeson.KeyMap qualified as KeyMap
-import Data.Map (Map)
+import Control.Lens hiding (from, (.=), (<.>))
+import Control.Monad (filterM)
 import Data.Map qualified as M
 import Data.Maybe (catMaybes, isNothing, listToMaybe)
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Vector qualified as V
 import Data.Yaml as Y
 import GHC.Generics (Generic)
-import GHC.Int (Int64)
-import Linear.V2
 import Swarm.Game.Entity
 import Swarm.Game.Recipe
 import Swarm.Game.Robot (TRobot, trobotName)
-import Swarm.Game.Terrain
+import Swarm.Game.Scenario.Cells
+import Swarm.Game.Scenario.ScenarioUtil
+import Swarm.Game.Scenario.WorldDescription
 import Swarm.Language.Pipeline (ProcessedTerm)
 import Swarm.Util (getDataFileNameSafe, reflow)
 import Swarm.Util.Yaml
@@ -116,122 +113,10 @@ instance FromJSON Objective where
 -- Robot map
 ------------------------------------------------------------
 
--- | A robot template paired with its definition's index within
--- the Scenario file
-type IndexedTRobot = (Int, TRobot)
-
--- | A map from names to robots, used to look up robots in scenario
---   descriptions.
-type RobotMap = Map Text IndexedTRobot
-
 -- | Create a 'RobotMap' from a list of robot templates.
 buildRobotMap :: [TRobot] -> RobotMap
 buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 ..] rs
 
-------------------------------------------------------------
--- Lookup utilities
-------------------------------------------------------------
-
--- | Look up a thing by name, throwing a parse error if it is not
---   found.
-getThing :: String -> (Text -> m -> Maybe a) -> Text -> ParserE m a
-getThing thing lkup name = do
-  m <- getE
-  case lkup name m of
-    Nothing -> fail $ "Unknown " <> thing <> " name: " ++ show name
-    Just a -> return a
-
--- | Look up an entity by name in an 'EntityMap', throwing a parse
---   error if it is not found.
-getEntity :: Text -> ParserE EntityMap Entity
-getEntity = getThing "entity" lookupEntityName
-
--- | Look up a robot by name in a 'RobotMap', throwing a parse error
---   if it is not found.
-getRobot :: Text -> ParserE RobotMap IndexedTRobot
-getRobot = getThing "robot" M.lookup
-
-------------------------------------------------------------
--- World cells
-------------------------------------------------------------
-
--- | A single cell in a world map, which contains a terrain value,
---   and optionally an entity and robot.
-data Cell = Cell
-  { cellTerrain :: TerrainType
-  , cellEntity :: Maybe Entity
-  , cellRobots :: [IndexedTRobot]
-  }
-  deriving (Eq, Show)
-
--- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'.  The
---   entity and robot, if present, are immediately looked up and
---   converted into 'Entity' and 'TRobot' values.  If they are not
---   found, a parse error results.
-instance FromJSONE (EntityMap, RobotMap) Cell where
-  parseJSONE = withArrayE "tuple" $ \v -> do
-    let tup = V.toList v
-    when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)"
-
-    terr <- liftE $ parseJSON (head tup)
-
-    ent <- case tup ^? ix 1 of
-      Nothing -> return Nothing
-      Just e -> do
-        meName <- liftE $ parseJSON @(Maybe Text) e
-        traverse (localE fst . getEntity) meName
-
-    let name2rob r = do
-          mrName <- liftE $ parseJSON @(Maybe Text) r
-          traverse (localE snd . getRobot) mrName
-
-    robs <- mapMaybeM name2rob (drop 2 tup)
-
-    return $ Cell terr ent robs
-
-------------------------------------------------------------
--- World description
-------------------------------------------------------------
-
--- | A world palette maps characters to 'Cell' values.
-newtype WorldPalette = WorldPalette
-  {unPalette :: KeyMap Cell}
-  deriving (Eq, Show)
-
-instance FromJSONE (EntityMap, RobotMap) WorldPalette where
-  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
-
--- | A description of a world parsed from a YAML file.
-data WorldDescription = WorldDescription
-  { defaultTerrain :: Maybe Cell
-  , offsetOrigin :: Bool
-  , palette :: WorldPalette
-  , ul :: V2 Int64
-  , area :: [[Cell]]
-  }
-  deriving (Eq, Show)
-
-instance FromJSONE (EntityMap, RobotMap) WorldDescription where
-  parseJSONE = withObjectE "world description" $ \v -> do
-    pal <- v ..:? "palette" ..!= WorldPalette mempty
-    WorldDescription
-      <$> v ..:? "default"
-      <*> liftE (v .:? "offset" .!= False)
-      <*> pure pal
-      <*> liftE (v .:? "upperleft" .!= V2 0 0)
-      <*> liftE ((v .:? "map" .!= "") >>= paintMap pal)
-
--- | "Paint" a world map using a 'WorldPalette', turning it from a raw
---   string into a nested list of 'Cell' values by looking up each
---   character in the palette, failing if any character in the raw map
---   is not contained in the palette.
-paintMap :: MonadFail m => WorldPalette -> Text -> m [[Cell]]
-paintMap pal = traverse (traverse toCell . into @String) . T.lines
- where
-  toCell c = case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of
-    Nothing -> fail $ "Char not in world palette: " ++ show c
-    Just cell -> return cell
-
 ------------------------------------------------------------
 -- Scenario
 ------------------------------------------------------------

src/Swarm/Game/Scenario/Cells.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Swarm.Game.Scenario.Cells where
+
+import Control.Lens hiding (from, (.=), (<.>))
+import Control.Monad (when)
+import Control.Monad.Extra (mapMaybeM)
+import Data.Maybe (catMaybes, listToMaybe)
+import Data.Text (Text)
+import Data.Vector qualified as V
+import Data.Yaml as Y
+import Swarm.Game.Entity
+import Swarm.Game.Scenario.EntityFacade
+import Swarm.Game.Scenario.ScenarioUtil
+import Swarm.Game.Terrain
+import Swarm.Util.Yaml
+
+------------------------------------------------------------
+-- World cells
+------------------------------------------------------------
+
+data ProtoCell e = Cell
+  { cellTerrain :: TerrainType
+  , cellEntity :: Maybe e
+  , cellRobots :: [IndexedTRobot]
+  }
+  deriving (Eq, Show)
+
+-- | A single cell in a world map, which contains a terrain value,
+--   and optionally an entity and robot.
+type Cell = ProtoCell Entity
+
+-- Note: This is used only for the purpose of WorldPalette
+instance ToJSON Cell where
+  toJSON x =
+    toJSON $
+      catMaybes
+        [ Just $ toJSON $ getTerrainWord $ cellTerrain x
+        , toJSON . (^. entityName) <$> cellEntity x
+        , listToMaybe []
+        ]
+
+-- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'.  The
+--   entity and robot, if present, are immediately looked up and
+--   converted into 'Entity' and 'TRobot' values.  If they are not
+--   found, a parse error results.
+instance FromJSONE (EntityMap, RobotMap) Cell where
+  parseJSONE = withArrayE "tuple" $ \v -> do
+    let tup = V.toList v
+    when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)"
+
+    terr <- liftE $ parseJSON (head tup)
+
+    ent <- case tup ^? ix 1 of
+      Nothing -> return Nothing
+      Just e -> do
+        meName <- liftE $ parseJSON @(Maybe Text) e
+        traverse (localE fst . getEntity) meName
+
+    let name2rob r = do
+          mrName <- liftE $ parseJSON @(Maybe Text) r
+          traverse (localE snd . getRobot) mrName
+
+    robs <- mapMaybeM name2rob (drop 2 tup)
+
+    return $ Cell terr ent robs
+
+------------------------------------------------------------
+-- World editor
+------------------------------------------------------------
+
+type CellPaintDisplay = ProtoCell EntityFacadeData
+
+-- Note: This instance is used only for the purpose of WorldPalette
+instance ToJSON CellPaintDisplay where
+  toJSON x =
+    toJSON $
+      catMaybes
+        [ Just $ toJSON $ getTerrainWord $ cellTerrain x
+        , toJSON <$> cellEntity x
+        , listToMaybe []
+        ]

src/Swarm/Game/Scenario/EntityFacade.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE DerivingVia #-}
+
+module Swarm.Game.Scenario.EntityFacade where
+
+import Control.Lens hiding (from, (.=), (<.>))
+import Data.Text (Text)
+import Data.Yaml as Y
+import Swarm.Game.Display (Display)
+import Swarm.Game.Entity qualified as E
+
+type EntityName = Text
+
+data EntityFacadeData = EntityFacadeData EntityName Display
+  deriving (Eq)
+
+-- Note: This instance is used only for the purpose of WorldPalette
+instance ToJSON EntityFacadeData where
+  toJSON (EntityFacadeData eName _display) = toJSON eName
+
+mkPaint :: E.Entity -> EntityFacadeData
+mkPaint e =
+  EntityFacadeData
+    (e ^. E.entityName)
+    (e ^. E.entityDisplay)

src/Swarm/Game/Scenario/ScenarioUtil.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Swarm.Game.Scenario.ScenarioUtil where
+
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Text (Text)
+import Swarm.Game.Entity
+import Swarm.Game.Robot (TRobot)
+import Swarm.Util.Yaml
+
+------------------------------------------------------------
+-- Robot map
+------------------------------------------------------------
+
+-- | A robot template paired with its definition's index within
+-- the Scenario file
+type IndexedTRobot = (Int, TRobot)
+
+-- | A map from names to robots, used to look up robots in scenario
+--   descriptions.
+type RobotMap = Map Text IndexedTRobot
+
+------------------------------------------------------------
+-- Lookup utilities
+------------------------------------------------------------
+
+-- | Look up a thing by name, throwing a parse error if it is not
+--   found.
+getThing :: String -> (Text -> m -> Maybe a) -> Text -> ParserE m a
+getThing thing lkup name = do
+  m <- getE
+  case lkup name m of
+    Nothing -> fail $ "Unknown " <> thing <> " name: " ++ show name
+    Just a -> return a
+
+-- | Look up an entity by name in an 'EntityMap', throwing a parse
+--   error if it is not found.
+getEntity :: Text -> ParserE EntityMap Entity
+getEntity = getThing "entity" lookupEntityName
+
+-- | Look up a robot by name in a 'RobotMap', throwing a parse error
+--   if it is not found.
+getRobot :: Text -> ParserE RobotMap IndexedTRobot
+getRobot = getThing "robot" M.lookup