split off WorldPalette module

src/Swarm/Game/Scenario/WorldDescription.hs

@@ -5,39 +5,24 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 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 Swarm.Game.Entity
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Cell
 import Swarm.Game.Scenario.EntityFacade
 import Swarm.Game.Scenario.RobotLookup
-import Swarm.Game.Terrain (TerrainType)
+import Swarm.Game.Scenario.WorldPalette
 import Swarm.Util.Yaml
 import Witch (into)
 
 ------------------------------------------------------------
 -- World description
 ------------------------------------------------------------
 
--- | A world palette maps characters to 'Cell' values.
-newtype WorldPalette e = WorldPalette
-  {unPalette :: KeyMap (PCell e)}
-  deriving (Eq, Show)
-
-instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
-  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
-
 -- | A description of a world parsed from a YAML file.
 -- This type is parameterized to accommodate Cells that
 -- utilize a less stateful Entity type.
@@ -79,15 +64,6 @@ paintMap pal = traverse (traverse toCell . into @String) . T.lines
 -- World editor
 ------------------------------------------------------------
 
-type TerrainWith a = (TerrainType, Maybe a)
-
-cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
-cellToTerrainPair (Cell terrain maybeEntity _) = (terrain, maybeEntity)
-
-toCellPaintDisplay :: Cell -> CellPaintDisplay
-toCellPaintDisplay (Cell terrain maybeEntity r) =
-  Cell terrain (mkFacade <$> maybeEntity) r
-
 -- | A pared-down (stateless) version of "WorldDescription" just for
 -- the purpose of rendering a Scenario file
 type WorldDescriptionPaint = PWorldDescription EntityFacade
@@ -105,92 +81,3 @@ instance ToJSON WorldDescriptionPaint where
     cellGrid = area w
     suggestedPalette = palette w
     (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid
-
-toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
-toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName)
-
--- | We want to identify all of the unique (terrain, entity facade) pairs.
--- However, "EntityFacade" includes a "Display" record, which contains more
--- fields than desirable for use as a unique key.
--- Therefore, we extract just the entity name for use in a
--- (terrain, entity name) key, and couple it with the original
--- (terrain, entity facade) pair in a Map.
-getUniqueTerrainFacadePairs ::
-  [[CellPaintDisplay]] ->
-  M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
-getUniqueTerrainFacadePairs cellGrid =
-  M.fromList $ concatMap (map genTuple) cellGrid
- where
-  genTuple c =
-    (toKey terrainEfd, terrainEfd)
-   where
-    terrainEfd = cellToTerrainPair c
-
-constructPalette ::
-  [(Char, TerrainWith EntityFacade)] ->
-  KM.KeyMap CellPaintDisplay
-constructPalette mappedPairs =
-  KM.fromMapText terrainEntityPalette
- where
-  g (terrain, maybeEfd) = Cell terrain maybeEfd []
-  terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs
-
-constructWorldMap ::
-  [(Char, TerrainWith EntityFacade)] ->
-  [[CellPaintDisplay]] ->
-  Text
-constructWorldMap mappedPairs =
-  T.unlines . map (T.pack . map renderMapCell)
- where
-  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 $ cellToTerrainPair c
-
--- | All alphanumeric characters. These are used as supplemental
--- map placeholders in case a pre-existing display character is
--- not available to re-use.
-genericCharacterPool :: Set.Set Char
-genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9']
-
--- | Note that display characters are not unique
--- across different entities! However, the palette KeyMap
--- as a conveyance serves to dedupe them.
-prepForJson ::
-  WorldPalette EntityFacade ->
-  [[CellPaintDisplay]] ->
-  (Text, KM.KeyMap CellPaintDisplay)
-prepForJson (WorldPalette suggestedPalette) cellGrid =
-  (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs)
- where
-  preassignments :: [(Char, TerrainWith EntityFacade)]
-  preassignments =
-    map (first T.head . fmap cellToTerrainPair) $
-      M.toList $
-        KM.toMapText suggestedPalette
-
-  entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
-  entityCells = getUniqueTerrainFacadePairs cellGrid
-
-  unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
-  unassignedCells =
-    M.withoutKeys entityCells $
-      Set.fromList $
-        map (toKey . snd) preassignments
-
-  unassignedCharacters :: Set.Set Char
-  unassignedCharacters =
-    -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char")
-    -- to generate this pool?
-    Set.difference genericCharacterPool $
-      Set.fromList $
-        map fst preassignments
-
-  newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
-  newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells
-
-  mappedPairs = preassignments <> newlyAssignedPairs

src/Swarm/Game/Scenario/WorldPalette.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Game.Scenario.WorldPalette where
+
+import Control.Arrow (first)
+import Control.Lens hiding (from, (.=), (<.>))
+import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.KeyMap qualified as KM
+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 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
+
+-- | A world palette maps characters to 'Cell' values.
+newtype WorldPalette e = WorldPalette
+  {unPalette :: KeyMap (PCell e)}
+  deriving (Eq, Show)
+
+instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
+  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
+
+type TerrainWith a = (TerrainType, Maybe a)
+
+cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
+cellToTerrainPair (Cell terrain maybeEntity _) = (terrain, maybeEntity)
+
+toCellPaintDisplay :: Cell -> CellPaintDisplay
+toCellPaintDisplay (Cell terrain maybeEntity r) =
+  Cell terrain (mkFacade <$> maybeEntity) r
+
+toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
+toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName)
+
+-- | We want to identify all of the unique (terrain, entity facade) pairs.
+-- However, "EntityFacade" includes a "Display" record, which contains more
+-- fields than desirable for use as a unique key.
+-- Therefore, we extract just the entity name for use in a
+-- (terrain, entity name) key, and couple it with the original
+-- (terrain, entity facade) pair in a Map.
+getUniqueTerrainFacadePairs ::
+  [[CellPaintDisplay]] ->
+  M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
+getUniqueTerrainFacadePairs cellGrid =
+  M.fromList $ concatMap (map genTuple) cellGrid
+ where
+  genTuple c =
+    (toKey terrainEfd, terrainEfd)
+   where
+    terrainEfd = cellToTerrainPair c
+
+constructPalette ::
+  [(Char, TerrainWith EntityFacade)] ->
+  KM.KeyMap CellPaintDisplay
+constructPalette mappedPairs =
+  KM.fromMapText terrainEntityPalette
+ where
+  g (terrain, maybeEfd) = Cell terrain maybeEfd []
+  terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs
+
+constructWorldMap ::
+  [(Char, TerrainWith EntityFacade)] ->
+  [[CellPaintDisplay]] ->
+  Text
+constructWorldMap mappedPairs =
+  T.unlines . map (T.pack . map renderMapCell)
+ where
+  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 $ cellToTerrainPair c
+
+-- | All alphanumeric characters. These are used as supplemental
+-- map placeholders in case a pre-existing display character is
+-- not available to re-use.
+genericCharacterPool :: Set.Set Char
+genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9']
+
+-- | Note that display characters are not unique
+-- across different entities! However, the palette KeyMap
+-- as a conveyance serves to dedupe them.
+prepForJson ::
+  WorldPalette EntityFacade ->
+  [[CellPaintDisplay]] ->
+  (Text, KM.KeyMap CellPaintDisplay)
+prepForJson (WorldPalette suggestedPalette) cellGrid =
+  (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs)
+ where
+  preassignments :: [(Char, TerrainWith EntityFacade)]
+  preassignments =
+    map (first T.head . fmap cellToTerrainPair) $
+      M.toList $
+        KM.toMapText suggestedPalette
+
+  entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
+  entityCells = getUniqueTerrainFacadePairs cellGrid
+
+  unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
+  unassignedCells =
+    M.withoutKeys entityCells $
+      Set.fromList $
+        map (toKey . snd) preassignments
+
+  unassignedCharacters :: Set.Set Char
+  unassignedCharacters =
+    -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char")
+    -- to generate this pool?
+    Set.difference genericCharacterPool $
+      Set.fromList $
+        map fst preassignments
+
+  newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
+  newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells
+
+  mappedPairs = preassignments <> newlyAssignedPairs

src/Swarm/TUI/Editor/Model.hs

@@ -11,7 +11,7 @@ import Data.Vector qualified as V
 import Swarm.Game.Display (Display)
 import Swarm.Game.Entity qualified as E
 import Swarm.Game.Scenario.EntityFacade
-import Swarm.Game.Scenario.WorldDescription
+import Swarm.Game.Scenario.WorldPalette
 import Swarm.Game.Terrain (TerrainType)
 import Swarm.Game.World qualified as W
 import Swarm.TUI.Model.Name

src/Swarm/TUI/Editor/Palette.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.TUI.Editor.Palette where
 
 import Control.Lens
@@ -21,7 +23,7 @@ import Swarm.Game.Location
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Cell
 import Swarm.Game.Scenario.EntityFacade
-import Swarm.Game.Scenario.WorldDescription
+import Swarm.Game.Scenario.WorldPalette
 import Swarm.Game.Terrain (TerrainType (BlankT), getTerrainDefaultPaletteChar)
 import Swarm.TUI.Editor.Area (AreaDimensions (..), getAreaDimensions)
 import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario))

swarm.cabal

@@ -117,6 +117,7 @@ library
                       Swarm.Game.Scenario.Status
                       Swarm.Game.Scenario.Style
                       Swarm.Game.Scenario.WorldDescription
+                      Swarm.Game.Scenario.WorldPalette
                       Swarm.Game.ScenarioInfo
                       Swarm.Game.State
                       Swarm.Game.Step
@@ -152,8 +153,8 @@ library
                       Swarm.TUI.Editor.Masking
                       Swarm.TUI.Editor.Model
                       Swarm.TUI.Editor.Palette
-                      Swarm.TUI.Editor.View
                       Swarm.TUI.Editor.Util
+                      Swarm.TUI.Editor.View
                       Swarm.TUI.Controller
                       Swarm.TUI.Controller.Util
                       Swarm.TUI.Inventory.Sorting