more comments, split module

src/Swarm/Game/Scenario/Cell.hs

@@ -82,6 +82,9 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
 -- World editor
 ------------------------------------------------------------
 
+-- | Stateless cells used for the World Editor.
+-- These cells contain the bare minimum display information
+-- for rendering.
 type CellPaintDisplay = PCell EntityFacade
 
 -- Note: This instance is used only for the purpose of WorldPalette

src/Swarm/Game/Scenario/EntityFacade.hs

@@ -19,6 +19,8 @@ type EntityName = Text
 -- | This datatype is a lightweight stand-in for the
 -- full-fledged "Entity" type without the baggage of all
 -- of its other fields.
+-- It contains the bare minimum display information
+-- for rendering.
 data EntityFacade = EntityFacade EntityName Display
   deriving (Eq)
 

src/Swarm/Game/Scenario/WorldDescription.hs

@@ -88,6 +88,8 @@ 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
 
 instance ToJSON WorldDescriptionPaint where
@@ -149,6 +151,9 @@ constructWorldMap mappedPairs =
    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']
 

src/Swarm/TUI/Controller/Util.hs

@@ -7,7 +7,7 @@ module Swarm.TUI.Controller.Util where
 import Brick hiding (Direction)
 import Brick.Focus
 import Control.Lens
-import Control.Monad (unless)
+import Control.Monad (forM_, unless)
 import Control.Monad.IO.Class (liftIO)
 import Graphics.Vty qualified as V
 import Swarm.Game.State
@@ -72,11 +72,9 @@ immediatelyRedrawWorld = do
 loadVisibleRegion :: EventM Name AppState ()
 loadVisibleRegion = do
   mext <- lookupExtent WorldExtent
-  case mext of
-    Nothing -> return ()
-    Just (Extent _ _ size) -> do
-      gs <- use gameState
-      gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size))
+  forM_ mext $ \(Extent _ _ size) -> do
+    gs <- use gameState
+    gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size))
 
 mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe W.Coords)
 mouseLocToWorldCoords (Brick.Location mouseLoc) = do

src/Swarm/TUI/Editor/Controller.hs

@@ -7,43 +7,23 @@ import Brick qualified as B
 import Brick.Focus
 import Brick.Widgets.List qualified as BL
 import Control.Lens
-import Control.Monad (guard, when)
+import Control.Monad (forM_, guard, when)
 import Control.Monad.Extra (whenJust)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
-import Data.Aeson.KeyMap qualified as KM
-import Data.List (sortOn)
-import Data.List.NonEmpty qualified as NE
-import Data.Map (Map)
 import Data.Map qualified as M
-import Data.Maybe (mapMaybe)
-import Data.Ord (Down (..))
-import Data.Set (Set)
-import Data.Set qualified as Set
-import Data.Text qualified as T
-import Data.Tuple (swap)
 import Data.Yaml qualified as Y
 import Graphics.Vty qualified as V
-import Swarm.Game.Display (Display, defaultChar)
-import Swarm.Game.Entity (entitiesByName)
-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.State
-import Swarm.Game.Terrain (TerrainType (BlankT), getTerrainDefaultPaletteChar)
 import Swarm.Game.World qualified as W
 import Swarm.TUI.Controller.Util
-import Swarm.TUI.Editor.Area (AreaDimensions (..), getAreaDimensions)
-import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario))
 import Swarm.TUI.Editor.Model
+import Swarm.TUI.Editor.Palette
 import Swarm.TUI.Editor.Util qualified as EU
 import Swarm.TUI.Model
 import Swarm.TUI.Model.Name
 import Swarm.TUI.Model.UI
-import Swarm.Util (binTuples, histogram)
-import Swarm.Util qualified as U
 import System.Clock
 
 ------------------------------------------------------------
@@ -104,14 +84,11 @@ handleMiddleClick mouseLoc = do
                   w
                   coords
           uiState . uiWorldEditor . terrainList %= BL.listMoveToElement terrain
-          case maybeElementPaint of
-            Nothing -> return ()
-            Just elementPaint ->
-              uiState . uiWorldEditor . entityPaintList %= BL.listMoveToElement p
-             where
-              p = case elementPaint of
-                Facade efd -> efd
-                Ref r -> mkFacade r
+          forM_ maybeElementPaint $ \elementPaint ->
+            let p = case elementPaint of
+                  Facade efd -> efd
+                  Ref r -> mkFacade r
+             in uiState . uiWorldEditor . entityPaintList %= BL.listMoveToElement p
 
     mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc
     whenJust mouseCoordsM setTerrainPaint
@@ -152,110 +129,6 @@ updateAreaBounds = \case
         return False
       SelectionComplete -> return True
 
-makeSuggestedPalette :: Maybe Scenario -> [[CellPaintDisplay]] -> KM.KeyMap CellPaintDisplay
-makeSuggestedPalette maybeOriginalScenario cellGrid =
-  KM.fromMapText $
-    M.fromList $
-      -- NOTE: the left-most maps take precedence!
-      M.elems (paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette)
- where
-  getMaybeEntityDisplay (Cell _terrain maybeEntity _) = do
-    EntityFacade eName d <- maybeEntity
-    return (eName, d)
-
-  getMaybeEntityNameTerrainPair (Cell terrain maybeEntity _) = do
-    EntityFacade eName _ <- maybeEntity
-    return (eName, terrain)
-
-  getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int)
-  getEntityTerrainMultiplicity =
-    M.map histogram $ binTuples $ concatMap (mapMaybe getMaybeEntityNameTerrainPair) cellGrid
-
-  usedEntityDisplays :: Map EntityName Display
-  usedEntityDisplays =
-    M.fromList $ concatMap (mapMaybe getMaybeEntityDisplay) cellGrid
-
-  -- Finds the most-used terrain type (the "mode" in the statistical sense)
-  -- paired with each entity
-  entitiesWithModalTerrain :: [(TerrainType, EntityName)]
-  entitiesWithModalTerrain =
-    map (swap . fmap (fst . NE.head))
-      . mapMaybe sequenceA
-      . M.toList
-      $ M.map (NE.nonEmpty . sortOn snd . M.toList) getEntityTerrainMultiplicity
-
-  invertPaletteMapToDedupe ::
-    Map a CellPaintDisplay ->
-    [(TerrainWith EntityName, (a, CellPaintDisplay))]
-  invertPaletteMapToDedupe =
-    map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList
-
-  paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
-  paletteCellsByKey =
-    M.map (NE.head . NE.sortWith toSortVal)
-      . binTuples
-      . invertPaletteMapToDedupe
-      $ KM.toMapText originalPalette
-   where
-    toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol)
-
-  excludedPaletteChars :: Set Char
-  excludedPaletteChars = Set.fromList [' ']
-
-  originalPalette :: KM.KeyMap CellPaintDisplay
-  originalPalette =
-    KM.map toCellPaintDisplay $
-      maybe mempty (unPalette . palette . (^. scenarioWorld)) maybeOriginalScenario
-
-  pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
-  pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain
-   where
-    g (terrain, eName) = do
-      eDisplay <- M.lookup eName usedEntityDisplays
-      let displayChar = eDisplay ^. defaultChar
-      guard $ Set.notMember displayChar excludedPaletteChars
-      let cell = Cell terrain (Just $ EntityFacade eName eDisplay) []
-      return ((terrain, Just eName), (T.singleton displayChar, cell))
-
-  -- TODO (#1153): Filter out terrain-only palette entries that aren't actually
-  -- used in the map.
-  terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
-  terrainOnlyPalette = M.fromList $ map f U.listEnums
-   where
-    f x = ((x, Nothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x Nothing []))
-
-constructScenario :: Maybe Scenario -> [[CellPaintDisplay]] -> SkeletonScenario
-constructScenario maybeOriginalScenario cellGrid =
-  SkeletonScenario
-    (maybe 1 (^. scenarioVersion) maybeOriginalScenario)
-    (maybe "My Scenario" (^. scenarioName) maybeOriginalScenario)
-    (maybe "The scenario description..." (^. scenarioDescription) maybeOriginalScenario)
-    -- (maybe True (^. scenarioCreative) maybeOriginalScenario)
-    True
-    (M.elems $ entitiesByName customEntities)
-    wd
-    [] -- robots
- where
-  customEntities = maybe mempty (^. scenarioEntities) maybeOriginalScenario
-  wd =
-    WorldDescription
-      { defaultTerrain = Just $ Cell BlankT Nothing []
-      , offsetOrigin = False
-      , scrollable = True
-      , palette = WorldPalette suggestedPalette
-      , ul = upperLeftCoord
-      , area = cellGrid
-      }
-
-  suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid
-
-  upperLeftCoord =
-    Location
-      (negate $ w `div` 2)
-      (h `div` 2)
-   where
-    AreaDimensions w h = getAreaDimensions cellGrid
-
 saveMapFile :: EventM Name AppState ()
 saveMapFile = do
   worldEditor <- use $ uiState . uiWorldEditor

src/Swarm/TUI/Editor/View.hs

@@ -81,7 +81,7 @@ drawWorldEditor toplevelFocusRing uis =
         <+> swatchContent (worldEditor ^. entityPaintList) drawLabeledEntitySwatch
 
   clearEntityButtonWidget =
-    if null (worldEditor ^. entityPaintList . BL.listSelectedL)
+    if null $ worldEditor ^. entityPaintList . BL.listSelectedL
       then emptyWidget
       else
         mkFormControl (WorldEditorPanelControl ClearEntityButton)

swarm.cabal

@@ -151,6 +151,7 @@ library
                       Swarm.TUI.Editor.Json
                       Swarm.TUI.Editor.Masking
                       Swarm.TUI.Editor.Model
+                      Swarm.TUI.Editor.Palette
                       Swarm.TUI.Editor.View
                       Swarm.TUI.Editor.Util
                       Swarm.TUI.Controller