world editor prototype

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,7 +58,7 @@ 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.Lens hiding (from, (.=), (<.>))
 import Control.Monad (filterM)
 import Data.Maybe (catMaybes, isNothing, listToMaybe)
 import Data.Text (Text)

src/Swarm/Game/Scenario/Cell.hs

@@ -1,17 +1,17 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Swarm.Game.Scenario.Cell (
-  Cell (..),
-) where
+module Swarm.Game.Scenario.Cell where
 
-import Control.Lens hiding (from, (<.>))
+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.RobotLookup
 import Swarm.Game.Terrain
 import Swarm.Util.Yaml
@@ -20,15 +20,27 @@ import Swarm.Util.Yaml
 -- World cells
 ------------------------------------------------------------
 
--- | A single cell in a world map, which contains a terrain value,
---   and optionally an entity and robot.
-data Cell = Cell
+data ProtoCell e = Cell
   { cellTerrain :: TerrainType
-  , cellEntity :: Maybe Entity
+  , 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
@@ -53,3 +65,19 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
     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/WorldDescription.hs

@@ -3,17 +3,25 @@
 
 module Swarm.Game.Scenario.WorldDescription where
 
+import Control.Arrow (first)
+import Control.Lens hiding (from, (.=), (<.>))
 import Data.Aeson.Key qualified as Key
 import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.KeyMap qualified as KM
 import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Map qualified as M
+import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Tuple (swap)
 import Data.Yaml as Y
 import GHC.Int (Int64)
 import Linear.V2
 import Swarm.Game.Entity
 import Swarm.Game.Scenario.Cell
+import Swarm.Game.Scenario.EntityFacade
 import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Terrain (TerrainType)
 import Swarm.Util.Yaml
 import Witch (into)
 
@@ -22,23 +30,25 @@ import Witch (into)
 ------------------------------------------------------------
 
 -- | A world palette maps characters to 'Cell' values.
-newtype WorldPalette = WorldPalette
-  {unPalette :: KeyMap Cell}
+newtype WorldPalette c = WorldPalette
+  {unPalette :: KeyMap c}
   deriving (Eq, Show)
 
-instance FromJSONE (EntityMap, RobotMap) WorldPalette where
+instance FromJSONE (EntityMap, RobotMap) (WorldPalette Cell) where
   parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
 
 -- | A description of a world parsed from a YAML file.
-data WorldDescription = WorldDescription
-  { defaultTerrain :: Maybe Cell
+data ProtoWorldDescription c = WorldDescription
+  { defaultTerrain :: Maybe c
   , offsetOrigin :: Bool
-  , palette :: WorldPalette
+  , palette :: WorldPalette c
   , ul :: V2 Int64
-  , area :: [[Cell]]
+  , area :: [[c]]
   }
   deriving (Eq, Show)
 
+type WorldDescription = ProtoWorldDescription Cell
+
 instance FromJSONE (EntityMap, RobotMap) WorldDescription where
   parseJSONE = withObjectE "world description" $ \v -> do
     pal <- v ..:? "palette" ..!= WorldPalette mempty
@@ -53,9 +63,108 @@ instance FromJSONE (EntityMap, RobotMap) WorldDescription where
 --   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 :: MonadFail m => WorldPalette Cell -> 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
+
+------------------------------------------------------------
+-- World editor
+------------------------------------------------------------
+
+type TerrainEntityNamePair = (TerrainType, Maybe EntityName)
+
+type TerrainEntityFacadePair = (TerrainType, Maybe EntityFacadeData)
+
+cellToTerrainEntityNamePair :: CellPaintDisplay -> TerrainEntityFacadePair
+cellToTerrainEntityNamePair (Cell terrain maybeEntity _) = (terrain, maybeEntity)
+
+toCellPaintDisplay :: Cell -> CellPaintDisplay
+toCellPaintDisplay (Cell terrain maybeEntity r) =
+  Cell terrain (mkPaint <$> maybeEntity) r
+
+type WorldDescriptionPaint = ProtoWorldDescription CellPaintDisplay
+
+instance ToJSON WorldDescriptionPaint where
+  toJSON w =
+    object
+      [ "default" .= defaultTerrain w
+      , "offset" .= offsetOrigin w
+      , "palette" .= Y.toJSON paletteKeymap
+      , "upperleft" .= ul w
+      , "map" .= Y.toJSON mapText
+      ]
+   where
+    cellGrid = area w
+    suggestedPalette = palette w
+    (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid
+
+toKey :: TerrainEntityFacadePair -> TerrainEntityNamePair
+toKey = fmap $ fmap (\(EntityFacadeData eName _display) -> eName)
+
+getUniquePairs :: [[CellPaintDisplay]] -> M.Map TerrainEntityNamePair TerrainEntityFacadePair
+getUniquePairs cellGrid =
+  M.fromList $ concatMap (map genTuple) cellGrid
+ where
+  genTuple c =
+    (toKey terrainEfd, terrainEfd)
+   where
+    terrainEfd = cellToTerrainEntityNamePair c
+
+-- | Note that display characters are not unique
+-- across different entities! However, the palette KeyMap
+-- as a conveyance serves to dedupe them.
+prepForJson ::
+  WorldPalette CellPaintDisplay ->
+  [[CellPaintDisplay]] ->
+  (Text, KM.KeyMap CellPaintDisplay)
+prepForJson (WorldPalette suggestedPalette) cellGrid =
+  (renderFullMap cellGrid, paletteKeymap)
+ where
+  preassignments :: [(Char, TerrainEntityFacadePair)]
+  preassignments =
+    map (first T.head . fmap cellToTerrainEntityNamePair) $
+      M.toList $
+        KM.toMapText suggestedPalette
+
+  entityCells :: M.Map TerrainEntityNamePair TerrainEntityFacadePair
+  entityCells = getUniquePairs cellGrid
+
+  unassignedCells :: M.Map TerrainEntityNamePair TerrainEntityFacadePair
+  unassignedCells =
+    M.withoutKeys entityCells $
+      Set.fromList $
+        map (toKey . snd) preassignments
+
+  unassignedCharacters :: Set.Set Char
+  unassignedCharacters =
+    -- TODO: Make this pool larger?
+    Set.difference (Set.fromList ['a' .. 'z']) $
+      Set.fromList $
+        map fst preassignments
+
+  newlyAssignedPairs :: [(Char, TerrainEntityFacadePair)]
+  newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells
+
+  mappedPairs :: [(Char, TerrainEntityFacadePair)]
+  mappedPairs = preassignments <> newlyAssignedPairs
+
+  invertedMappedPairs :: [(TerrainEntityNamePair, Char)]
+  invertedMappedPairs = map (swap . fmap toKey) mappedPairs
+
+  renderMapCell c =
+    -- NOTE: This lookup should never fail
+    M.findWithDefault (error "Palette lookup failed!") k $
+      M.fromList invertedMappedPairs
+   where
+    k = toKey $ cellToTerrainEntityNamePair c
+
+  renderFullMap = T.unlines . map (T.pack . map renderMapCell)
+
+  g (terrain, maybeEfd) = Cell terrain maybeEfd []
+  terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs
+
+  paletteKeymap :: KM.KeyMap (ProtoCell EntityFacadeData)
+  paletteKeymap = KM.fromMapText terrainEntityPalette

src/Swarm/Game/Terrain.hs

@@ -10,6 +10,8 @@ module Swarm.Game.Terrain (
   -- * Terrain
   TerrainType (..),
   terrainMap,
+  getTerrainDefaultPaletteChar,
+  getTerrainWord,
 ) where
 
 import Data.Aeson (FromJSON (..), withText)
@@ -37,6 +39,12 @@ instance FromJSON TerrainType where
       Just ter -> return ter
       Nothing -> fail $ "Unknown terrain type: " ++ into @String t
 
+getTerrainDefaultPaletteChar :: TerrainType -> Char
+getTerrainDefaultPaletteChar = head . show
+
+getTerrainWord :: TerrainType -> T.Text
+getTerrainWord = T.toLower . T.pack . init . show
+
 -- | A map containing a 'Display' record for each different 'TerrainType'.
 terrainMap :: Map TerrainType Display
 terrainMap =