swarm-game/swarm
1
1
Fork 0
mirror of https://github.com/swarm-game/swarm.git synced 2024-10-27 01:49:15 +03:00
Code Issues Projects Releases Wiki Activity

world editor prototype (#873)

Browse Source 
Towards #558
I was motivated to build this after finding that editing scenario maps directly in the YAML file is rather constraining.

## What I've implemented so far
* A small, collapsible panel to the left of the REPL containing World Editing status/operations.  Enter world-editing mode with CTRL+e to show the panel.
    * This works only in `--cheat` mode
* Terrain selection
    * A "picker"/"eye dropper" middle-click mechanism to select a terrain style to draw.
    * A pop-up selector to choose between the 5 different types of terrain.
* Drawing terrain with the left mouse button
* Saving a rectangular section of the world map (terrain only) to a file with CTRL+s
* Code organization
    * The complete state of the World Editor, including "painted overlays" of terrain, is contained within the `uiWorldEditor` field of `UIState` record.
    * The bulk of the World Editor functionality shall be in new modules
    * Some refactoring of `Controller.hs` and `View.hs` to extract functions utilized by the World Editor (towards #707)

## Vision

* The audience for this tooling is strictly envisioned to be Scenario authors.
    * Though, if we eventually allow swarm-lang to program the UI, there may be some common code to extract.
* The World Editor is intended to be compatible with a workflow of editing maps in text form within YAML scenario files.

# Demos
## Round-trip with random world

    stack run -- --scenario creative --seed 0 --cheat

Then Ctrl+e, tab down to the Save button, hit Enter to save the map
In another tab run:

    stack run -- --scenario mymap.yaml

Toggle between tabs to compare, observe the derived map is an identical 41x21 subset.
This commit is contained in:
Karl Ostmo 2023-06-09 11:14:41 -07:00 committed by GitHub
parent 6691300f5f
commit 987ddd6c04
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
27 changed files with 1211 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Swarm/Game/Scenario.hs
View File

@ -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)

31
src/Swarm/Game/Scenario/Cell.hs
View File

@ -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,19 @@ 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 $
catMaybes
[ Just . toJSON . getTerrainWord $ cellTerrain x
, toJSON . modifier <$> cellEntity x
, listToMaybe []
]
instance ToJSON Cell where
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
-- converted into 'Entity' and 'TRobot' values. If they are not
@ -62,3 +78,16 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
robs <- mapMaybeM name2rob (drop 2 tup)
return $ Cell terr ent robs
------------------------------------------------------------
-- 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
instance ToJSON CellPaintDisplay where
toJSON = mkPCellJson id

35
src/Swarm/Game/Scenario/EntityFacade.hs Normal file
View File

@ -0,0 +1,35 @@
{-# 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, (.=), (<.>))
import Data.Text (Text)
import Data.Yaml as Y
import Swarm.Game.Display (Display)
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.
-- It contains the bare minimum display information
-- for rendering.
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
mkFacade :: E.Entity -> EntityFacade
mkFacade e =
EntityFacade
(e ^. E.entityName)
(e ^. E.entityDisplay)

33
src/Swarm/Game/Scenario/WorldDescription.hs
View File

@ -6,7 +6,6 @@
module Swarm.Game.Scenario.WorldDescription where
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap (KeyMap)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Text (Text)
import Data.Text qualified as T
@ -14,7 +13,9 @@ 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.Scenario.WorldPalette
import Swarm.Util.Yaml
import Witch (into)
@ -22,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.
@ -66,3 +59,25 @@ 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
------------------------------------------------------------
-- | A pared-down (stateless) version of "WorldDescription" just for
-- the purpose of rendering a Scenario file
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

127
src/Swarm/Game/Scenario/WorldPalette.hs Normal file
View File

@ -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

2
src/Swarm/Game/State.hs
View File

@ -719,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) -> (W.Coords, W.Coords)
viewingRegion :: GameState -> (Int32, Int32) -> W.BoundsRectangle
viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax))
where
Location cx cy = g ^. viewCenter

8
src/Swarm/Game/Terrain.hs
View File

@ -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 =

5
src/Swarm/Game/World.hs
View File

@ -17,6 +17,7 @@ module Swarm.Game.World (
Coords (..),
locToCoords,
coordsToLoc,
BoundsRectangle,
-- * Worlds
WorldFun (..),
@ -87,6 +88,10 @@ 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
------------------------------------------------------------

69
src/Swarm/TUI/Controller.hs
View File

@ -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,10 @@ handleModalEvent = \case
Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev)
modal <- preuse $ uiState . uiModal . _Just . modalType
case modal of
Just TerrainPaletteModal ->
refreshList $ uiState . uiWorldEditor . terrainList
Just EntityPaletteModal -> do
refreshList $ uiState . uiWorldEditor . entityPaintList
Just GoalModal -> case ev of
V.EvKey (V.KChar '\t') [] -> uiState . uiGoal . focus %= focusNext
_ -> do
@ -458,13 +475,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 z = Brick.zoom z $ BL.handleListEvent ev
getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath)
getNormalizedCurrentScenarioPath =
@ -928,17 +946,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

30
src/Swarm/TUI/Controller/Util.hs
View File

@ -7,10 +7,11 @@ 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
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,30 @@ 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
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
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)

50
src/Swarm/TUI/Editor/Area.hs Normal file
View File

@ -0,0 +1,50 @@
{-# 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.
-- Inverse of "cornersToArea".
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".
-- Inverse of "upperLeftToBottomRight".
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

143
src/Swarm/TUI/Editor/Controller.hs Normal file
View File

@ -0,0 +1,143 @@
{-# 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 (forM_, guard, when)
import Control.Monad.Extra (whenJust)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Map qualified as M
import Data.Yaml qualified as Y
import Graphics.Vty qualified as V
import Swarm.Game.Scenario.EntityFacade
import Swarm.Game.State
import Swarm.Game.World qualified as W
import Swarm.TUI.Controller.Util
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 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 (#1151): 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
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
-- | 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 (#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)
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
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."

20
src/Swarm/TUI/Editor/Json.hs Normal file
View File

@ -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

30
src/Swarm/TUI/Editor/Masking.hs Normal file
View File

@ -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

87
src/Swarm/TUI/Editor/Model.hs Normal file
View File

@ -0,0 +1,87 @@
{-# 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.WorldPalette
import Swarm.Game.Terrain (TerrainType)
import Swarm.Game.World qualified as W
import Swarm.TUI.Model.Name
import Swarm.Util
import System.Clock
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 -> mkFacade e
getEntityName :: EntityFacade -> EntityName
getEntityName (EntityFacade name _) = name
data MapEditingBounds = MapEditingBounds
{ _boundsRect :: Maybe W.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 (TerrainWith EntityFacade)
, _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

137
src/Swarm/TUI/Editor/Palette.hs Normal file
View File

@ -0,0 +1,137 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- SPDX-License-Identifier: BSD-3-Clause
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.WorldPalette
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

118
src/Swarm/TUI/Editor/Util.hs Normal file
View File

@ -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 mkFacade entities
where
entities = M.elems $ entitiesByName em
getEditingBounds :: WorldDescription -> (Bool, W.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
W.BoundsRectangle ->
-- | current coords
W.Coords ->
Bool
isOutsideRegion (tl, br) coord =
isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord
getEditedMapRectangle ::
WorldEditor Name ->
Maybe W.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]

159
src/Swarm/TUI/Editor/View.hs Normal file
View File

@ -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 (#1150): 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

2
src/Swarm/TUI/Model/Menu.hs
View File

@ -44,6 +44,8 @@ data ModalType
| RecipesModal
| CommandsModal
| MessagesModal
| EntityPaletteModal
| TerrainPaletteModal
| RobotsModal
| ScenarioEndModal ScenarioOutcome
| QuitModal

21
src/Swarm/TUI/Model/Name.hs
View File

@ -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

25
src/Swarm/TUI/Model/StateUpdate.hs
View File

@ -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

10
src/Swarm/TUI/Model/UI.hs
View File

@ -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

44
src/Swarm/TUI/View.hs
View File

@ -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

63
src/Swarm/TUI/View/CellDisplay.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Rendering of cells in the map view
--
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.TUI.View.CellDisplay where
@ -16,11 +20,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 +38,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
known e =
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 (Facade (EntityFacade _ _)) = True
known (Ref e) =
e
`hasProperty` Known
|| (e ^. entityName)
@ -63,16 +88,18 @@ 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

23
src/Swarm/TUI/View/Util.hs
View File

@ -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

12
src/Swarm/Util.hs
View File

@ -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

11
swarm.cabal
View File

@ -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
@ -120,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
@ -150,6 +152,14 @@ 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.Palette
Swarm.TUI.Editor.Util
Swarm.TUI.Editor.View
Swarm.TUI.Controller
Swarm.TUI.Controller.Util
Swarm.TUI.Inventory.Sorting
@ -207,6 +217,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,