From bebb9f27292f562f4e212792f8a36fdc89464d28 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Fri, 9 Jun 2023 10:44:50 -0700 Subject: [PATCH 01/11] resolve merge conflicts --- src/Swarm/Game/Scenario.hs | 4 +- src/Swarm/Game/Scenario/Cell.hs | 30 ++- src/Swarm/Game/Scenario/EntityFacade.hs | 24 ++ src/Swarm/Game/Scenario/WorldDescription.hs | 117 +++++++++ src/Swarm/Game/State.hs | 3 +- src/Swarm/Game/Terrain.hs | 8 + src/Swarm/TUI/Controller.hs | 73 +++--- src/Swarm/TUI/Controller/Util.hs | 30 +++ src/Swarm/TUI/Editor/Area.hs | 48 ++++ src/Swarm/TUI/Editor/Controller.hs | 270 ++++++++++++++++++++ src/Swarm/TUI/Editor/Json.hs | 20 ++ src/Swarm/TUI/Editor/Masking.hs | 30 +++ src/Swarm/TUI/Editor/Model.hs | 91 +++++++ src/Swarm/TUI/Editor/Util.hs | 118 +++++++++ src/Swarm/TUI/Editor/View.hs | 159 ++++++++++++ src/Swarm/TUI/Model/Menu.hs | 2 + src/Swarm/TUI/Model/Name.hs | 21 ++ src/Swarm/TUI/Model/StateUpdate.hs | 25 +- src/Swarm/TUI/Model/UI.hs | 10 + src/Swarm/TUI/View.hs | 44 ++-- src/Swarm/TUI/View/CellDisplay.hs | 59 +++-- src/Swarm/TUI/View/Util.hs | 23 +- src/Swarm/Util.hs | 12 +- swarm.cabal | 9 + 24 files changed, 1152 insertions(+), 78 deletions(-) create mode 100644 src/Swarm/Game/Scenario/EntityFacade.hs create mode 100644 src/Swarm/TUI/Editor/Area.hs create mode 100644 src/Swarm/TUI/Editor/Controller.hs create mode 100644 src/Swarm/TUI/Editor/Json.hs create mode 100644 src/Swarm/TUI/Editor/Masking.hs create mode 100644 src/Swarm/TUI/Editor/Model.hs create mode 100644 src/Swarm/TUI/Editor/Util.hs create mode 100644 src/Swarm/TUI/Editor/View.hs diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index a8587e97a..6534ffc21 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -20,7 +20,7 @@ module Swarm.Game.Scenario ( IndexedTRobot, -- * Scenario - Scenario, + Scenario (..), -- ** Fields scenarioVersion, @@ -45,7 +45,7 @@ module Swarm.Game.Scenario ( getScenarioPath, ) where -import Control.Lens hiding (from, (<.>)) +import Control.Lens hiding (from, (.=), (<.>)) import Control.Monad (filterM) import Control.Monad.Except (ExceptT (..), MonadIO, liftIO, runExceptT, withExceptT) import Control.Monad.Trans.Except (except) diff --git a/src/Swarm/Game/Scenario/Cell.hs b/src/Swarm/Game/Scenario/Cell.hs index aa23af553..32ffd0fc7 100644 --- a/src/Swarm/Game/Scenario/Cell.hs +++ b/src/Swarm/Game/Scenario/Cell.hs @@ -6,15 +6,18 @@ module Swarm.Game.Scenario.Cell ( PCell (..), Cell, + CellPaintDisplay, ) 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 @@ -38,6 +41,15 @@ data PCell e = Cell -- and optionally an entity and robot. type Cell = PCell Entity +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 @@ -62,3 +74,19 @@ instance FromJSONE (EntityMap, RobotMap) Cell where robs <- mapMaybeM name2rob (drop 2 tup) return $ Cell terr ent robs + +------------------------------------------------------------ +-- World editor +------------------------------------------------------------ + +type CellPaintDisplay = PCell EntityFacade + +-- 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 [] + ] diff --git a/src/Swarm/Game/Scenario/EntityFacade.hs b/src/Swarm/Game/Scenario/EntityFacade.hs new file mode 100644 index 000000000..b04bc30c8 --- /dev/null +++ b/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 EntityFacade = EntityFacade EntityName Display + deriving (Eq) + +-- Note: This instance is used only for the purpose of WorldPalette +instance ToJSON EntityFacade where + toJSON (EntityFacade eName _display) = toJSON eName + +mkPaint :: E.Entity -> EntityFacade +mkPaint e = + EntityFacade + (e ^. E.entityName) + (e ^. E.entityDisplay) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 50f77b88b..f2ba7f763 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -5,16 +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.Util.Yaml import Witch (into) @@ -66,3 +74,112 @@ paintMap pal = traverse (traverse toCell . into @String) . T.lines 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 EntityFacade) + +cellToTerrainEntityNamePair :: CellPaintDisplay -> TerrainEntityFacadePair +cellToTerrainEntityNamePair (Cell terrain maybeEntity _) = (terrain, maybeEntity) + +toCellPaintDisplay :: Cell -> CellPaintDisplay +toCellPaintDisplay (Cell terrain maybeEntity r) = + Cell terrain (mkPaint <$> maybeEntity) r + +type WorldDescriptionPaint = PWorldDescription EntityFacade + +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 (\(EntityFacade 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 + +constructPalette :: + [(Char, TerrainEntityFacadePair)] -> + 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, TerrainEntityFacadePair)] -> + [[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 $ cellToTerrainEntityNamePair c + +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, 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: 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, TerrainEntityFacadePair)] + newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells + + mappedPairs = preassignments <> newlyAssignedPairs diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index f33cb6b9a..96b035119 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -177,6 +177,7 @@ import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst) import Swarm.Language.Typed (Typed (Typed)) import Swarm.Language.Types import Swarm.Language.Value (Value) +import Swarm.TUI.Editor.Model (BoundsRectangle) import Swarm.Util (uniq, (<+=), (<<.=), (?)) import Swarm.Util.Lens (makeLensesExcluding) import System.Clock qualified as Clock @@ -719,7 +720,7 @@ unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id -- | Given a width and height, compute the region, centered on the -- 'viewCenter', that should currently be in view. -viewingRegion :: GameState -> (Int32, Int32) -> (W.Coords, W.Coords) +viewingRegion :: GameState -> (Int32, Int32) -> BoundsRectangle viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) where Location cx cy = g ^. viewCenter diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs index 8f41bca4a..c7004a063 100644 --- a/src/Swarm/Game/Terrain.hs +++ b/src/Swarm/Game/Terrain.hs @@ -8,6 +8,8 @@ module Swarm.Game.Terrain ( -- * Terrain TerrainType (..), terrainMap, + getTerrainDefaultPaletteChar, + getTerrainWord, ) where import Data.Aeson (FromJSON (..), withText) @@ -35,6 +37,12 @@ instance FromJSON TerrainType where Just ter -> return ter Nothing -> failT ["Unknown terrain type:", 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 = diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index a9eea2852..9ef72e00f 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -39,7 +39,6 @@ module Swarm.TUI.Controller ( ) where import Brick hiding (Direction, Location) -import Brick qualified import Brick.Focus import Brick.Widgets.Dialog import Brick.Widgets.Edit (handleEditorEvent) @@ -77,7 +76,6 @@ import Swarm.Game.Robot import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.Step (finishGameTick, gameTick) -import Swarm.Game.World qualified as W import Swarm.Language.Capability (Capability (CDebug, CMake)) import Swarm.Language.Context import Swarm.Language.Key (KeyCombo, mkKeyCombo) @@ -92,6 +90,8 @@ import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult) import Swarm.TUI.Controller.Util +import Swarm.TUI.Editor.Controller qualified as EC +import Swarm.TUI.Editor.Model import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) import Swarm.TUI.Launch.Controller import Swarm.TUI.Launch.Model @@ -103,8 +103,8 @@ import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl import Swarm.TUI.Model.StateUpdate import Swarm.TUI.Model.UI -import Swarm.TUI.View (generateModal) import Swarm.TUI.View.Objective qualified as GR +import Swarm.TUI.View.Util (generateModal) import Swarm.Util hiding (both, (<<.=)) import Swarm.Version (NewReleaseFailure (..)) import System.Clock @@ -351,8 +351,27 @@ handleMainEvent ev = do VtyEvent vev | isJust (s ^. uiState . uiModal) -> handleModalEvent vev -- toggle creative mode if in "cheat mode" + + MouseDown (TerrainListItem pos) V.BLeft _ _ -> + uiState . uiWorldEditor . terrainList %= BL.listMoveTo pos + MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> + uiState . uiWorldEditor . entityPaintList %= BL.listMoveTo pos ControlChar 'v' | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not + -- toggle world editor mode if in "cheat mode" + ControlChar 'e' + | s ^. uiState . uiCheatMode -> do + uiState . uiWorldEditor . isWorldEditorEnabled %= not + setFocus WorldEditorPanel + MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> + -- Eye Dropper tool + EC.handleMiddleClick mouseLoc + MouseDown (FocusablePanel WorldPanel) V.BRight _ mouseLoc -> + -- Eraser tool + EC.handleRightClick mouseLoc + MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc -> + -- Paint with the World Editor + EC.handleCtrlLeftClick mouseLoc -- toggle collapse/expand REPL ControlChar 's' -> do invalidateCacheEntry WorldCache @@ -360,13 +379,18 @@ handleMainEvent ev = do MouseDown n _ _ mouseLoc -> case n of FocusablePanel WorldPanel -> do - mouseCoordsM <- Brick.zoom gameState (mouseLocToWorldCoords mouseLoc) - uiState . uiWorldCursor .= mouseCoordsM + mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + shouldUpdateCursor <- EC.updateAreaBounds mouseCoordsM + when shouldUpdateCursor $ + uiState . uiWorldCursor .= mouseCoordsM REPLInput -> handleREPLEvent ev _ -> continueWithoutRedraw MouseUp n _ _mouseLoc -> do case n of InventoryListItem pos -> uiState . uiInventory . traverse . _2 %= BL.listMoveTo pos + x@(WorldEditorPanelControl y) -> do + uiState . uiWorldEditor . editorFocusRing %= focusSetCurrent x + EC.activateWorldEditorFunction y _ -> return () flip whenJust setFocus $ case n of -- Adapt click event origin to their right panel. @@ -377,6 +401,7 @@ handleMainEvent ev = do InventoryListItem _ -> Just RobotPanel InfoViewport -> Just InfoPanel REPLInput -> Just REPLPanel + WorldEditorPanelControl _ -> Just WorldEditorPanel _ -> Nothing case n of FocusablePanel x -> setFocus x @@ -388,23 +413,11 @@ handleMainEvent ev = do Just (FocusablePanel x) -> ($ ev) $ case x of REPLPanel -> handleREPLEvent WorldPanel -> handleWorldEvent + WorldEditorPanel -> EC.handleWorldEditorPanelEvent RobotPanel -> handleRobotPanelEvent InfoPanel -> handleInfoPanelEvent infoScroll _ -> continueWithoutRedraw -mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe W.Coords) -mouseLocToWorldCoords (Brick.Location mouseLoc) = do - mext <- lookupExtent WorldExtent - case mext of - Nothing -> pure Nothing - Just ext -> do - region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) - let regionStart = W.unCoords (fst region) - mouseLoc' = bimap fromIntegral fromIntegral mouseLoc - mx = snd mouseLoc' + fst regionStart - my = fst mouseLoc' + snd regionStart - in pure . Just $ W.Coords (mx, my) - -- | Set the game to Running if it was (auto) paused otherwise to paused. -- -- Also resets the last frame time to now. If we are pausing, it @@ -450,6 +463,14 @@ handleModalEvent = \case Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev) modal <- preuse $ uiState . uiModal . _Just . modalType case modal of + Just TerrainPaletteModal -> do + lw <- use $ uiState . uiWorldEditor . terrainList + newList <- refreshList lw + uiState . uiWorldEditor . terrainList .= newList + Just EntityPaletteModal -> do + lw <- use $ uiState . uiWorldEditor . entityPaintList + newList <- refreshList lw + uiState . uiWorldEditor . entityPaintList .= newList Just GoalModal -> case ev of V.EvKey (V.KChar '\t') [] -> uiState . uiGoal . focus %= focusNext _ -> do @@ -458,13 +479,14 @@ handleModalEvent = \case Just (GoalWidgets w) -> case w of ObjectivesList -> do lw <- use $ uiState . uiGoal . listWidget - newList <- refreshList lw + newList <- refreshGoalList lw uiState . uiGoal . listWidget .= newList GoalSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) where - refreshList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection + refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection + refreshList w = nestEventM' w $ BL.handleListEvent ev getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) getNormalizedCurrentScenarioPath = @@ -928,17 +950,6 @@ doGoalUpdates = do return goalWasUpdated --- | Make sure all tiles covering the visible part of the world are --- loaded. -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)) - -- | Strips top-level `cmd` from type (in case of REPL evaluation), -- and returns a boolean to indicate if it happened stripCmd :: Polytype -> Polytype diff --git a/src/Swarm/TUI/Controller/Util.hs b/src/Swarm/TUI/Controller/Util.hs index eb4080e5b..f2b0800e7 100644 --- a/src/Swarm/TUI/Controller/Util.hs +++ b/src/Swarm/TUI/Controller/Util.hs @@ -11,6 +11,7 @@ import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Graphics.Vty qualified as V import Swarm.Game.State +import Swarm.Game.World qualified as W import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) @@ -63,3 +64,32 @@ isRunningModal = \case setFocus :: FocusablePanel -> EventM Name AppState () setFocus name = uiState . uiFocusRing %= focusSetCurrent (FocusablePanel name) + +immediatelyRedrawWorld :: EventM Name AppState () +immediatelyRedrawWorld = do + invalidateCacheEntry WorldCache + loadVisibleRegion + +-- | Make sure all tiles covering the visible part of the world are +-- loaded. +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)) + +mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe W.Coords) +mouseLocToWorldCoords (Brick.Location mouseLoc) = do + mext <- lookupExtent WorldExtent + case mext of + Nothing -> pure Nothing + Just ext -> do + region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) + let regionStart = W.unCoords (fst region) + mouseLoc' = bimap fromIntegral fromIntegral mouseLoc + mx = snd mouseLoc' + fst regionStart + my = fst mouseLoc' + snd regionStart + in pure . Just $ W.Coords (mx, my) diff --git a/src/Swarm/TUI/Editor/Area.hs b/src/Swarm/TUI/Editor/Area.hs new file mode 100644 index 000000000..675fe405a --- /dev/null +++ b/src/Swarm/TUI/Editor/Area.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.Editor.Area where + +import Data.Int (Int32) +import Data.List qualified as L +import Data.Maybe (listToMaybe) +import Linear (V2 (..)) +import Swarm.Game.Location + +data AreaDimensions = AreaDimensions + { rectWidth :: Int32 + , rectHeight :: Int32 + } + +renderRectDimensions :: AreaDimensions -> String +renderRectDimensions (AreaDimensions w h) = + L.intercalate "x" $ map show [w, h] + +invertY :: V2 Int32 -> V2 Int32 +invertY (V2 x y) = V2 x (-y) + +-- | Incorporates an offset by -1, since the area is +-- "inclusive" of the lower-right coordinate. +upperLeftToBottomRight :: AreaDimensions -> Location -> Location +upperLeftToBottomRight (AreaDimensions w h) upperLeft = + upperLeft .+^ displacement + where + displacement = invertY $ subtract 1 <$> V2 w h + +-- | Converts the displacement vector between the two +-- diagonal corners of the rectangle into an "AreaDimensions" record. +-- Adds one to both dimensions since the corner coordinates are "inclusive". +cornersToArea :: Location -> Location -> AreaDimensions +cornersToArea upperLeft lowerRight = + AreaDimensions x y + where + V2 x y = (+ 1) <$> invertY (lowerRight .-. upperLeft) + +isEmpty :: AreaDimensions -> Bool +isEmpty (AreaDimensions w h) = w == 0 || h == 0 + +getAreaDimensions :: [[a]] -> AreaDimensions +getAreaDimensions cellGrid = + AreaDimensions w h + where + w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid -- column count + h = fromIntegral $ length cellGrid -- row count diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs new file mode 100644 index 000000000..feb43173f --- /dev/null +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.Editor.Controller where + +import Brick hiding (Direction (..), Location (..)) +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.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.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 + +------------------------------------------------------------ +-- World Editor panel events +------------------------------------------------------------ + +activateWorldEditorFunction :: WorldEditorFocusable -> EventM Name AppState () +activateWorldEditorFunction BrushSelector = openModal TerrainPaletteModal +activateWorldEditorFunction EntitySelector = openModal EntityPaletteModal +activateWorldEditorFunction AreaSelector = do + selectorStage <- use $ uiState . uiWorldEditor . editingBounds . boundsSelectionStep + case selectorStage of + SelectionComplete -> uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= UpperLeftPending + _ -> return () +activateWorldEditorFunction OutputPathSelector = + -- TODO + liftIO $ putStrLn "File selection" +activateWorldEditorFunction MapSaveButton = saveMapFile +activateWorldEditorFunction ClearEntityButton = + uiState . uiWorldEditor . entityPaintList . BL.listSelectedL .= Nothing + +handleCtrlLeftClick :: B.Location -> EventM Name AppState () +handleCtrlLeftClick mouseLoc = do + worldEditor <- use $ uiState . uiWorldEditor + _ <- runMaybeT $ do + guard $ worldEditor ^. isWorldEditorEnabled + let getSelected x = snd <$> BL.listSelectedElement x + maybeTerrainType = getSelected $ worldEditor ^. terrainList + maybeEntityPaint = getSelected $ worldEditor ^. entityPaintList + -- TODO: Use hoistMaybe when available + terrain <- MaybeT . pure $ maybeTerrainType + mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + uiState . uiWorldEditor . paintedTerrain %= M.insert mouseCoords (terrain, maybeEntityPaint) + uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing + immediatelyRedrawWorld + return () + +handleRightClick :: B.Location -> EventM Name AppState () +handleRightClick mouseLoc = do + worldEditor <- use $ uiState . uiWorldEditor + _ <- runMaybeT $ do + guard $ worldEditor ^. isWorldEditorEnabled + mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + uiState . uiWorldEditor . paintedTerrain %= M.delete mouseCoords + immediatelyRedrawWorld + return () + +-- | "Eye Dropper" tool: +handleMiddleClick :: B.Location -> EventM Name AppState () +handleMiddleClick mouseLoc = do + worldEditor <- use $ uiState . uiWorldEditor + when (worldEditor ^. isWorldEditorEnabled) $ do + w <- use $ gameState . world + let setTerrainPaint coords = do + let (terrain, maybeElementPaint) = + EU.getContentAt + worldEditor + 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 -> mkPaint r + + mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + whenJust mouseCoordsM setTerrainPaint + +-- | Handle user input events in the robot panel. +handleWorldEditorPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleWorldEditorPanelEvent = \case + Key V.KEsc -> uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete + Key V.KEnter -> do + fring <- use $ uiState . uiWorldEditor . editorFocusRing + case focusGetCurrent fring of + Just (WorldEditorPanelControl x) -> activateWorldEditorFunction x + _ -> return () + ControlChar 's' -> saveMapFile + CharKey '\t' -> uiState . uiWorldEditor . editorFocusRing %= focusNext + Key V.KBackTab -> uiState . uiWorldEditor . editorFocusRing %= focusPrev + _ -> return () + +-- | Return value: whether the cursor position should be updated +updateAreaBounds :: Maybe W.Coords -> EventM Name AppState Bool +updateAreaBounds = \case + Nothing -> return True + Just mouseCoords -> do + selectorStage <- use $ uiState . uiWorldEditor . editingBounds . boundsSelectionStep + case selectorStage of + UpperLeftPending -> do + uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= LowerRightPending mouseCoords + return False + -- TODO: Validate that the lower-right click is below and to the right of the top-left coord + LowerRightPending upperLeftMouseCoords -> do + uiState . uiWorldEditor . editingBounds . boundsRect + .= Just (upperLeftMouseCoords, mouseCoords) + uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing + uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete + t <- liftIO $ getTime Monotonic + uiState . uiWorldEditor . editingBounds . boundsPersistDisplayUntil .= t + TimeSpec 2 0 + setFocus WorldEditorPanel + 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 -> + [(TerrainEntityNamePair, (a, CellPaintDisplay))] + invertPaletteMapToDedupe = + map (\x@(_, c) -> (toKey $ cellToTerrainEntityNamePair c, x)) . M.toList + + paletteCellsByKey :: Map TerrainEntityNamePair (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 TerrainEntityNamePair (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: Filter out terrain-only palette entries that aren't actually + -- used in the map. + terrainOnlyPalette :: Map TerrainEntityNamePair (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 + maybeBounds <- use $ uiState . uiWorldEditor . editingBounds . boundsRect + w <- use $ gameState . world + let mapCellGrid = EU.getEditedMapRectangle worldEditor maybeBounds w + + let fp = worldEditor ^. outputFilePath + maybeScenarioPair <- use $ uiState . scenarioRef + liftIO $ Y.encodeFile fp $ constructScenario (fst <$> maybeScenarioPair) mapCellGrid + + uiState . uiWorldEditor . lastWorldEditorMessage .= Just "Saved." diff --git a/src/Swarm/TUI/Editor/Json.hs b/src/Swarm/TUI/Editor/Json.hs new file mode 100644 index 000000000..24e33fdc9 --- /dev/null +++ b/src/Swarm/TUI/Editor/Json.hs @@ -0,0 +1,20 @@ +module Swarm.TUI.Editor.Json where + +import Data.Text (Text) +import Data.Yaml as Y +import GHC.Generics (Generic) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Scenario.WorldDescription + +data SkeletonScenario = SkeletonScenario + { version :: Int + , name :: Text + , description :: Text + , creative :: Bool + , entities :: [Entity] + , world :: WorldDescriptionPaint + , robots :: [String] + } + deriving (Generic) + +instance ToJSON SkeletonScenario diff --git a/src/Swarm/TUI/Editor/Masking.hs b/src/Swarm/TUI/Editor/Masking.hs new file mode 100644 index 000000000..93274e5e5 --- /dev/null +++ b/src/Swarm/TUI/Editor/Masking.hs @@ -0,0 +1,30 @@ +module Swarm.TUI.Editor.Masking where + +import Control.Lens hiding (Const, from) +import Data.Maybe (fromMaybe) +import Swarm.Game.World qualified as W +import Swarm.TUI.Editor.Model +import Swarm.TUI.Editor.Util qualified as EU +import Swarm.TUI.Model.UI + +shouldHideWorldCell :: UIState -> W.Coords -> Bool +shouldHideWorldCell ui coords = + isOutsideSingleSelectedCorner || isOutsideMapSaveBounds + where + we = ui ^. uiWorldEditor + withinTimeout = ui ^. lastFrameTime < we ^. editingBounds . boundsPersistDisplayUntil + + isOutsideMapSaveBounds = + withinTimeout + && fromMaybe + False + ( do + bounds <- we ^. editingBounds . boundsRect + pure $ EU.isOutsideRegion bounds coords + ) + + isOutsideSingleSelectedCorner = fromMaybe False $ do + cornerCoords <- case we ^. editingBounds . boundsSelectionStep of + LowerRightPending cornerCoords -> Just cornerCoords + _ -> Nothing + pure $ EU.isOutsideTopLeftCorner cornerCoords coords diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs new file mode 100644 index 000000000..dbc68eb18 --- /dev/null +++ b/src/Swarm/TUI/Editor/Model.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Swarm.TUI.Editor.Model where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (from, (.=), (<.>)) +import Data.Map qualified as M +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.Terrain (TerrainType) +import Swarm.Game.World qualified as W +import Swarm.TUI.Model.Name +import Swarm.Util +import System.Clock + +-- | Represents the top-left and bottom-right coordinates +-- of a bounding rectangle of cells in the world map +type BoundsRectangle = (W.Coords, W.Coords) + +data BoundsSelectionStep + = UpperLeftPending + | -- | Stores the *world coords* of the upper-left click + LowerRightPending W.Coords + | SelectionComplete + +data EntityPaint + = Facade EntityFacade + | Ref E.Entity + deriving (Eq) + +getDisplay :: EntityPaint -> Display +getDisplay (Facade (EntityFacade _ d)) = d +getDisplay (Ref e) = e ^. E.entityDisplay + +toFacade :: EntityPaint -> EntityFacade +toFacade = \case + Facade f -> f + Ref e -> mkPaint e + +getEntityName :: EntityFacade -> EntityName +getEntityName (EntityFacade name _) = name + +data MapEditingBounds = MapEditingBounds + { _boundsRect :: Maybe BoundsRectangle + -- ^ Upper-left and lower-right coordinates + -- of the map to be saved. + , _boundsPersistDisplayUntil :: TimeSpec + , _boundsSelectionStep :: BoundsSelectionStep + } + +makeLenses ''MapEditingBounds + +data WorldEditor n = WorldEditor + { _isWorldEditorEnabled :: Bool + , _terrainList :: BL.List n TerrainType + , _entityPaintList :: BL.List n EntityFacade + -- ^ This field has deferred initialization; it gets populated when a game + -- is initialized. + , _paintedTerrain :: M.Map W.Coords TerrainEntityFacadePair + , _editingBounds :: MapEditingBounds + , _editorFocusRing :: FocusRing n + , _outputFilePath :: FilePath + , _lastWorldEditorMessage :: Maybe String + } + +makeLenses ''WorldEditor + +initialWorldEditor :: TimeSpec -> WorldEditor Name +initialWorldEditor ts = + WorldEditor + False + (BL.list TerrainList (V.fromList listEnums) 1) + (BL.list EntityPaintList (V.fromList []) 1) + mempty + bounds + (focusRing $ map WorldEditorPanelControl listEnums) + "mymap.yaml" + Nothing + where + bounds = + MapEditingBounds + -- Note that these are in "world coordinates", + -- not in player-facing "Location" coordinates + (Just (W.Coords (-10, -20), W.Coords (10, 20))) + (ts - 1) + SelectionComplete diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs new file mode 100644 index 000000000..1fc763446 --- /dev/null +++ b/src/Swarm/TUI/Editor/Util.hs @@ -0,0 +1,118 @@ +module Swarm.TUI.Editor.Util where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (Const, from) +import Control.Monad (guard) +import Data.Int (Int32) +import Data.Map qualified as M +import Data.Map qualified as Map +import Data.Maybe qualified as Maybe +import Data.Vector qualified as V +import Swarm.Game.Entity +import Swarm.Game.Scenario.Cell +import Swarm.Game.Scenario.EntityFacade +import Swarm.Game.Scenario.WorldDescription +import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.World qualified as W +import Swarm.TUI.Editor.Area qualified as EA +import Swarm.TUI.Editor.Model +import Swarm.TUI.Model + +getEntitiesForList :: EntityMap -> V.Vector EntityFacade +getEntitiesForList em = + V.fromList $ map mkPaint entities + where + entities = M.elems $ entitiesByName em + +getEditingBounds :: WorldDescription -> (Bool, BoundsRectangle) +getEditingBounds myWorld = + (EA.isEmpty a, newBounds) + where + newBounds = (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) + upperLeftLoc = ul myWorld + a = EA.getAreaDimensions $ area myWorld + lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc + +getContentAt :: + WorldEditor Name -> + W.World Int Entity -> + W.Coords -> + (TerrainType, Maybe EntityPaint) +getContentAt editor w coords = + (terrainWithOverride, entityWithOverride) + where + terrainWithOverride = Maybe.fromMaybe underlyingCellTerrain $ do + (terrainOverride, _) <- maybePaintedCell + return terrainOverride + + maybeEntityOverride = do + (_, e) <- maybePaintedCell + Facade <$> e + + maybePaintedCell = do + guard $ editor ^. isWorldEditorEnabled + Map.lookup coords pm + + pm = editor ^. paintedTerrain + + entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride + underlyingCellEntity = W.lookupEntity coords w + underlyingCellTerrain = toEnum $ W.lookupTerrain coords w + +getTerrainAt :: + WorldEditor Name -> + W.World Int Entity -> + W.Coords -> + TerrainType +getTerrainAt editor w coords = fst $ getContentAt editor w coords + +isOutsideTopLeftCorner :: + -- | top left corner coords + W.Coords -> + -- | current coords + W.Coords -> + Bool +isOutsideTopLeftCorner (W.Coords (yTop, xLeft)) (W.Coords (y, x)) = + x < xLeft || y < yTop + +isOutsideBottomRightCorner :: + -- | bottom right corner coords + W.Coords -> + -- | current coords + W.Coords -> + Bool +isOutsideBottomRightCorner (W.Coords (yBottom, xRight)) (W.Coords (y, x)) = + x > xRight || y > yBottom + +isOutsideRegion :: + -- | full bounds + BoundsRectangle -> + -- | current coords + W.Coords -> + Bool +isOutsideRegion (tl, br) coord = + isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord + +getEditedMapRectangle :: + WorldEditor Name -> + Maybe BoundsRectangle -> + W.World Int Entity -> + [[CellPaintDisplay]] +getEditedMapRectangle _ Nothing _ = [] +getEditedMapRectangle worldEditor (Just coords) w = + map renderRow [yTop .. yBottom] + where + (W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords + + getContent = getContentAt worldEditor w + + drawCell :: Int32 -> Int32 -> CellPaintDisplay + drawCell rowIndex colIndex = + Cell + terrain + (toFacade <$> maybeEntity) + [] + where + (terrain, maybeEntity) = getContent $ W.Coords (rowIndex, colIndex) + + renderRow rowIndex = map (drawCell rowIndex) [xLeft .. xRight] diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs new file mode 100644 index 000000000..b011f50d3 --- /dev/null +++ b/src/Swarm/TUI/Editor/View.hs @@ -0,0 +1,159 @@ +module Swarm.TUI.Editor.View where + +import Brick hiding (Direction) +import Brick.Focus +import Brick.Widgets.Center (hCenter) +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.List qualified as L +import Swarm.Game.Scenario.EntityFacade +import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.World qualified as W +import Swarm.TUI.Attr +import Swarm.TUI.Border +import Swarm.TUI.Editor.Area qualified as EA +import Swarm.TUI.Editor.Model +import Swarm.TUI.Model +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI +import Swarm.TUI.Panel +import Swarm.TUI.View.CellDisplay (renderDisplay) +import Swarm.TUI.View.Util qualified as VU +import Swarm.Util (listEnums) + +drawWorldEditor :: FocusRing Name -> UIState -> Widget Name +drawWorldEditor toplevelFocusRing uis = + if worldEditor ^. isWorldEditorEnabled + then + panel + highlightAttr + toplevelFocusRing + (FocusablePanel WorldEditorPanel) + plainBorder + innerWidget + else emptyWidget + where + privateFocusRing = worldEditor ^. editorFocusRing + maybeCurrentFocus = focusGetCurrent privateFocusRing + + controlsBox = + padBottom Max $ + vBox + [ brushWidget + , entityWidget + , clearEntityButtonWidget + , areaWidget + , outputWidget + , str " " + , saveButtonWidget + ] + + innerWidget = + padLeftRight 1 $ + hLimit 30 $ + controlsBox <=> statusBox + + worldEditor = uis ^. uiWorldEditor + maybeAreaBounds = worldEditor ^. editingBounds . boundsRect + + -- TODO: Use withFocusRing? + mkFormControl n w = + clickable n $ transformation w + where + transformation = + if Just n == maybeCurrentFocus + then withAttr BL.listSelectedFocusedAttr + else id + + swatchContent list drawFunc = + maybe emptyWidget drawFunc selectedThing + where + selectedThing = snd <$> BL.listSelectedElement list + + brushWidget = + mkFormControl (WorldEditorPanelControl BrushSelector) $ + padRight (Pad 1) (str "Brush:") + <+> swatchContent (worldEditor ^. terrainList) VU.drawLabeledTerrainSwatch + + entityWidget = + mkFormControl (WorldEditorPanelControl EntitySelector) $ + padRight (Pad 1) (str "Entity:") + <+> swatchContent (worldEditor ^. entityPaintList) drawLabeledEntitySwatch + + clearEntityButtonWidget = + if null (worldEditor ^. entityPaintList . BL.listSelectedL) + then emptyWidget + else + mkFormControl (WorldEditorPanelControl ClearEntityButton) $ + hLimit 20 $ + hCenter $ + str "None" + + areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of + UpperLeftPending -> str "Click top-left" + LowerRightPending _wcoords -> str "Click bottom-right" + SelectionComplete -> maybe emptyWidget renderBounds maybeAreaBounds + + areaWidget = + mkFormControl (WorldEditorPanelControl AreaSelector) $ + vBox + [ str "Area:" + , areaContent + ] + + renderBounds (upperLeftCoord, lowerRightCoord) = + str $ + unwords $ + L.intersperse + "@" + [ EA.renderRectDimensions rectArea + , VU.locationToString upperLeftLoc + ] + where + upperLeftLoc = W.coordsToLoc upperLeftCoord + lowerRightLoc = W.coordsToLoc lowerRightCoord + rectArea = EA.cornersToArea upperLeftLoc lowerRightLoc + + outputWidget = + mkFormControl (WorldEditorPanelControl OutputPathSelector) $ + padRight (Pad 1) (str "Output:") <+> outputWidgetContent + + outputWidgetContent = str $ worldEditor ^. outputFilePath + + saveButtonWidget = + mkFormControl (WorldEditorPanelControl MapSaveButton) $ + hLimit 20 $ + hCenter $ + str "Save" + + statusBox = maybe emptyWidget str $ worldEditor ^. lastWorldEditorMessage + +drawLabeledEntitySwatch :: EntityFacade -> Widget Name +drawLabeledEntitySwatch (EntityFacade eName eDisplay) = + tile <+> txt eName + where + tile = padRight (Pad 1) $ renderDisplay eDisplay + +drawTerrainSelector :: AppState -> Widget Name +drawTerrainSelector s = + padAll 1 $ + hCenter $ + vLimit (length (listEnums :: [TerrainType])) $ + BL.renderListWithIndex listDrawTerrainElement True $ + s ^. uiState . uiWorldEditor . terrainList + +listDrawTerrainElement :: Int -> Bool -> TerrainType -> Widget Name +listDrawTerrainElement pos _isSelected a = + clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch a + +drawEntityPaintSelector :: AppState -> Widget Name +drawEntityPaintSelector s = + padAll 1 $ + hCenter $ + vLimit 10 $ + BL.renderListWithIndex listDrawEntityPaintElement True $ + s ^. uiState . uiWorldEditor . entityPaintList + +listDrawEntityPaintElement :: Int -> Bool -> EntityFacade -> Widget Name +listDrawEntityPaintElement pos _isSelected a = + clickable (EntityPaintListItem pos) $ drawLabeledEntitySwatch a diff --git a/src/Swarm/TUI/Model/Menu.hs b/src/Swarm/TUI/Model/Menu.hs index 7e4a09769..d8d12ebf7 100644 --- a/src/Swarm/TUI/Model/Menu.hs +++ b/src/Swarm/TUI/Model/Menu.hs @@ -44,6 +44,8 @@ data ModalType | RecipesModal | CommandsModal | MessagesModal + | EntityPaletteModal + | TerrainPaletteModal | RobotsModal | ScenarioEndModal ScenarioOutcome | QuitModal diff --git a/src/Swarm/TUI/Model/Name.hs b/src/Swarm/TUI/Model/Name.hs index e3793cac6..ca5310680 100644 --- a/src/Swarm/TUI/Model/Name.hs +++ b/src/Swarm/TUI/Model/Name.hs @@ -2,11 +2,22 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Model.Name where +data WorldEditorFocusable + = BrushSelector + | EntitySelector + | AreaSelector + | OutputPathSelector + | MapSaveButton + | ClearEntityButton + deriving (Eq, Ord, Show, Read, Bounded, Enum) + data FocusablePanel = -- | The panel containing the REPL. REPLPanel | -- | The panel containing the world view. WorldPanel + | -- | The panel containing the world editor controls. + WorldEditorPanel | -- | The panel showing robot info and inventory on the top left. RobotPanel | -- | The info panel on the bottom left. @@ -43,12 +54,22 @@ data Button -- of the UI, such as forms, panels, caches, extents, lists, and buttons. data Name = FocusablePanel FocusablePanel + | -- | An individual control within the world editor panel. + WorldEditorPanelControl WorldEditorFocusable | -- | The REPL input form. REPLInput | -- | The render cache for the world view. WorldCache | -- | The cached extent for the world view. WorldExtent + | -- | The list of possible entities to paint a map with. + EntityPaintList + | -- | The entity paint item position in the EntityPaintList. + EntityPaintListItem Int + | -- | The list of possible terrain materials. + TerrainList + | -- | The terrain item position in the TerrainList. + TerrainListItem Int | -- | The list of inventory items for the currently -- focused robot. InventoryList diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index cb84f5ccb..1d6762354 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -16,6 +16,7 @@ module Swarm.TUI.Model.StateUpdate ( ) where import Brick.AttrMap (applyAttrMappings) +import Brick.Widgets.List qualified as BL import Control.Applicative ((<|>)) import Control.Lens hiding (from, (<.>)) import Control.Monad.Except @@ -30,7 +31,7 @@ import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Persistence import Swarm.Game.Failure.Render (prettyFailure) import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace)) -import Swarm.Game.Scenario (loadScenario, scenarioAttrs) +import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorld) import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics @@ -44,6 +45,8 @@ import Swarm.Game.ScenarioInfo ( ) import Swarm.Game.State import Swarm.TUI.Attr (swarmAttrMap) +import Swarm.TUI.Editor.Model qualified as EM +import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (ValidatedLaunchParams, toSerializableParams) import Swarm.TUI.Model @@ -141,13 +144,14 @@ scenarioToAppState siPair@(scene, _) userSeed toRun = do rs <- use runtimeState gs <- liftIO $ scenarioToGameState scene userSeed toRun (mkGameStateConfig rs) gameState .= gs - withLensIO uiState $ scenarioToUIState siPair + void $ withLensIO uiState $ scenarioToUIState siPair gs where - withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m () + withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m x withLensIO l a = do x <- use l x' <- liftIO $ a x l .= x' + return x' attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () attainAchievement a = do @@ -170,8 +174,8 @@ attainAchievement' t p a = do liftIO $ saveAchievementsInfo $ M.elems newAchievements -- | Modify the UI state appropriately when starting a new scenario. -scenarioToUIState :: ScenarioInfoPair -> UIState -> IO UIState -scenarioToUIState siPair u = do +scenarioToUIState :: ScenarioInfoPair -> GameState -> UIState -> IO UIState +scenarioToUIState siPair@(scenario, _) gs u = do curTime <- getTime Monotonic return $ u @@ -187,6 +191,17 @@ scenarioToUIState siPair u = do & uiAttrMap .~ applyAttrMappings (map toAttrPair $ fst siPair ^. scenarioAttrs) swarmAttrMap & scenarioRef ?~ siPair & lastFrameTime .~ curTime + & uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing + & uiWorldEditor . EM.editingBounds . EM.boundsRect %~ setNewBounds + where + entityList = EU.getEntitiesForList $ gs ^. entityMap + + myWorld = scenario ^. scenarioWorld + (isEmptyArea, newBounds) = EU.getEditingBounds myWorld + setNewBounds maybeOldBounds = + if isEmptyArea + then maybeOldBounds + else Just newBounds -- | Create an initial app state for a specific scenario. Note that -- this function is used only for unit tests, integration tests, and diff --git a/src/Swarm/TUI/Model/UI.hs b/src/Swarm/TUI/Model/UI.hs index 0cf48f91a..8bff1ebf3 100644 --- a/src/Swarm/TUI/Model/UI.hs +++ b/src/Swarm/TUI/Model/UI.hs @@ -15,6 +15,7 @@ module Swarm.TUI.Model.UI ( uiFocusRing, uiLaunchConfig, uiWorldCursor, + uiWorldEditor, uiREPL, uiInventory, uiInventorySort, @@ -74,6 +75,7 @@ import Swarm.Game.ScenarioInfo ( ) import Swarm.Game.World qualified as W import Swarm.TUI.Attr (swarmAttrMap) +import Swarm.TUI.Editor.Model import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep @@ -98,6 +100,7 @@ data UIState = UIState , _uiFocusRing :: FocusRing Name , _uiLaunchConfig :: LaunchOptions , _uiWorldCursor :: Maybe W.Coords + , _uiWorldEditor :: WorldEditor Name , _uiREPL :: REPLState , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry) , _uiInventorySort :: InventorySortOptions @@ -155,6 +158,9 @@ uiFocusRing :: Lens' UIState (FocusRing Name) -- | The last clicked position on the world view. uiWorldCursor :: Lens' UIState (Maybe W.Coords) +-- | State of all World Editor widgets +uiWorldEditor :: Lens' UIState (WorldEditor Name) + -- | The state of REPL panel. uiREPL :: Lens' UIState REPLState @@ -278,6 +284,9 @@ appData :: Lens' UIState (Map Text Text) -- UIState initialization -- | The initial state of the focus ring. +-- NOTE: Normally, the Tab key might cycle through the members of the +-- focus ring. However, the REPL already uses Tab. So, to is not used +-- at all right now for navigating the toplevel focus ring. initFocusRing :: FocusRing Name initFocusRing = focusRing $ map FocusablePanel listEnums @@ -306,6 +315,7 @@ initUIState speedFactor showMainMenu cheatMode = do , _uiLaunchConfig = launchConfigPanel , _uiFocusRing = initFocusRing , _uiWorldCursor = Nothing + , _uiWorldEditor = initialWorldEditor startTime , _uiREPL = initREPLState $ newREPLHistory history , _uiInventory = Nothing , _uiInventorySort = defaultSortOptions diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index fada1eb12..b7e36099d 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -10,7 +10,6 @@ module Swarm.TUI.View ( -- * Dialog box drawDialog, - generateModal, chooseCursor, -- * Key hint menu @@ -95,6 +94,8 @@ import Swarm.Language.Syntax import Swarm.Language.Typecheck (inferConst) import Swarm.TUI.Attr import Swarm.TUI.Border +import Swarm.TUI.Editor.Model +import Swarm.TUI.Editor.View qualified as EV import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.View @@ -106,7 +107,7 @@ import Swarm.TUI.Panel import Swarm.TUI.View.Achievement import Swarm.TUI.View.CellDisplay import Swarm.TUI.View.Objective qualified as GR -import Swarm.TUI.View.Util +import Swarm.TUI.View.Util as VU import Swarm.Util import Swarm.Version (NewReleaseFailure (..)) import System.Clock (TimeSpec (..)) @@ -405,6 +406,10 @@ drawGameUI s = .~ (if moreBot then Just (txt " · · · ") else Nothing) ) $ drawInfoPanel s + , hCenter $ + clickable (FocusablePanel WorldEditorPanel) $ + EV.drawWorldEditor fr $ + s ^. uiState ] , vBox rightPanel ] @@ -413,7 +418,7 @@ drawGameUI s = addCursorPos = case s ^. uiState . uiWorldCursor of Nothing -> id Just coord -> - let worldCursorInfo = drawWorldCursorInfo (s ^. gameState) coord + let worldCursorInfo = drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord in bottomLabels . leftLabel ?~ padLeftRight 1 worldCursorInfo -- Add clock display in top right of the world view if focused robot -- has a clock equipped @@ -437,7 +442,7 @@ drawGameUI s = & addCursorPos & addClock ) - (drawWorld (s ^. uiState . uiShowRobots) (s ^. gameState)) + (drawWorld (s ^. uiState) (s ^. gameState)) , drawKeyMenu s ] replPanel = @@ -456,18 +461,14 @@ drawGameUI s = ) ] -drawWorldCursorInfo :: GameState -> W.Coords -> Widget Name -drawWorldCursorInfo g coords@(W.Coords (y, x)) = +drawWorldCursorInfo :: WorldEditor Name -> GameState -> W.Coords -> Widget Name +drawWorldCursorInfo worldEditor g coords = case getStatic g coords of Just s -> renderDisplay $ displayStatic s Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget] where coordsWidget = - txt $ - T.unwords - [ from $ show x - , from $ show $ y * (-1) - ] + str $ VU.locationToString $ W.coordsToLoc coords tileMembers = terrain : mapMaybe merge [entity, robot] tileMemberWidgets = @@ -479,8 +480,8 @@ drawWorldCursorInfo g coords@(W.Coords (y, x)) = where f cell preposition = [renderDisplay cell, txt preposition] - terrain = displayTerrainCell g coords - entity = displayEntityCell g coords + terrain = displayTerrainCell worldEditor g coords + entity = displayEntityCell worldEditor g coords robot = displayRobotCell g coords merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible)) @@ -594,6 +595,8 @@ drawModal s = \case QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg (s ^. uiState . uiMenu)) GoalModal -> GR.renderGoalsDisplay (s ^. uiState . uiGoal) KeepPlayingModal -> padLeftRight 1 (displayParagraphs ["Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu."]) + TerrainPaletteModal -> EV.drawTerrainSelector s + EntityPaletteModal -> EV.drawEntityPaintSelector s robotsListWidget :: AppState -> Widget Name robotsListWidget s = hCenter table @@ -646,7 +649,11 @@ robotsListWidget s = hCenter table locWidget = hBox [worldCell, txt $ " " <> locStr] where rloc@(Location x y) = robot ^. robotLocation - worldCell = drawLoc (s ^. uiState . uiShowRobots) g (W.locToCoords rloc) + worldCell = + drawLoc + (s ^. uiState) + g + (W.locToCoords rloc) locStr = from (show x) <> " " <> from (show y) statusWidget = case robot ^. machine of @@ -917,6 +924,7 @@ drawKeyMenu s = catMaybes [ may goal (NoHighlight, "^g", "goal") , may cheat (NoHighlight, "^v", "creative") + , may cheat (NoHighlight, "^e", "editor") , Just (NoHighlight, "^p", if isPaused then "unpause" else "pause") , may isPaused (NoHighlight, "^o", "step") , may (isPaused && hasDebug) (if s ^. uiState . uiShowDebug then Alert else NoHighlight, "M-d", "debug") @@ -930,6 +938,8 @@ drawKeyMenu s = "pop out" | (s ^. uiState . uiMoreInfoBot) || (s ^. uiState . uiMoreInfoTop) -> Alert _ -> PanelSpecific + keyCmdsFor (Just (FocusablePanel WorldEditorPanel)) = + [("^s", "save map")] keyCmdsFor (Just (FocusablePanel REPLPanel)) = [ ("↓↑", "history") ] @@ -975,8 +985,8 @@ drawKeyCmd (h, key, cmd) = ------------------------------------------------------------ -- | Draw the current world view. -drawWorld :: Bool -> GameState -> Widget Name -drawWorld showRobots g = +drawWorld :: UIState -> GameState -> Widget Name +drawWorld ui g = center . cached WorldCache . reportExtent WorldExtent @@ -988,7 +998,7 @@ drawWorld showRobots g = let w = ctx ^. availWidthL h = ctx ^. availHeightL ixs = range (viewingRegion g (fromIntegral w, fromIntegral h)) - render . vBox . map hBox . chunksOf w . map (drawLoc showRobots g) $ ixs + render . vBox . map hBox . chunksOf w . map (drawLoc ui g) $ ixs ------------------------------------------------------------ -- Robot inventory panel diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs index 24e540dc4..0feaa5bcd 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ b/src/Swarm/TUI/View/CellDisplay.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.CellDisplay where @@ -16,11 +18,16 @@ import Linear.Affine ((.-.)) import Swarm.Game.Display import Swarm.Game.Entity import Swarm.Game.Robot +import Swarm.Game.Scenario.EntityFacade import Swarm.Game.State import Swarm.Game.Terrain import Swarm.Game.World qualified as W import Swarm.TUI.Attr +import Swarm.TUI.Editor.Masking +import Swarm.TUI.Editor.Model +import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI import Witch (from) import Witch.Encoding qualified as Encoding @@ -29,20 +36,36 @@ renderDisplay :: Display -> Widget n renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] -- | Render the 'Display' for a specific location. -drawLoc :: Bool -> GameState -> W.Coords -> Widget Name -drawLoc showRobots g = renderDisplay . displayLoc showRobots g - -displayTerrainCell :: GameState -> W.Coords -> Display -displayTerrainCell g coords = terrainMap M.! toEnum (W.lookupTerrain coords (g ^. world)) - -displayEntityCell, displayRobotCell :: GameState -> W.Coords -> [Display] -displayRobotCell g coords = map (view robotDisplay) (robotsAtLocation (W.coordsToLoc coords) g) -displayEntityCell g coords = maybeToList (displayForEntity <$> W.lookupEntity coords (g ^. world)) +drawLoc :: UIState -> GameState -> W.Coords -> Widget Name +drawLoc ui g coords = + if shouldHideWorldCell ui coords + then str " " + else drawCell where - displayForEntity :: Entity -> Display - displayForEntity e = (if known e then id else hidden) (e ^. entityDisplay) + showRobots = ui ^. uiShowRobots + we = ui ^. uiWorldEditor + drawCell = renderDisplay $ displayLoc showRobots we g coords + +displayTerrainCell :: WorldEditor Name -> GameState -> W.Coords -> Display +displayTerrainCell worldEditor g coords = + terrainMap M.! EU.getTerrainAt worldEditor (g ^. world) coords + +displayRobotCell :: GameState -> W.Coords -> [Display] +displayRobotCell g coords = + map (view robotDisplay) $ + robotsAtLocation (W.coordsToLoc coords) g + +displayEntityCell :: WorldEditor Name -> GameState -> W.Coords -> [Display] +displayEntityCell worldEditor g coords = + maybeToList $ displayForEntity <$> maybeEntity + where + (_, maybeEntity) = EU.getContentAt worldEditor (g ^. world) coords + + displayForEntity :: EntityPaint -> Display + displayForEntity e = (if known e then id else hidden) $ getDisplay e - known e = + known (Facade (EntityFacade _ _)) = True + known (Ref e) = e `hasProperty` Known || (e ^. entityName) @@ -63,16 +86,16 @@ hidingMode g -- 'Display's for the terrain, entity, and robots at the location, and -- taking into account "static" based on the distance to the robot -- being @view@ed. -displayLoc :: Bool -> GameState -> W.Coords -> Display -displayLoc showRobots g coords = staticDisplay g coords <> displayLocRaw showRobots g coords +displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display +displayLoc showRobots we g coords = staticDisplay g coords <> displayLocRaw showRobots we g coords -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. -displayLocRaw :: Bool -> GameState -> W.Coords -> Display -displayLocRaw showRobots g coords = sconcat $ terrain NE.:| entity <> robots +displayLocRaw :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display +displayLocRaw showRobots worldEditor g coords = sconcat $ terrain NE.:| entity <> robots where - terrain = displayTerrainCell g coords - entity = displayEntityCell g coords + terrain = displayTerrainCell worldEditor g coords + entity = displayEntityCell worldEditor g coords robots = if showRobots then displayRobotCell g coords diff --git a/src/Swarm/TUI/View/Util.hs b/src/Swarm/TUI/View/Util.hs index 5cb706968..b4b3dc5aa 100644 --- a/src/Swarm/TUI/View/Util.hs +++ b/src/Swarm/TUI/View/Util.hs @@ -4,25 +4,30 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.Util where -import Brick hiding (Direction) +import Brick hiding (Direction, Location) import Brick.Widgets.Dialog import Brick.Widgets.List qualified as BL import Control.Lens hiding (Const, from) import Control.Monad.Reader (withReaderT) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as M import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Graphics.Vty qualified as V import Swarm.Game.Entity as E +import Swarm.Game.Location import Swarm.Game.Scenario (scenarioName) import Swarm.Game.ScenarioInfo (scenarioItemName) import Swarm.Game.State +import Swarm.Game.Terrain import Swarm.Language.Pretty (prettyText) import Swarm.Language.Types (Polytype) import Swarm.TUI.Attr import Swarm.TUI.Model import Swarm.TUI.Model.UI +import Swarm.TUI.View.CellDisplay +import Swarm.Util (listEnums) import Witch (from, into) -- | Generate a fresh modal window of the requested type. @@ -99,11 +104,23 @@ generateModal s mt = Modal mt (dialog (Just $ str title) buttons (maxModalWindow Just (scenario, _) -> scenario ^. scenarioName in (" " <> T.unpack goalModalTitle <> " ", Nothing, descriptionWidth) KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80) + TerrainPaletteModal -> ("Terrain", Nothing, w) + where + wordLength = maximum $ map (length . show) (listEnums :: [TerrainType]) + w = wordLength + 6 + EntityPaletteModal -> ("Entity", Nothing, 30) -- | Render the type of the current REPL input to be shown to the user. drawType :: Polytype -> Widget Name drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText +drawLabeledTerrainSwatch :: TerrainType -> Widget Name +drawLabeledTerrainSwatch a = + tile <+> str materialName + where + tile = padRight (Pad 1) $ renderDisplay $ terrainMap M.! a + materialName = init $ show a + descriptionTitle :: Entity -> String descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " " @@ -126,6 +143,10 @@ quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this NoMenu -> "quit" _ -> "return to the menu" +locationToString :: Location -> String +locationToString (Location x y) = + unwords $ map show [x, y] + -- | Display a list of text-wrapped paragraphs with one blank line after -- each. displayParagraphs :: [Text] -> Widget Name diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index d309f4774..31969a67c 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -17,6 +17,7 @@ module Swarm.Util ( listEnums, uniq, binTuples, + histogram, findDup, both, @@ -77,8 +78,8 @@ import Control.Monad.Except (ExceptT (..), runExceptT) import Data.Bifunctor (Bifunctor (bimap), first) import Data.Char (isAlphaNum) import Data.Either.Validation -import Data.List (maximumBy, partition) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List (foldl', maximumBy, partition) +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M @@ -161,6 +162,13 @@ binTuples = foldr f mempty where f = uncurry (M.insertWith (<>)) . fmap pure +-- | Count occurrences of a value +histogram :: + (Foldable t, Ord a) => + t a -> + Map a Int +histogram = foldl' (\m k -> M.insertWith (+) k 1 m) M.empty + -- | Find a duplicate element within the list, if any exists. findDup :: Ord a => [a] -> Maybe a findDup = go S.empty diff --git a/swarm.cabal b/swarm.cabal index 98491a3c3..8555e0d1d 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -107,6 +107,7 @@ library Swarm.TUI.Launch.Model Swarm.TUI.Launch.Prep Swarm.TUI.Launch.View + Swarm.Game.Scenario.EntityFacade Swarm.Game.Scenario.Objective Swarm.Game.Scenario.Objective.Graph Swarm.Game.Scenario.Objective.Logic @@ -150,6 +151,13 @@ library Swarm.ReadableIORef Swarm.TUI.Attr Swarm.TUI.Border + Swarm.TUI.Editor.Area + Swarm.TUI.Editor.Controller + Swarm.TUI.Editor.Json + Swarm.TUI.Editor.Masking + Swarm.TUI.Editor.Model + Swarm.TUI.Editor.View + Swarm.TUI.Editor.Util Swarm.TUI.Controller Swarm.TUI.Controller.Util Swarm.TUI.Inventory.Sorting @@ -207,6 +215,7 @@ library lsp >= 1.6 && < 1.7, megaparsec >= 9.0 && < 9.4, minimorph >= 0.3 && < 0.4, + transformers >= 0.5 && < 0.7, mtl >= 2.2.2 && < 2.3, murmur3 >= 1.0.4 && < 1.1, natural-sort >= 0.1.2 && < 0.2, From 8f6182b3823e97cdf37c0e4d8a7f532bf128f7e6 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Tue, 7 Mar 2023 23:41:02 -0800 Subject: [PATCH 02/11] Add issue references --- src/Swarm/Game/Scenario/WorldDescription.hs | 2 +- src/Swarm/TUI/Editor/Controller.hs | 6 +++--- src/Swarm/TUI/Editor/View.hs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index f2ba7f763..2e2fb9801 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -173,7 +173,7 @@ prepForJson (WorldPalette suggestedPalette) cellGrid = unassignedCharacters :: Set.Set Char unassignedCharacters = - -- TODO: How can we efficiently use the Unicode categories (in "Data.Char") + -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char") -- to generate this pool? Set.difference genericCharacterPool $ Set.fromList $ diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index feb43173f..fdeff242a 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -73,7 +73,7 @@ handleCtrlLeftClick mouseLoc = do let getSelected x = snd <$> BL.listSelectedElement x maybeTerrainType = getSelected $ worldEditor ^. terrainList maybeEntityPaint = getSelected $ worldEditor ^. entityPaintList - -- TODO: Use hoistMaybe when available + -- TODO (#1151): Use hoistMaybe when available terrain <- MaybeT . pure $ maybeTerrainType mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc uiState . uiWorldEditor . paintedTerrain %= M.insert mouseCoords (terrain, maybeEntityPaint) @@ -140,7 +140,7 @@ updateAreaBounds = \case UpperLeftPending -> do uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= LowerRightPending mouseCoords return False - -- TODO: Validate that the lower-right click is below and to the right of the top-left coord + -- TODO (#1152): Validate that the lower-right click is below and to the right of the top-left coord LowerRightPending upperLeftMouseCoords -> do uiState . uiWorldEditor . editingBounds . boundsRect .= Just (upperLeftMouseCoords, mouseCoords) @@ -217,7 +217,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = let cell = Cell terrain (Just $ EntityFacade eName eDisplay) [] return ((terrain, Just eName), (T.singleton displayChar, cell)) - -- TODO: Filter out terrain-only palette entries that aren't actually + -- TODO (#1153): Filter out terrain-only palette entries that aren't actually -- used in the map. terrainOnlyPalette :: Map TerrainEntityNamePair (T.Text, CellPaintDisplay) terrainOnlyPalette = M.fromList $ map f U.listEnums diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs index b011f50d3..1d2417bd6 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ b/src/Swarm/TUI/Editor/View.hs @@ -56,7 +56,7 @@ drawWorldEditor toplevelFocusRing uis = worldEditor = uis ^. uiWorldEditor maybeAreaBounds = worldEditor ^. editingBounds . boundsRect - -- TODO: Use withFocusRing? + -- TODO (#1150): Use withFocusRing? mkFormControl n w = clickable n $ transformation w where From 48c1a64228e6ab53dbb911abdee57207baa5140b Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 6 May 2023 14:27:34 -0700 Subject: [PATCH 03/11] address some review comments --- src/Swarm/Game/Scenario/Cell.hs | 24 +++++++++------------ src/Swarm/Game/Scenario/EntityFacade.hs | 13 +++++++++-- src/Swarm/Game/Scenario/WorldDescription.hs | 2 +- src/Swarm/Game/State.hs | 3 +-- src/Swarm/Game/World.hs | 8 ++++++- src/Swarm/TUI/Controller.hs | 12 ++++------- src/Swarm/TUI/Editor/Controller.hs | 2 +- src/Swarm/TUI/Editor/Model.hs | 8 ++----- src/Swarm/TUI/Editor/Util.hs | 8 +++---- src/Swarm/TUI/View/CellDisplay.hs | 5 ++++- 10 files changed, 45 insertions(+), 40 deletions(-) diff --git a/src/Swarm/Game/Scenario/Cell.hs b/src/Swarm/Game/Scenario/Cell.hs index 32ffd0fc7..03c6401a6 100644 --- a/src/Swarm/Game/Scenario/Cell.hs +++ b/src/Swarm/Game/Scenario/Cell.hs @@ -41,14 +41,16 @@ data PCell e = Cell -- and optionally an entity and robot. type Cell = PCell Entity +mkPCellJson :: ToJSON b => (a -> b) -> PCell a -> Value +mkPCellJson modifier x = toJSON $ + catMaybes + [ Just . toJSON . getTerrainWord $ cellTerrain x + , toJSON . modifier <$> cellEntity x + , listToMaybe [] + ] + instance ToJSON Cell where - toJSON x = - toJSON $ - catMaybes - [ Just $ toJSON $ getTerrainWord $ cellTerrain x - , toJSON . (^. entityName) <$> cellEntity x - , listToMaybe [] - ] + toJSON = mkPCellJson $ view entityName -- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'. The -- entity and robot, if present, are immediately looked up and @@ -83,10 +85,4 @@ type CellPaintDisplay = PCell EntityFacade -- 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 [] - ] + toJSON = mkPCellJson id diff --git a/src/Swarm/Game/Scenario/EntityFacade.hs b/src/Swarm/Game/Scenario/EntityFacade.hs index b04bc30c8..caa543fa2 100644 --- a/src/Swarm/Game/Scenario/EntityFacade.hs +++ b/src/Swarm/Game/Scenario/EntityFacade.hs @@ -1,5 +1,11 @@ {-# LANGUAGE DerivingVia #-} +-- | Stand-in type for an "Entity" for purposes +-- that do not require carrying around the entire state +-- of an Entity. +-- +-- Useful for simplified serialization, debugging, +-- and equality checking, particularly for the World Editor. module Swarm.Game.Scenario.EntityFacade where import Control.Lens hiding (from, (.=), (<.>)) @@ -10,6 +16,9 @@ import Swarm.Game.Entity qualified as E 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. data EntityFacade = EntityFacade EntityName Display deriving (Eq) @@ -17,8 +26,8 @@ data EntityFacade = EntityFacade EntityName Display instance ToJSON EntityFacade where toJSON (EntityFacade eName _display) = toJSON eName -mkPaint :: E.Entity -> EntityFacade -mkPaint e = +mkFacade :: E.Entity -> EntityFacade +mkFacade e = EntityFacade (e ^. E.entityName) (e ^. E.entityDisplay) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 2e2fb9801..945be6a6c 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -88,7 +88,7 @@ cellToTerrainEntityNamePair (Cell terrain maybeEntity _) = (terrain, maybeEntity toCellPaintDisplay :: Cell -> CellPaintDisplay toCellPaintDisplay (Cell terrain maybeEntity r) = - Cell terrain (mkPaint <$> maybeEntity) r + Cell terrain (mkFacade <$> maybeEntity) r type WorldDescriptionPaint = PWorldDescription EntityFacade diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 96b035119..da230e42a 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -177,7 +177,6 @@ import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst) import Swarm.Language.Typed (Typed (Typed)) import Swarm.Language.Types import Swarm.Language.Value (Value) -import Swarm.TUI.Editor.Model (BoundsRectangle) import Swarm.Util (uniq, (<+=), (<<.=), (?)) import Swarm.Util.Lens (makeLensesExcluding) import System.Clock qualified as Clock @@ -720,7 +719,7 @@ unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id -- | Given a width and height, compute the region, centered on the -- 'viewCenter', that should currently be in view. -viewingRegion :: GameState -> (Int32, Int32) -> BoundsRectangle +viewingRegion :: GameState -> (Int32, Int32) -> W.BoundsRectangle viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) where Location cx cy = g ^. viewCenter diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index 1964df275..26dddd8ff 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -17,7 +17,8 @@ module Swarm.Game.World ( Coords (..), locToCoords, coordsToLoc, - + BoundsRectangle, + -- * Worlds WorldFun (..), worldFunFromArray, @@ -87,6 +88,11 @@ locToCoords (Location x y) = Coords (-y, x) coordsToLoc :: Coords -> Location coordsToLoc (Coords (r, c)) = Location c (-r) + +-- | Represents the top-left and bottom-right coordinates +-- of a bounding rectangle of cells in the world map +type BoundsRectangle = (Coords, Coords) + ------------------------------------------------------------ -- World function ------------------------------------------------------------ diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 9ef72e00f..b6dda5435 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -463,14 +463,10 @@ handleModalEvent = \case Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev) modal <- preuse $ uiState . uiModal . _Just . modalType case modal of - Just TerrainPaletteModal -> do - lw <- use $ uiState . uiWorldEditor . terrainList - newList <- refreshList lw - uiState . uiWorldEditor . terrainList .= newList + Just TerrainPaletteModal -> + refreshList $ uiState . uiWorldEditor . terrainList Just EntityPaletteModal -> do - lw <- use $ uiState . uiWorldEditor . entityPaintList - newList <- refreshList lw - uiState . uiWorldEditor . entityPaintList .= newList + refreshList $ uiState . uiWorldEditor . entityPaintList Just GoalModal -> case ev of V.EvKey (V.KChar '\t') [] -> uiState . uiGoal . focus %= focusNext _ -> do @@ -486,7 +482,7 @@ handleModalEvent = \case _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) where refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection - refreshList w = nestEventM' w $ BL.handleListEvent ev + refreshList z = Brick.zoom z $ BL.handleListEvent ev getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) getNormalizedCurrentScenarioPath = diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index fdeff242a..5fbd57f7b 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -111,7 +111,7 @@ handleMiddleClick mouseLoc = do where p = case elementPaint of Facade efd -> efd - Ref r -> mkPaint r + Ref r -> mkFacade r mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc whenJust mouseCoordsM setTerrainPaint diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs index dbc68eb18..4cabd58a9 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ b/src/Swarm/TUI/Editor/Model.hs @@ -18,10 +18,6 @@ import Swarm.TUI.Model.Name import Swarm.Util import System.Clock --- | Represents the top-left and bottom-right coordinates --- of a bounding rectangle of cells in the world map -type BoundsRectangle = (W.Coords, W.Coords) - data BoundsSelectionStep = UpperLeftPending | -- | Stores the *world coords* of the upper-left click @@ -40,13 +36,13 @@ getDisplay (Ref e) = e ^. E.entityDisplay toFacade :: EntityPaint -> EntityFacade toFacade = \case Facade f -> f - Ref e -> mkPaint e + Ref e -> mkFacade e getEntityName :: EntityFacade -> EntityName getEntityName (EntityFacade name _) = name data MapEditingBounds = MapEditingBounds - { _boundsRect :: Maybe BoundsRectangle + { _boundsRect :: Maybe W.BoundsRectangle -- ^ Upper-left and lower-right coordinates -- of the map to be saved. , _boundsPersistDisplayUntil :: TimeSpec diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs index 1fc763446..8d8a3a3e5 100644 --- a/src/Swarm/TUI/Editor/Util.hs +++ b/src/Swarm/TUI/Editor/Util.hs @@ -20,11 +20,11 @@ import Swarm.TUI.Model getEntitiesForList :: EntityMap -> V.Vector EntityFacade getEntitiesForList em = - V.fromList $ map mkPaint entities + V.fromList $ map mkFacade entities where entities = M.elems $ entitiesByName em -getEditingBounds :: WorldDescription -> (Bool, BoundsRectangle) +getEditingBounds :: WorldDescription -> (Bool, W.BoundsRectangle) getEditingBounds myWorld = (EA.isEmpty a, newBounds) where @@ -86,7 +86,7 @@ isOutsideBottomRightCorner (W.Coords (yBottom, xRight)) (W.Coords (y, x)) = isOutsideRegion :: -- | full bounds - BoundsRectangle -> + W.BoundsRectangle -> -- | current coords W.Coords -> Bool @@ -95,7 +95,7 @@ isOutsideRegion (tl, br) coord = getEditedMapRectangle :: WorldEditor Name -> - Maybe BoundsRectangle -> + Maybe W.BoundsRectangle -> W.World Int Entity -> [[CellPaintDisplay]] getEditedMapRectangle _ Nothing _ = [] diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs index 0feaa5bcd..8ebd42bbe 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ b/src/Swarm/TUI/View/CellDisplay.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -- | +-- Rendering of cells in the map view +-- -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.CellDisplay where @@ -87,7 +89,8 @@ hidingMode g -- taking into account "static" based on the distance to the robot -- being @view@ed. displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display -displayLoc showRobots we g coords = staticDisplay g coords <> displayLocRaw showRobots we g coords +displayLoc showRobots we g coords = staticDisplay g coords + <> displayLocRaw showRobots we g coords -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. From 98fa653f9ee2757a88b611ed7200337e636fab2a Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 6 May 2023 17:20:16 -0700 Subject: [PATCH 04/11] lint/restyle --- src/Swarm/Game/Scenario/Cell.hs | 13 ++++++----- src/Swarm/Game/World.hs | 3 +-- src/Swarm/TUI/Editor/Controller.hs | 16 ++++++------- src/Swarm/TUI/Editor/View.hs | 36 +++++++++++++++--------------- src/Swarm/TUI/View.hs | 8 +++---- src/Swarm/TUI/View/CellDisplay.hs | 7 +++--- 6 files changed, 42 insertions(+), 41 deletions(-) diff --git a/src/Swarm/Game/Scenario/Cell.hs b/src/Swarm/Game/Scenario/Cell.hs index 03c6401a6..53f6f464a 100644 --- a/src/Swarm/Game/Scenario/Cell.hs +++ b/src/Swarm/Game/Scenario/Cell.hs @@ -42,12 +42,13 @@ data PCell e = Cell type Cell = PCell Entity mkPCellJson :: ToJSON b => (a -> b) -> PCell a -> Value -mkPCellJson modifier x = toJSON $ - catMaybes - [ Just . toJSON . getTerrainWord $ cellTerrain x - , toJSON . modifier <$> cellEntity x - , listToMaybe [] - ] +mkPCellJson modifier x = + toJSON $ + catMaybes + [ Just . toJSON . getTerrainWord $ cellTerrain x + , toJSON . modifier <$> cellEntity x + , listToMaybe [] + ] instance ToJSON Cell where toJSON = mkPCellJson $ view entityName diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index 26dddd8ff..4e7728756 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -18,7 +18,7 @@ module Swarm.Game.World ( locToCoords, coordsToLoc, BoundsRectangle, - + -- * Worlds WorldFun (..), worldFunFromArray, @@ -88,7 +88,6 @@ locToCoords (Location x y) = Coords (-y, x) coordsToLoc :: Coords -> Location coordsToLoc (Coords (r, c)) = Location c (-r) - -- | Represents the top-left and bottom-right coordinates -- of a bounding rectangle of cells in the world map type BoundsRectangle = (Coords, Coords) diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index 5fbd57f7b..a0a98c354 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -179,10 +179,10 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = -- 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 + map (swap . fmap (fst . NE.head)) + . mapMaybe sequenceA + . M.toList + $ M.map (NE.nonEmpty . sortOn snd . M.toList) getEntityTerrainMultiplicity invertPaletteMapToDedupe :: Map a CellPaintDisplay -> @@ -192,10 +192,10 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = paletteCellsByKey :: Map TerrainEntityNamePair (T.Text, CellPaintDisplay) paletteCellsByKey = - M.map (NE.head . NE.sortWith toSortVal) $ - binTuples $ - invertPaletteMapToDedupe $ - KM.toMapText originalPalette + M.map (NE.head . NE.sortWith toSortVal) + . binTuples + . invertPaletteMapToDedupe + $ KM.toMapText originalPalette where toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol) diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs index 1d2417bd6..51c3fe44b 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ b/src/Swarm/TUI/Editor/View.hs @@ -84,10 +84,10 @@ drawWorldEditor toplevelFocusRing uis = if null (worldEditor ^. entityPaintList . BL.listSelectedL) then emptyWidget else - mkFormControl (WorldEditorPanelControl ClearEntityButton) $ - hLimit 20 $ - hCenter $ - str "None" + mkFormControl (WorldEditorPanelControl ClearEntityButton) + . hLimit 20 + . hCenter + $ str "None" areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of UpperLeftPending -> str "Click top-left" @@ -121,10 +121,10 @@ drawWorldEditor toplevelFocusRing uis = outputWidgetContent = str $ worldEditor ^. outputFilePath saveButtonWidget = - mkFormControl (WorldEditorPanelControl MapSaveButton) $ - hLimit 20 $ - hCenter $ - str "Save" + mkFormControl (WorldEditorPanelControl MapSaveButton) + . hLimit 20 + . hCenter + $ str "Save" statusBox = maybe emptyWidget str $ worldEditor ^. lastWorldEditorMessage @@ -136,11 +136,11 @@ drawLabeledEntitySwatch (EntityFacade eName eDisplay) = drawTerrainSelector :: AppState -> Widget Name drawTerrainSelector s = - padAll 1 $ - hCenter $ - vLimit (length (listEnums :: [TerrainType])) $ - BL.renderListWithIndex listDrawTerrainElement True $ - s ^. uiState . uiWorldEditor . terrainList + padAll 1 + . hCenter + . vLimit (length (listEnums :: [TerrainType])) + . BL.renderListWithIndex listDrawTerrainElement True + $ s ^. uiState . uiWorldEditor . terrainList listDrawTerrainElement :: Int -> Bool -> TerrainType -> Widget Name listDrawTerrainElement pos _isSelected a = @@ -148,11 +148,11 @@ listDrawTerrainElement pos _isSelected a = drawEntityPaintSelector :: AppState -> Widget Name drawEntityPaintSelector s = - padAll 1 $ - hCenter $ - vLimit 10 $ - BL.renderListWithIndex listDrawEntityPaintElement True $ - s ^. uiState . uiWorldEditor . entityPaintList + padAll 1 + . hCenter + . vLimit 10 + . BL.renderListWithIndex listDrawEntityPaintElement True + $ s ^. uiState . uiWorldEditor . entityPaintList listDrawEntityPaintElement :: Int -> Bool -> EntityFacade -> Widget Name listDrawEntityPaintElement pos _isSelected a = diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index b7e36099d..e37ff38d6 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -406,10 +406,10 @@ drawGameUI s = .~ (if moreBot then Just (txt " · · · ") else Nothing) ) $ drawInfoPanel s - , hCenter $ - clickable (FocusablePanel WorldEditorPanel) $ - EV.drawWorldEditor fr $ - s ^. uiState + , hCenter + . clickable (FocusablePanel WorldEditorPanel) + . EV.drawWorldEditor fr + $ s ^. uiState ] , vBox rightPanel ] diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs index 8ebd42bbe..52cc4b9da 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ b/src/Swarm/TUI/View/CellDisplay.hs @@ -2,7 +2,7 @@ -- | -- Rendering of cells in the map view --- +-- -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.CellDisplay where @@ -89,8 +89,9 @@ hidingMode g -- taking into account "static" based on the distance to the robot -- being @view@ed. displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display -displayLoc showRobots we g coords = staticDisplay g coords - <> displayLocRaw showRobots we g coords +displayLoc showRobots we g coords = + staticDisplay g coords + <> displayLocRaw showRobots we g coords -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. From b18002588be583e5aeeffdb951734fea5a7c95f5 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 00:15:46 -0700 Subject: [PATCH 05/11] TerrainWith --- src/Swarm/Game/Scenario/WorldDescription.hs | 22 ++++++++++----------- src/Swarm/TUI/Editor/Controller.hs | 8 ++++---- src/Swarm/TUI/Editor/Model.hs | 2 +- 3 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 945be6a6c..83f121b83 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -79,11 +79,9 @@ paintMap pal = traverse (traverse toCell . into @String) . T.lines -- World editor ------------------------------------------------------------ -type TerrainEntityNamePair = (TerrainType, Maybe EntityName) +type TerrainWith a = (TerrainType, Maybe a) -type TerrainEntityFacadePair = (TerrainType, Maybe EntityFacade) - -cellToTerrainEntityNamePair :: CellPaintDisplay -> TerrainEntityFacadePair +cellToTerrainEntityNamePair :: CellPaintDisplay -> TerrainWith EntityFacade cellToTerrainEntityNamePair (Cell terrain maybeEntity _) = (terrain, maybeEntity) toCellPaintDisplay :: Cell -> CellPaintDisplay @@ -106,10 +104,10 @@ instance ToJSON WorldDescriptionPaint where suggestedPalette = palette w (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid -toKey :: TerrainEntityFacadePair -> TerrainEntityNamePair +toKey :: TerrainWith EntityFacade -> TerrainWith EntityName toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName) -getUniquePairs :: [[CellPaintDisplay]] -> M.Map TerrainEntityNamePair TerrainEntityFacadePair +getUniquePairs :: [[CellPaintDisplay]] -> M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) getUniquePairs cellGrid = M.fromList $ concatMap (map genTuple) cellGrid where @@ -119,7 +117,7 @@ getUniquePairs cellGrid = terrainEfd = cellToTerrainEntityNamePair c constructPalette :: - [(Char, TerrainEntityFacadePair)] -> + [(Char, TerrainWith EntityFacade)] -> KM.KeyMap CellPaintDisplay constructPalette mappedPairs = KM.fromMapText terrainEntityPalette @@ -128,7 +126,7 @@ constructPalette mappedPairs = terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs constructWorldMap :: - [(Char, TerrainEntityFacadePair)] -> + [(Char, TerrainWith EntityFacade)] -> [[CellPaintDisplay]] -> Text constructWorldMap mappedPairs = @@ -156,16 +154,16 @@ prepForJson :: prepForJson (WorldPalette suggestedPalette) cellGrid = (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs) where - preassignments :: [(Char, TerrainEntityFacadePair)] + preassignments :: [(Char, TerrainWith EntityFacade)] preassignments = map (first T.head . fmap cellToTerrainEntityNamePair) $ M.toList $ KM.toMapText suggestedPalette - entityCells :: M.Map TerrainEntityNamePair TerrainEntityFacadePair + entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) entityCells = getUniquePairs cellGrid - unassignedCells :: M.Map TerrainEntityNamePair TerrainEntityFacadePair + unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) unassignedCells = M.withoutKeys entityCells $ Set.fromList $ @@ -179,7 +177,7 @@ prepForJson (WorldPalette suggestedPalette) cellGrid = Set.fromList $ map fst preassignments - newlyAssignedPairs :: [(Char, TerrainEntityFacadePair)] + newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)] newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells mappedPairs = preassignments <> newlyAssignedPairs diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index a0a98c354..006c249c1 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -186,11 +186,11 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = invertPaletteMapToDedupe :: Map a CellPaintDisplay -> - [(TerrainEntityNamePair, (a, CellPaintDisplay))] + [(TerrainWith EntityName, (a, CellPaintDisplay))] invertPaletteMapToDedupe = map (\x@(_, c) -> (toKey $ cellToTerrainEntityNamePair c, x)) . M.toList - paletteCellsByKey :: Map TerrainEntityNamePair (T.Text, CellPaintDisplay) + paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) paletteCellsByKey = M.map (NE.head . NE.sortWith toSortVal) . binTuples @@ -207,7 +207,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = KM.map toCellPaintDisplay $ maybe mempty (unPalette . palette . (^. scenarioWorld)) maybeOriginalScenario - pairsWithDisplays :: Map TerrainEntityNamePair (T.Text, CellPaintDisplay) + pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain where g (terrain, eName) = do @@ -219,7 +219,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = -- TODO (#1153): Filter out terrain-only palette entries that aren't actually -- used in the map. - terrainOnlyPalette :: Map TerrainEntityNamePair (T.Text, CellPaintDisplay) + 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 [])) diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs index 4cabd58a9..cccd0ebe5 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ b/src/Swarm/TUI/Editor/Model.hs @@ -57,7 +57,7 @@ data WorldEditor n = WorldEditor , _entityPaintList :: BL.List n EntityFacade -- ^ This field has deferred initialization; it gets populated when a game -- is initialized. - , _paintedTerrain :: M.Map W.Coords TerrainEntityFacadePair + , _paintedTerrain :: M.Map W.Coords (TerrainWith EntityFacade) , _editingBounds :: MapEditingBounds , _editorFocusRing :: FocusRing n , _outputFilePath :: FilePath From f6f19a07117f3abc03d4d5c44334632e5b78296b Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 00:17:32 -0700 Subject: [PATCH 06/11] rename cellToTerrainEntityNamePair --- src/Swarm/Game/Scenario/WorldDescription.hs | 10 +++++----- src/Swarm/TUI/Editor/Controller.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 83f121b83..302a5e90a 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -81,8 +81,8 @@ paintMap pal = traverse (traverse toCell . into @String) . T.lines type TerrainWith a = (TerrainType, Maybe a) -cellToTerrainEntityNamePair :: CellPaintDisplay -> TerrainWith EntityFacade -cellToTerrainEntityNamePair (Cell terrain maybeEntity _) = (terrain, maybeEntity) +cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade +cellToTerrainPair (Cell terrain maybeEntity _) = (terrain, maybeEntity) toCellPaintDisplay :: Cell -> CellPaintDisplay toCellPaintDisplay (Cell terrain maybeEntity r) = @@ -114,7 +114,7 @@ getUniquePairs cellGrid = genTuple c = (toKey terrainEfd, terrainEfd) where - terrainEfd = cellToTerrainEntityNamePair c + terrainEfd = cellToTerrainPair c constructPalette :: [(Char, TerrainWith EntityFacade)] -> @@ -139,7 +139,7 @@ constructWorldMap mappedPairs = M.findWithDefault (error "Palette lookup failed!") k $ M.fromList invertedMappedPairs where - k = toKey $ cellToTerrainEntityNamePair c + k = toKey $ cellToTerrainPair c genericCharacterPool :: Set.Set Char genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9'] @@ -156,7 +156,7 @@ prepForJson (WorldPalette suggestedPalette) cellGrid = where preassignments :: [(Char, TerrainWith EntityFacade)] preassignments = - map (first T.head . fmap cellToTerrainEntityNamePair) $ + map (first T.head . fmap cellToTerrainPair) $ M.toList $ KM.toMapText suggestedPalette diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index 006c249c1..316cf7aee 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -188,7 +188,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = Map a CellPaintDisplay -> [(TerrainWith EntityName, (a, CellPaintDisplay))] invertPaletteMapToDedupe = - map (\x@(_, c) -> (toKey $ cellToTerrainEntityNamePair c, x)) . M.toList + map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) paletteCellsByKey = From 76ccdd609439794b5a03dd9191f3cc58b78ed4ba Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 00:28:53 -0700 Subject: [PATCH 07/11] rename getUniquePairs to getUniqueTerrainFacadePairs and add comment --- src/Swarm/Game/Scenario/WorldDescription.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 302a5e90a..7cddb0459 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -107,8 +107,16 @@ instance ToJSON WorldDescriptionPaint where toKey :: TerrainWith EntityFacade -> TerrainWith EntityName toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName) -getUniquePairs :: [[CellPaintDisplay]] -> M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) -getUniquePairs cellGrid = +-- | 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 = @@ -161,7 +169,7 @@ prepForJson (WorldPalette suggestedPalette) cellGrid = KM.toMapText suggestedPalette entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) - entityCells = getUniquePairs cellGrid + entityCells = getUniqueTerrainFacadePairs cellGrid unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) unassignedCells = From 4ca4320a59be0b653fe28ba1775d7552cc3ead7d Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 12:08:38 -0700 Subject: [PATCH 08/11] more comments, split module --- src/Swarm/Game/Scenario/Cell.hs | 3 + src/Swarm/Game/Scenario/EntityFacade.hs | 2 + src/Swarm/Game/Scenario/WorldDescription.hs | 5 + src/Swarm/TUI/Controller/Util.hs | 10 +- src/Swarm/TUI/Editor/Controller.hs | 141 +------------------- src/Swarm/TUI/Editor/Palette.hs | 135 +++++++++++++++++++ src/Swarm/TUI/Editor/View.hs | 2 +- swarm.cabal | 1 + 8 files changed, 158 insertions(+), 141 deletions(-) create mode 100644 src/Swarm/TUI/Editor/Palette.hs diff --git a/src/Swarm/Game/Scenario/Cell.hs b/src/Swarm/Game/Scenario/Cell.hs index 53f6f464a..0a838af54 100644 --- a/src/Swarm/Game/Scenario/Cell.hs +++ b/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 diff --git a/src/Swarm/Game/Scenario/EntityFacade.hs b/src/Swarm/Game/Scenario/EntityFacade.hs index caa543fa2..1166bf6ba 100644 --- a/src/Swarm/Game/Scenario/EntityFacade.hs +++ b/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) diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs index 7cddb0459..33238205b 100644 --- a/src/Swarm/Game/Scenario/WorldDescription.hs +++ b/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'] diff --git a/src/Swarm/TUI/Controller/Util.hs b/src/Swarm/TUI/Controller/Util.hs index f2b0800e7..ec69c8d42 100644 --- a/src/Swarm/TUI/Controller/Util.hs +++ b/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 @@ -75,11 +75,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 diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index 316cf7aee..f0df7c482 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/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 diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs new file mode 100644 index 000000000..a0047d389 --- /dev/null +++ b/src/Swarm/TUI/Editor/Palette.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.Editor.Palette where + +import Control.Lens +import Control.Monad (guard) +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 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.Terrain (TerrainType (BlankT), getTerrainDefaultPaletteChar) +import Swarm.TUI.Editor.Area (AreaDimensions (..), getAreaDimensions) +import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) +import Swarm.Util (binTuples, histogram) +import Swarm.Util qualified as U + +makeSuggestedPalette :: Maybe Scenario -> [[CellPaintDisplay]] -> KM.KeyMap CellPaintDisplay +makeSuggestedPalette maybeOriginalScenario cellGrid = + KM.fromMapText + . M.fromList + . M.elems + -- NOTE: the left-most maps take precedence! + $ 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 [])) + +-- | Generate a \"skeleton\" scenario with placeholders for certain required fields +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 diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs index 51c3fe44b..bf4d36ab9 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ b/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) diff --git a/swarm.cabal b/swarm.cabal index 8555e0d1d..0b7ee0e62 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -156,6 +156,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 From 0a2649fc62039ff0861a843d9618117764434ae2 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 15:41:15 -0700 Subject: [PATCH 09/11] more comments --- src/Swarm/Game/Scenario/Cell.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Swarm/Game/Scenario/Cell.hs b/src/Swarm/Game/Scenario/Cell.hs index 0a838af54..14c527c2e 100644 --- a/src/Swarm/Game/Scenario/Cell.hs +++ b/src/Swarm/Game/Scenario/Cell.hs @@ -41,6 +41,7 @@ data PCell e = Cell -- and optionally an entity and robot. type Cell = PCell Entity +-- | Re-usable serialization for variants of "PCell" mkPCellJson :: ToJSON b => (a -> b) -> PCell a -> Value mkPCellJson modifier x = toJSON $ From 224bf0a1fcda9271aed3922a2393127a8b428beb Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 7 May 2023 16:34:13 -0700 Subject: [PATCH 10/11] 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 33238205b..7b117c1aa 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 000000000..aa183c505 --- /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 cccd0ebe5..2745349ce 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 a0047d389..875b3ceed 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 0b7ee0e62..c75c92b80 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -121,6 +121,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 @@ -157,8 +158,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 From 20e0d2b720e1e9d594faf8beca0eeea31516df9b Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 8 May 2023 13:44:15 -0700 Subject: [PATCH 11/11] comments --- src/Swarm/TUI/Editor/Area.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Swarm/TUI/Editor/Area.hs b/src/Swarm/TUI/Editor/Area.hs index 675fe405a..5072b822b 100644 --- a/src/Swarm/TUI/Editor/Area.hs +++ b/src/Swarm/TUI/Editor/Area.hs @@ -22,6 +22,7 @@ invertY (V2 x y) = V2 x (-y) -- | Incorporates an offset by -1, since the area is -- "inclusive" of the lower-right coordinate. +-- Inverse of "cornersToArea". upperLeftToBottomRight :: AreaDimensions -> Location -> Location upperLeftToBottomRight (AreaDimensions w h) upperLeft = upperLeft .+^ displacement @@ -31,6 +32,7 @@ upperLeftToBottomRight (AreaDimensions w h) upperLeft = -- | Converts the displacement vector between the two -- diagonal corners of the rectangle into an "AreaDimensions" record. -- Adds one to both dimensions since the corner coordinates are "inclusive". +-- Inverse of "upperLeftToBottomRight". cornersToArea :: Location -> Location -> AreaDimensions cornersToArea upperLeft lowerRight = AreaDimensions x y