From 871cce0628ca8743ff2007a3ed1718ba15bdca97 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 16:34:13 -0700 Subject: [PATCH] split off WorldPalette module --- src/Swarm/Game/Scenario/WorldDescription.hs | 115 +----------------- src/Swarm/Game/Scenario/WorldPalette.hs | 127 ++++++++++++++++++++ src/Swarm/TUI/Editor/Model.hs | 2 +- src/Swarm/TUI/Editor/Palette.hs | 4 +- swarm.cabal | 3 +- 5 files changed, 134 insertions(+), 117 deletions(-) create mode 100644 src/Swarm/Game/Scenario/WorldPalette.hs diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 33238205ba..7b117c1aac 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -5,24 +5,17 @@ -- 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) @@ -30,14 +23,6 @@ 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 diff --git a/src/Swarm/Game/Scenario/WorldPalette.hs b/src/Swarm/Game/Scenario/WorldPalette.hs new file mode 100644 index 0000000000..aa183c5050 --- /dev/null +++ b/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 diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs index cccd0ebe5c..2745349cee 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ b/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 diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs index a0047d3891..875b3ceed7 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ b/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)) diff --git a/swarm.cabal b/swarm.cabal index f4b2dfa5af..1944804030 100644 --- a/swarm.cabal +++ b/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