diff --git a/src/Swarm/App.hs b/src/Swarm/App.hs index d0030c4d30..2928bb6a3a 100644 --- a/src/Swarm/App.hs +++ b/src/Swarm/App.hs @@ -23,6 +23,7 @@ import Swarm.Game.Robot (LogSource (ErrorTrace, Said)) import Swarm.TUI.Attr import Swarm.TUI.Controller import Swarm.TUI.Model +import Swarm.TUI.Model.ScenarioState import Swarm.TUI.View import Swarm.Version (getNewerReleaseVersion) import Swarm.Web diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index af60096ab6..b3b924151d 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -23,12 +23,15 @@ module Swarm.Game.Scenario ( objectiveCondition, -- * WorldDescription - Cell (..), - WorldDescription (..), + ProtoCell (..), + Cell, + ProtoWorldDescription (..), + WorldDescription, + WorldPalette (..), IndexedTRobot, -- * Scenario - Scenario, + Scenario (..), -- ** Fields scenarioVersion, @@ -55,26 +58,20 @@ module Swarm.Game.Scenario ( import Control.Algebra (Has) import Control.Carrier.Lift (Lift, sendIO) import Control.Carrier.Throw.Either (Throw, throwError) -import Control.Lens hiding (from, (<.>)) -import Control.Monad (filterM, when) -import Control.Monad.Extra (mapMaybeM) -import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap (KeyMap) -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Map (Map) +import Control.Lens hiding (from, (.=), (<.>)) +import Control.Monad (filterM) import Data.Map qualified as M import Data.Maybe (catMaybes, isNothing, listToMaybe) import Data.Text (Text) import Data.Text qualified as T -import Data.Vector qualified as V import Data.Yaml as Y import GHC.Generics (Generic) -import GHC.Int (Int64) -import Linear.V2 import Swarm.Game.Entity import Swarm.Game.Recipe import Swarm.Game.Robot (TRobot, trobotName) -import Swarm.Game.Terrain +import Swarm.Game.Scenario.Cells +import Swarm.Game.Scenario.ScenarioUtil +import Swarm.Game.Scenario.WorldDescription import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Util (getDataFileNameSafe, reflow) import Swarm.Util.Yaml @@ -116,122 +113,10 @@ instance FromJSON Objective where -- Robot map ------------------------------------------------------------ --- | A robot template paired with its definition's index within --- the Scenario file -type IndexedTRobot = (Int, TRobot) - --- | A map from names to robots, used to look up robots in scenario --- descriptions. -type RobotMap = Map Text IndexedTRobot - -- | Create a 'RobotMap' from a list of robot templates. buildRobotMap :: [TRobot] -> RobotMap buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 ..] rs ------------------------------------------------------------- --- Lookup utilities ------------------------------------------------------------- - --- | Look up a thing by name, throwing a parse error if it is not --- found. -getThing :: String -> (Text -> m -> Maybe a) -> Text -> ParserE m a -getThing thing lkup name = do - m <- getE - case lkup name m of - Nothing -> fail $ "Unknown " <> thing <> " name: " ++ show name - Just a -> return a - --- | Look up an entity by name in an 'EntityMap', throwing a parse --- error if it is not found. -getEntity :: Text -> ParserE EntityMap Entity -getEntity = getThing "entity" lookupEntityName - --- | Look up a robot by name in a 'RobotMap', throwing a parse error --- if it is not found. -getRobot :: Text -> ParserE RobotMap IndexedTRobot -getRobot = getThing "robot" M.lookup - ------------------------------------------------------------- --- World cells ------------------------------------------------------------- - --- | A single cell in a world map, which contains a terrain value, --- and optionally an entity and robot. -data Cell = Cell - { cellTerrain :: TerrainType - , cellEntity :: Maybe Entity - , cellRobots :: [IndexedTRobot] - } - deriving (Eq, Show) - --- | 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 --- found, a parse error results. -instance FromJSONE (EntityMap, RobotMap) Cell where - parseJSONE = withArrayE "tuple" $ \v -> do - let tup = V.toList v - when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)" - - terr <- liftE $ parseJSON (head tup) - - ent <- case tup ^? ix 1 of - Nothing -> return Nothing - Just e -> do - meName <- liftE $ parseJSON @(Maybe Text) e - traverse (localE fst . getEntity) meName - - let name2rob r = do - mrName <- liftE $ parseJSON @(Maybe Text) r - traverse (localE snd . getRobot) mrName - - robs <- mapMaybeM name2rob (drop 2 tup) - - return $ Cell terr ent robs - ------------------------------------------------------------- --- World description ------------------------------------------------------------- - --- | A world palette maps characters to 'Cell' values. -newtype WorldPalette = WorldPalette - {unPalette :: KeyMap Cell} - deriving (Eq, Show) - -instance FromJSONE (EntityMap, RobotMap) WorldPalette where - parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE - --- | A description of a world parsed from a YAML file. -data WorldDescription = WorldDescription - { defaultTerrain :: Maybe Cell - , offsetOrigin :: Bool - , palette :: WorldPalette - , ul :: V2 Int64 - , area :: [[Cell]] - } - deriving (Eq, Show) - -instance FromJSONE (EntityMap, RobotMap) WorldDescription where - parseJSONE = withObjectE "world description" $ \v -> do - pal <- v ..:? "palette" ..!= WorldPalette mempty - WorldDescription - <$> v ..:? "default" - <*> liftE (v .:? "offset" .!= False) - <*> pure pal - <*> liftE (v .:? "upperleft" .!= V2 0 0) - <*> liftE ((v .:? "map" .!= "") >>= paintMap pal) - --- | "Paint" a world map using a 'WorldPalette', turning it from a raw --- string into a nested list of 'Cell' values by looking up each --- character in the palette, failing if any character in the raw map --- is not contained in the palette. -paintMap :: MonadFail m => WorldPalette -> Text -> m [[Cell]] -paintMap pal = traverse (traverse toCell . into @String) . T.lines - where - toCell c = case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of - Nothing -> fail $ "Char not in world palette: " ++ show c - Just cell -> return cell - ------------------------------------------------------------ -- Scenario ------------------------------------------------------------ diff --git a/src/Swarm/Game/Scenario/Cells.hs b/src/Swarm/Game/Scenario/Cells.hs new file mode 100644 index 0000000000..ab9a4e023b --- /dev/null +++ b/src/Swarm/Game/Scenario/Cells.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.Game.Scenario.Cells where + +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.ScenarioUtil +import Swarm.Game.Terrain +import Swarm.Util.Yaml + +------------------------------------------------------------ +-- World cells +------------------------------------------------------------ + +data ProtoCell e = Cell + { cellTerrain :: TerrainType + , cellEntity :: Maybe e + , cellRobots :: [IndexedTRobot] + } + deriving (Eq, Show) + +-- | A single cell in a world map, which contains a terrain value, +-- and optionally an entity and robot. +type Cell = ProtoCell Entity + +-- Note: This is used only for the purpose of WorldPalette +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 +-- found, a parse error results. +instance FromJSONE (EntityMap, RobotMap) Cell where + parseJSONE = withArrayE "tuple" $ \v -> do + let tup = V.toList v + when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)" + + terr <- liftE $ parseJSON (head tup) + + ent <- case tup ^? ix 1 of + Nothing -> return Nothing + Just e -> do + meName <- liftE $ parseJSON @(Maybe Text) e + traverse (localE fst . getEntity) meName + + let name2rob r = do + mrName <- liftE $ parseJSON @(Maybe Text) r + traverse (localE snd . getRobot) mrName + + robs <- mapMaybeM name2rob (drop 2 tup) + + return $ Cell terr ent robs + +------------------------------------------------------------ +-- World editor +------------------------------------------------------------ + +type CellPaintDisplay = ProtoCell EntityFacadeData + +-- 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 0000000000..e03b1d27e3 --- /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 EntityFacadeData = EntityFacadeData EntityName Display + deriving (Eq) + +-- Note: This instance is used only for the purpose of WorldPalette +instance ToJSON EntityFacadeData where + toJSON (EntityFacadeData eName _display) = toJSON eName + +mkPaint :: E.Entity -> EntityFacadeData +mkPaint e = + EntityFacadeData + (e ^. E.entityName) + (e ^. E.entityDisplay) diff --git a/src/Swarm/Game/Scenario/ScenarioUtil.hs b/src/Swarm/Game/Scenario/ScenarioUtil.hs new file mode 100644 index 0000000000..d7f6326220 --- /dev/null +++ b/src/Swarm/Game/Scenario/ScenarioUtil.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.Game.Scenario.ScenarioUtil where + +import Data.Map (Map) +import Data.Map qualified as M +import Data.Text (Text) +import Swarm.Game.Entity +import Swarm.Game.Robot (TRobot) +import Swarm.Util.Yaml + +------------------------------------------------------------ +-- Robot map +------------------------------------------------------------ + +-- | A robot template paired with its definition's index within +-- the Scenario file +type IndexedTRobot = (Int, TRobot) + +-- | A map from names to robots, used to look up robots in scenario +-- descriptions. +type RobotMap = Map Text IndexedTRobot + +------------------------------------------------------------ +-- Lookup utilities +------------------------------------------------------------ + +-- | Look up a thing by name, throwing a parse error if it is not +-- found. +getThing :: String -> (Text -> m -> Maybe a) -> Text -> ParserE m a +getThing thing lkup name = do + m <- getE + case lkup name m of + Nothing -> fail $ "Unknown " <> thing <> " name: " ++ show name + Just a -> return a + +-- | Look up an entity by name in an 'EntityMap', throwing a parse +-- error if it is not found. +getEntity :: Text -> ParserE EntityMap Entity +getEntity = getThing "entity" lookupEntityName + +-- | Look up a robot by name in a 'RobotMap', throwing a parse error +-- if it is not found. +getRobot :: Text -> ParserE RobotMap IndexedTRobot +getRobot = getThing "robot" M.lookup diff --git a/src/Swarm/Game/Scenario/WorldDescription.hs b/src/Swarm/Game/Scenario/WorldDescription.hs new file mode 100644 index 0000000000..abf06fccc3 --- /dev/null +++ b/src/Swarm/Game/Scenario/WorldDescription.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +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 GHC.Int (Int64) +import Linear.V2 +import Swarm.Game.Entity +import Swarm.Game.Scenario.Cells +import Swarm.Game.Scenario.EntityFacade +import Swarm.Game.Scenario.ScenarioUtil +import Swarm.Game.Terrain (TerrainType) +import Swarm.Util.Yaml +import Witch (into) + +------------------------------------------------------------ +-- World description +------------------------------------------------------------ + +-- | A world palette maps characters to 'Cell' values. +newtype WorldPalette c = WorldPalette + {unPalette :: KeyMap c} + deriving (Eq, Show) + +instance FromJSONE (EntityMap, RobotMap) (WorldPalette Cell) where + parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE + +-- | A description of a world parsed from a YAML file. +data ProtoWorldDescription c = WorldDescription + { defaultTerrain :: Maybe c + , offsetOrigin :: Bool + , palette :: WorldPalette c + , ul :: V2 Int64 + , area :: [[c]] + } + deriving (Eq, Show) + +type WorldDescription = ProtoWorldDescription Cell + +instance FromJSONE (EntityMap, RobotMap) WorldDescription where + parseJSONE = withObjectE "world description" $ \v -> do + pal <- v ..:? "palette" ..!= WorldPalette mempty + WorldDescription + <$> v ..:? "default" + <*> liftE (v .:? "offset" .!= False) + <*> pure pal + <*> liftE (v .:? "upperleft" .!= V2 0 0) + <*> liftE ((v .:? "map" .!= "") >>= paintMap pal) + +-- | "Paint" a world map using a 'WorldPalette', turning it from a raw +-- string into a nested list of 'Cell' values by looking up each +-- character in the palette, failing if any character in the raw map +-- is not contained in the palette. +paintMap :: MonadFail m => WorldPalette Cell -> Text -> m [[Cell]] +paintMap pal = traverse (traverse toCell . into @String) . T.lines + where + 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 EntityFacadeData) + +cellToTerrainEntityNamePair :: CellPaintDisplay -> TerrainEntityFacadePair +cellToTerrainEntityNamePair (Cell terrain maybeEntity _) = (terrain, maybeEntity) + +toCellPaintDisplay :: Cell -> CellPaintDisplay +toCellPaintDisplay (Cell terrain maybeEntity r) = + Cell terrain (mkPaint <$> maybeEntity) r + +type WorldDescriptionPaint = ProtoWorldDescription CellPaintDisplay + +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 (\(EntityFacadeData 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 + +-- | Note that display characters are not unique +-- across different entities! However, the palette KeyMap +-- as a conveyance serves to dedupe them. +prepForJson :: + WorldPalette CellPaintDisplay -> + [[CellPaintDisplay]] -> + (Text, KM.KeyMap CellPaintDisplay) +prepForJson (WorldPalette suggestedPalette) cellGrid = + (renderFullMap cellGrid, paletteKeymap) + 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: Make this pool larger? + Set.difference (Set.fromList ['a' .. 'z']) $ + Set.fromList $ map fst preassignments + + newlyAssignedPairs :: [(Char, TerrainEntityFacadePair)] + newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells + + mappedPairs :: [(Char, TerrainEntityFacadePair)] + mappedPairs = preassignments <> newlyAssignedPairs + + invertedMappedPairs :: [(TerrainEntityNamePair, Char)] + 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 + + renderFullMap = T.unlines . map (T.pack . map renderMapCell) + + g (terrain, maybeEfd) = Cell terrain maybeEfd [] + terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs + + paletteKeymap :: KM.KeyMap (ProtoCell EntityFacadeData) + paletteKeymap = KM.fromMapText terrainEntityPalette diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs index 9df1157591..23deba1d7e 100644 --- a/src/Swarm/Game/Terrain.hs +++ b/src/Swarm/Game/Terrain.hs @@ -10,6 +10,8 @@ module Swarm.Game.Terrain ( -- * Terrain TerrainType (..), terrainMap, + getTerrainDefaultPaletteChar, + getTerrainWord, ) where import Data.Aeson (FromJSON (..), withText) @@ -37,6 +39,12 @@ instance FromJSON TerrainType where Just ter -> return ter Nothing -> fail $ "Unknown terrain type: " ++ into @String 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 8f29764845..be2ac1480b 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Swarm.TUI.Controller @@ -51,6 +50,7 @@ import Control.Lens.Extras (is) import Control.Monad.Except import Control.Monad.Extra (whenJust) import Control.Monad.State +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits import Data.Either (isRight) import Data.Int (Int64) @@ -67,6 +67,7 @@ import Linear import Swarm.Game.CESK (cancel, emptyStore, initMachine) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Robot +import Swarm.Game.Scenario.EntityFacade import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.Step (gameTick) @@ -81,33 +82,20 @@ import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types +import Swarm.TUI.Controller.ControllerUtils +import Swarm.TUI.Editor.EditorController qualified as EC +import Swarm.TUI.Editor.EditorModel +import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) import Swarm.TUI.List import Swarm.TUI.Model -import Swarm.TUI.View (generateModal) +import Swarm.TUI.Model.ScenarioState +import Swarm.TUI.View.ViewUtils (generateModal) import Swarm.Util hiding ((<<.=)) import Swarm.Version (NewReleaseFailure (..)) import System.Clock import Witch (into) --- | Pattern synonyms to simplify brick event handler -pattern Key :: V.Key -> BrickEvent n e -pattern Key k = VtyEvent (V.EvKey k []) - -pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e -pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) []) -pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl]) -pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta]) - -pattern ShiftKey :: V.Key -> BrickEvent n e -pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift]) - -pattern EscapeKey :: BrickEvent n e -pattern EscapeKey = VtyEvent (V.EvKey V.KEsc []) - -pattern FKey :: Int -> BrickEvent n e -pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) - -- | The top-level event handler for the TUI. handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleEvent = \case @@ -289,18 +277,73 @@ 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 n V.BRight _ mouseLoc -> do + let worldEditor = s ^. uiState . uiWorldEditor + case (n, worldEditor ^. isWorldEditorEnabled) of + -- "Eye Dropper" tool: + (FocusablePanel WorldPanel, True) -> do + mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + whenJust mouseCoordsM setTerrainPaint + where + setTerrainPaint coords = do + uiState . uiWorldEditor . terrainList %= BL.listMoveToElement terrain + + case maybeElementPaint of + Nothing -> return () + Just elementPaint -> + uiState . uiWorldEditor . entityPaintList %= BL.listMoveToElement p + where + p = case elementPaint of + EntityFacade efd -> efd + EntityRef r -> mkPaint r + where + (terrain, maybeElementPaint) = + EU.getContentAt + worldEditor + (s ^. gameState . world) + coords + _ -> continueWithoutRedraw + MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] 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 + terrain <- MaybeT . pure $ maybeTerrainType + mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + -- TODO: Screen updates are laggy, and the needsRedraw flag doesn't seem to help + uiState . uiWorldEditor . paintedTerrain %= M.insert mouseCoords (terrain, maybeEntityPaint) + uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing + + return () 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. @@ -311,6 +354,7 @@ handleMainEvent ev = do InventoryListItem _ -> Just RobotPanel InfoViewport -> Just InfoPanel REPLInput -> Just REPLPanel + WorldEditorPanelControl _ -> Just WorldEditorPanel _ -> Nothing case n of FocusablePanel x -> setFocus x @@ -322,6 +366,7 @@ handleMainEvent ev = do Just (FocusablePanel x) -> ($ ev) $ case x of REPLPanel -> handleREPLEvent WorldPanel -> handleWorldEvent + WorldEditorPanel -> EC.handleWorldEditorPanelEvent RobotPanel -> handleRobotPanelEvent InfoPanel -> handleInfoPanelEvent infoScroll _ -> continueWithoutRedraw @@ -339,9 +384,6 @@ mouseLocToWorldCoords (Brick.Location mouseLoc) = do my = fst mouseLoc' + snd regionStart in pure . Just $ W.Coords (mx, my) -setFocus :: FocusablePanel -> EventM Name AppState () -setFocus name = uiState . uiFocusRing %= focusSetCurrent (FocusablePanel name) - -- | 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 @@ -367,21 +409,8 @@ toggleModal :: ModalType -> EventM Name AppState () toggleModal mt = do modal <- use $ uiState . uiModal case modal of - Nothing -> do - newModal <- gets $ flip generateModal mt - ensurePause - uiState . uiModal ?= newModal + Nothing -> openModal mt Just _ -> uiState . uiModal .= Nothing >> safeAutoUnpause - where - -- Set the game to AutoPause if needed - ensurePause = do - pause <- use $ gameState . paused - unless (pause || isRunningModal mt) $ do - gameState . runStatus .= AutoPause - --- | The running modals do not autopause the game. -isRunningModal :: ModalType -> Bool -isRunningModal mt = mt `elem` [RobotsModal, MessagesModal] handleModalEvent :: V.Event -> EventM Name AppState () handleModalEvent = \case @@ -398,8 +427,18 @@ handleModalEvent = \case Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev) modal <- preuse $ uiState . uiModal . _Just . modalType case modal of + Just TerrainPaletteModal -> do + listWidget <- use $ uiState . uiWorldEditor . terrainList + newList <- refreshList listWidget + uiState . uiWorldEditor . terrainList .= newList + Just EntityPaletteModal -> do + listWidget <- use $ uiState . uiWorldEditor . entityPaintList + newList <- refreshList listWidget + uiState . uiWorldEditor . entityPaintList .= newList Just _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> return () + where + refreshList listWidget = nestEventM' listWidget $ BL.handleListEvent ev -- | Write the @ScenarioInfo@ out to disk when exiting a game. saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () diff --git a/src/Swarm/TUI/Controller/ControllerUtils.hs b/src/Swarm/TUI/Controller/ControllerUtils.hs new file mode 100644 index 0000000000..6472d21a67 --- /dev/null +++ b/src/Swarm/TUI/Controller/ControllerUtils.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Swarm.TUI.Controller.ControllerUtils where + +import Brick hiding (Direction) +import Brick.Focus +import Control.Lens +import Control.Monad (unless) +import Graphics.Vty qualified as V +import Swarm.Game.State +import Swarm.TUI.Model +import Swarm.TUI.View.ViewUtils (generateModal) + +-- | Pattern synonyms to simplify brick event handler +pattern Key :: V.Key -> BrickEvent n e +pattern Key k = VtyEvent (V.EvKey k []) + +pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e +pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) []) +pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl]) +pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta]) + +pattern ShiftKey :: V.Key -> BrickEvent n e +pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift]) + +pattern EscapeKey :: BrickEvent n e +pattern EscapeKey = VtyEvent (V.EvKey V.KEsc []) + +pattern FKey :: Int -> BrickEvent n e +pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) + +openModal :: ModalType -> EventM Name AppState () +openModal mt = do + newModal <- gets $ flip generateModal mt + ensurePause + uiState . uiModal ?= newModal + where + -- Set the game to AutoPause if needed + ensurePause = do + pause <- use $ gameState . paused + unless (pause || isRunningModal mt) $ do + gameState . runStatus .= AutoPause + +-- | The running modals do not autopause the game. +isRunningModal :: ModalType -> Bool +isRunningModal mt = mt `elem` [RobotsModal, MessagesModal] + +setFocus :: FocusablePanel -> EventM Name AppState () +setFocus name = uiState . uiFocusRing %= focusSetCurrent (FocusablePanel name) diff --git a/src/Swarm/TUI/Editor/EditorController.hs b/src/Swarm/TUI/Editor/EditorController.hs new file mode 100644 index 0000000000..ada8b86a2c --- /dev/null +++ b/src/Swarm/TUI/Editor/EditorController.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.Editor.EditorController where + +import Brick hiding (Direction (..)) +import Brick.Focus +import Control.Lens +import Control.Monad (guard) +import Control.Monad.IO.Class (liftIO) +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 Linear (V2 (..)) +import Swarm.Game.Display (Display, defaultChar) +import Swarm.Game.Entity (entitiesByName) +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Cells +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.ControllerUtils +import Swarm.TUI.Editor.EditorJson (SkeletonScenario (SkeletonScenario)) +import Swarm.TUI.Editor.EditorModel +import Swarm.TUI.Editor.Util qualified as EU +import Swarm.TUI.Model +import Swarm.TUI.Model.Names +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 + +-- | 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 + EntityFacadeData eName d <- maybeEntity + return (eName, d) + + getMaybeEntityNameTerrainPair (Cell terrain maybeEntity _) = do + EntityFacadeData 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 $ EntityFacadeData eName eDisplay) [] + return ((terrain, Just eName), (T.singleton displayChar, cell)) + + 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 + , palette = WorldPalette suggestedPalette + , ul = upperLeftCoord + , area = cellGrid + } + + suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid + + upperLeftCoord = + V2 + (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/EditorJson.hs b/src/Swarm/TUI/Editor/EditorJson.hs new file mode 100644 index 0000000000..1175ee6c7d --- /dev/null +++ b/src/Swarm/TUI/Editor/EditorJson.hs @@ -0,0 +1,20 @@ +module Swarm.TUI.Editor.EditorJson 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/EditorModel.hs b/src/Swarm/TUI/Editor/EditorModel.hs new file mode 100644 index 0000000000..d428252280 --- /dev/null +++ b/src/Swarm/TUI/Editor/EditorModel.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Swarm.TUI.Editor.EditorModel where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (from, (.=), (<.>)) +import Data.Int (Int64) +import Data.Map qualified as M +import Data.Maybe (listToMaybe) +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.Terrain (TerrainType) +import Swarm.Game.World qualified as W +import Swarm.TUI.Model.Names +import Swarm.Util +import System.Clock + +data AreaDimensions = AreaDimensions + { rectWidth :: Int64 + , rectHeight :: Int64 + } + +getAreaDimensions :: [[a]] -> AreaDimensions +getAreaDimensions cellGrid = + AreaDimensions w h + where + w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid + h = fromIntegral $ length cellGrid + +data BoundsSelectionStep + = UpperLeftPending + | -- | Stores the *mouse coords* of the upper-left click + LowerRightPending W.Coords + | SelectionComplete + +data EntityPaint + = EntityFacade EntityFacadeData + | EntityRef E.Entity + deriving (Eq) + +getDisplay :: EntityPaint -> Display +getDisplay (EntityFacade (EntityFacadeData _ d)) = d +getDisplay (EntityRef e) = e ^. E.entityDisplay + +toFacade :: EntityPaint -> EntityFacadeData +toFacade = \case + EntityFacade f -> f + EntityRef e -> mkPaint e + +getEntityName :: EntityFacadeData -> EntityName +getEntityName (EntityFacadeData name _) = name + +data MapEditingBounds = MapEditingBounds + { -- | Upper-left and lower-right coordinates + -- of the map to be saved. + _boundsRect :: Maybe (W.Coords, W.Coords) + , _boundsPersistDisplayUntil :: TimeSpec + , _boundsSelectionStep :: BoundsSelectionStep + } + +makeLenses ''MapEditingBounds + +data WorldEditor n = WorldEditor + { _isWorldEditorEnabled :: Bool + , _terrainList :: BL.List n TerrainType + , -- | This field has deferred initialization; it gets populated when a game + -- is initialized. + _entityPaintList :: BL.List n EntityFacadeData + , _paintedTerrain :: M.Map W.Coords (TerrainType, Maybe EntityFacadeData) + , _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 + (Just (W.Coords (-10, -20), W.Coords (10, 20))) + (ts - 1) + SelectionComplete diff --git a/src/Swarm/TUI/Editor/EditorView.hs b/src/Swarm/TUI/Editor/EditorView.hs new file mode 100644 index 0000000000..2c24afc0e0 --- /dev/null +++ b/src/Swarm/TUI/Editor/EditorView.hs @@ -0,0 +1,168 @@ +module Swarm.TUI.Editor.EditorView 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 Data.Maybe (fromMaybe) +import Swarm.Game.Display (renderDisplay) +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.EditorModel +import Swarm.TUI.Editor.Util qualified as EU +import Swarm.TUI.Model +import Swarm.TUI.Model.Names +import Swarm.TUI.Panel +import Swarm.TUI.View.ViewUtils +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 + , 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) drawLabeledTerrainSwatch + + entityWidget = + mkFormControl (WorldEditorPanelControl EntitySelector) $ + padRight (Pad 1) (str "Entity:") + <+> swatchContent (worldEditor ^. entityPaintList) drawLabeledEntitySwatch + + 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 (W.Coords (x1, y1), W.Coords (x2, y2)) = + str $ + L.intercalate + " @ " + [ rectSize + , show (y1, x1) -- Note the inverted coords! + ] + where + -- Note that the width and height are swapped! + myHeight = x2 - x1 + myWidth = y2 - y1 + rectSize = L.intercalate "x" [show myWidth, show myHeight] + + 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 + +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 + +drawLabeledEntitySwatch :: EntityFacadeData -> Widget Name +drawLabeledEntitySwatch (EntityFacadeData 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) $ drawLabeledTerrainSwatch a + +drawEntityPaintSelector :: AppState -> Widget Name +drawEntityPaintSelector s = + padAll 1 $ + hCenter $ + vLimit 10 $ + BL.renderListWithIndex listDrawEntityPaintElement True $ + s ^. uiState . uiWorldEditor . entityPaintList + +listDrawEntityPaintElement :: Int -> Bool -> EntityFacadeData -> Widget Name +listDrawEntityPaintElement pos _isSelected a = + clickable (EntityPaintListItem pos) $ drawLabeledEntitySwatch a diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs new file mode 100644 index 0000000000..477528650c --- /dev/null +++ b/src/Swarm/TUI/Editor/Util.hs @@ -0,0 +1,95 @@ +module Swarm.TUI.Editor.Util where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (Const, from) +import Control.Monad (guard) +import Data.Int (Int64) +import Data.Map qualified as Map +import Data.Maybe qualified as Maybe +import Swarm.Game.Entity (Entity) +import Swarm.Game.Scenario.Cells +import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.World qualified as W +import Swarm.TUI.Editor.EditorModel +import Swarm.TUI.Model + +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 + EntityFacade <$> e + + maybePaintedCell = do + guard $ editor ^. isWorldEditorEnabled + Map.lookup coords paintMap + + paintMap = editor ^. paintedTerrain + + entityWithOverride = (EntityRef <$> 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 :: + -- | corner coords + W.Coords -> + -- | current coords + W.Coords -> + Bool +isOutsideTopLeftCorner (W.Coords (xLeft, yTop)) (W.Coords (x, y)) = + x < xLeft || y < yTop + +isOutsideRegion :: + -- | full bounds + (W.Coords, W.Coords) -> + -- | current coords + W.Coords -> + Bool +isOutsideRegion (tl, W.Coords (xRight, yBottom)) c@(W.Coords (x, y)) = + isOutsideTopLeftCorner tl c + || (x > xRight || y > yBottom) + +getEditedMapRectangle :: + WorldEditor Name -> + Maybe (W.Coords, W.Coords) -> + W.World Int Entity -> + [[CellPaintDisplay]] +getEditedMapRectangle _ Nothing _ = [] +getEditedMapRectangle worldEditor (Just (tl, br)) w = + map renderRow [yTop .. yBottom] + where + -- We swap the horizontal and vertical coordinate. + -- TODO If this is necessary, then what is mouseLocToWorldCoords for? + toWorldCoords (W.Coords (mx, my)) = W.Coords (my, mx) + + W.Coords (xLeft, yTop) = toWorldCoords tl + W.Coords (xRight, yBottom) = toWorldCoords br + + getContent = getContentAt worldEditor w + + drawCell :: Int64 -> Int64 -> 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/Model.hs b/src/Swarm/TUI/Model.hs index e97600957e..b0edf6680a 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -69,6 +69,7 @@ module Swarm.TUI.Model ( uiCheatMode, uiFocusRing, uiWorldCursor, + uiWorldEditor, uiREPL, uiInventory, uiInventorySort, @@ -129,17 +130,13 @@ module Swarm.TUI.Model ( logEvent, -- * App state - AppState, + AppState (AppState), gameState, uiState, runtimeState, -- ** Initialization AppOpts (..), - initAppState, - startGame, - restartGame, - scenarioToAppState, Seed, -- *** Re-exported types used in options @@ -158,7 +155,7 @@ import Brick.Focus import Brick.Widgets.Dialog (Dialog) import Brick.Widgets.Edit (Editor, applyEdit, editorText, getEditContents) import Brick.Widgets.List qualified as BL -import Control.Applicative (Applicative (liftA2), (<|>)) +import Control.Applicative (Applicative (liftA2)) import Control.Lens hiding (from, (<.>)) import Control.Monad.Except import Control.Monad.State @@ -175,7 +172,6 @@ import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Text qualified as T import Data.Text.Zipper qualified as TZ -import Data.Time (getZonedTime) import Data.Vector qualified as V import GitHash (GitInfo) import Graphics.Vty (ColorMode (..)) @@ -183,26 +179,21 @@ import Linear (zero) import Network.Wai.Handler.Warp (Port) import Swarm.Game.Entity as E import Swarm.Game.Robot -import Swarm.Game.Scenario (loadScenario) import Swarm.Game.ScenarioInfo ( ScenarioCollection, ScenarioInfo (..), ScenarioInfoPair, ScenarioItem (..), - ScenarioStatus (..), - normalizeScenarioPath, scMap, scenarioCollectionToList, - scenarioItemByPath, - scenarioPath, - scenarioSolution, - scenarioStatus, _SISingle, ) import Swarm.Game.State import Swarm.Game.World qualified as W import Swarm.Language.Types +import Swarm.TUI.Editor.EditorModel import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model.Names import Swarm.Util import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease)) import System.Clock @@ -225,42 +216,6 @@ data AppEvent | UpstreamVersion (Either NewReleaseFailure String) deriving (Show) -data FocusablePanel - = -- | The panel containing the REPL. - REPLPanel - | -- | The panel containing the world view. - WorldPanel - | -- | The panel showing robot info and inventory on the top left. - RobotPanel - | -- | The info panel on the bottom left. - InfoPanel - deriving (Eq, Ord, Show, Read, Bounded, Enum) - --- | 'Name' represents names to uniquely identify various components --- of the UI, such as forms, panels, caches, extents, and lists. -data Name - = FocusablePanel FocusablePanel - | -- | The REPL input form. - REPLInput - | -- | The render cache for the world view. - WorldCache - | -- | The cached extent for the world view. - WorldExtent - | -- | The list of inventory items for the currently - -- focused robot. - InventoryList - | -- | The inventory item position in the InventoryList. - InventoryListItem Int - | -- | The list of main menu choices. - MenuList - | -- | The list of scenario choices. - ScenarioList - | -- | The scrollable viewport for the info panel. - InfoViewport - | -- | The scrollable viewport for any modal dialog. - ModalViewport - deriving (Eq, Ord, Show, Read) - infoScroll :: ViewportScroll Name infoScroll = viewportScroll InfoViewport @@ -488,6 +443,8 @@ data ModalType | KeepPlayingModal | DescriptionModal Entity | GoalModal [Text] + | TerrainPaletteModal + | EntityPaletteModal deriving (Eq, Show) data ButtonSelection = CancelButton | KeepPlayingButton | StartOverButton Seed ScenarioInfoPair | QuitButton | NextButton ScenarioInfoPair @@ -570,6 +527,7 @@ data UIState = UIState , _uiCheatMode :: Bool , _uiFocusRing :: FocusRing Name , _uiWorldCursor :: Maybe W.Coords + , _uiWorldEditor :: WorldEditor Name , _uiREPL :: REPLState , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry) , _uiInventorySort :: InventorySortOptions @@ -626,6 +584,9 @@ uiFocusRing :: Lens' UIState (FocusRing Name) -- | The last clicked position on the world view. uiWorldCursor :: Lens' UIState (Maybe W.Coords) +-- | World editor mode +uiWorldEditor :: Lens' UIState (WorldEditor Name) + -- | The state of REPL panel. uiREPL :: Lens' UIState REPLState @@ -824,6 +785,9 @@ focusedEntity = -- 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 @@ -849,6 +813,7 @@ initUIState showMainMenu cheatMode = liftIO $ do , _uiCheatMode = cheatMode , _uiFocusRing = initFocusRing , _uiWorldCursor = Nothing + , _uiWorldEditor = initialWorldEditor startTime , _uiREPL = initREPLState $ newREPLHistory history , _uiInventory = Nothing , _uiInventorySort = defaultSortOptions @@ -951,56 +916,6 @@ data AppOpts = AppOpts repoGitInfo :: Maybe GitInfo } --- | Initialize the 'AppState'. -initAppState :: AppOpts -> ExceptT Text IO AppState -initAppState AppOpts {..} = do - let isRunningInitialProgram = isJust scriptToRun || autoPlay - skipMenu = isJust userScenario || isRunningInitialProgram || isJust userSeed - gs <- initGameState - ui <- initUIState (not skipMenu) cheatMode - let rs = initRuntimeState - case skipMenu of - False -> return $ AppState gs ui rs - True -> do - (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap) - - let maybeAutoplay = do - guard autoPlay - soln <- scenario ^. scenarioSolution - return $ SuggestedSolution soln - let realToRun = maybeAutoplay <|> (ScriptPath <$> scriptToRun) - - execStateT - (startGameWithSeed userSeed (scenario, ScenarioInfo path NotStarted NotStarted NotStarted) realToRun) - (AppState gs ui rs) - --- | Load a 'Scenario' and start playing the game. -startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m () -startGame = startGameWithSeed Nothing - --- | Re-initialize the game from the stored reference to the current scenario. --- --- Note that "restarting" is intended only for "scenarios"; --- with some scenarios, it may be possible to get stuck so that it is --- either impossible or very annoying to win, so being offered an --- option to restart is more user-friendly. --- --- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing --- case upstream so that the Scenario passed to this function definitely exists. -restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m () -restartGame currentSeed siPair = startGameWithSeed (Just currentSeed) siPair Nothing - --- | Load a 'Scenario' and start playing the game, with the --- possibility for the user to override the seed. -startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> ScenarioInfoPair -> Maybe CodeToRun -> m () -startGameWithSeed userSeed siPair@(_scene, si) toRun = do - t <- liftIO getZonedTime - ss <- use $ gameState . scenarios - p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath) - gameState . currentScenarioPath .= Just p - gameState . scenarios . scenarioItemByPath p . _SISingle . _2 . scenarioStatus .= InProgress t 0 0 - scenarioToAppState siPair userSeed toRun - -- | Extract the scenario which would come next in the menu from the -- currently selected scenario (if any). Can return @Nothing@ if -- either we are not in the @NewGameMenu@, or the current scenario @@ -1027,36 +942,3 @@ topContext s = ctxPossiblyWithIt ctxPossiblyWithIt = case s ^. gameState . replStatus of REPLDone (Just p) -> ctx & at "it" ?~ p _ -> ctx - --- XXX do we need to keep an old entity map around??? - --- | Modify the 'AppState' appropriately when starting a new scenario. -scenarioToAppState :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe Seed -> Maybe CodeToRun -> m () -scenarioToAppState siPair@(scene, _) userSeed toRun = do - withLensIO gameState $ scenarioToGameState scene userSeed toRun - withLensIO uiState $ scenarioToUIState siPair - where - withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m () - withLensIO l a = do - x <- use l - x' <- liftIO $ a x - l .= x' - --- | Modify the UI state appropriately when starting a new scenario. -scenarioToUIState :: ScenarioInfoPair -> UIState -> IO UIState -scenarioToUIState siPair u = do - curTime <- getTime Monotonic - return $ - u - & uiPlaying .~ True - & uiGoal .~ Nothing - & uiFocusRing .~ initFocusRing - & uiInventory .~ Nothing - & uiInventorySort .~ defaultSortOptions - & uiShowFPS .~ False - & uiShowZero .~ True - & lgTicksPerSecond .~ initLgTicksPerSecond - & uiREPL .~ initREPLState (u ^. uiREPL . replHistory) - & uiREPL . replHistory %~ restartREPLHistory - & scenarioRef ?~ siPair - & lastFrameTime .~ curTime diff --git a/src/Swarm/TUI/Model/Names.hs b/src/Swarm/TUI/Model/Names.hs new file mode 100644 index 0000000000..172005f899 --- /dev/null +++ b/src/Swarm/TUI/Model/Names.hs @@ -0,0 +1,57 @@ +module Swarm.TUI.Model.Names where + +data WorldEditorFocusable + = BrushSelector + | EntitySelector + | AreaSelector + | OutputPathSelector + | MapSaveButton + 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. + InfoPanel + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +-- | 'Name' represents names to uniquely identify various components +-- of the UI, such as forms, panels, caches, extents, and lists. +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 + | -- | The inventory item position in the InventoryList. + InventoryListItem Int + | -- | The list of main menu choices. + MenuList + | -- | The list of scenario choices. + ScenarioList + | -- | The scrollable viewport for the info panel. + InfoViewport + | -- | The scrollable viewport for any modal dialog. + ModalViewport + deriving (Eq, Ord, Show, Read) diff --git a/src/Swarm/TUI/Model/ScenarioState.hs b/src/Swarm/TUI/Model/ScenarioState.hs new file mode 100644 index 0000000000..830a03baa8 --- /dev/null +++ b/src/Swarm/TUI/Model/ScenarioState.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Swarm.TUI.Model.ScenarioState where + +import Brick.Widgets.List qualified as BL +import Control.Applicative ((<|>)) +import Control.Lens hiding (from, (<.>)) +import Control.Monad.Except +import Control.Monad.State +import Data.Map qualified as M +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Time (getZonedTime) +import Data.Vector qualified as V +import Linear (V2 (..)) +import Swarm.Game.Entity as E +import Swarm.Game.Scenario (area, loadScenario, scenarioWorld, ul) +import Swarm.Game.Scenario.EntityFacade +import Swarm.Game.ScenarioInfo ( + ScenarioInfo (..), + ScenarioInfoPair, + ScenarioStatus (..), + normalizeScenarioPath, + scenarioItemByPath, + scenarioPath, + scenarioSolution, + scenarioStatus, + _SISingle, + ) +import Swarm.Game.State +import Swarm.Game.World qualified as W +import Swarm.TUI.Editor.EditorModel +import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model +import System.Clock + +-- XXX do we need to keep an old entity map around??? + +-- | Modify the 'AppState' appropriately when starting a new scenario. +scenarioToAppState :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe Seed -> Maybe CodeToRun -> m () +scenarioToAppState siPair@(scene, _) userSeed toRun = do + newGameState <- withLensIO gameState $ scenarioToGameState scene userSeed toRun + void $ withLensIO uiState $ scenarioToUIState siPair newGameState + where + 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' + +-- | Modify the UI state appropriately when starting a new scenario. +scenarioToUIState :: ScenarioInfoPair -> GameState -> UIState -> IO UIState +scenarioToUIState siPair@(scenario, _) gs u = do + curTime <- getTime Monotonic + return $ + u + & uiPlaying .~ True + & uiGoal .~ Nothing + & uiFocusRing .~ initFocusRing + & uiInventory .~ Nothing + & uiInventorySort .~ defaultSortOptions + & uiShowFPS .~ False + & uiShowZero .~ True + & lgTicksPerSecond .~ initLgTicksPerSecond + & uiREPL .~ initREPLState (u ^. uiREPL . replHistory) + & uiREPL . replHistory %~ restartREPLHistory + & scenarioRef ?~ siPair + & lastFrameTime .~ curTime + & uiWorldEditor . entityPaintList %~ BL.listReplace newList Nothing + & uiWorldEditor . editingBounds . boundsRect %~ setNewBounds + where + myWorld = scenario ^. scenarioWorld + V2 left top = ul myWorld + + setNewBounds maybeOldBounds = + if mapHeight /= 0 && mapWidth /= 0 + then Just newBounds + else maybeOldBounds + + -- TODO Note inversion of horizontal and vertical coordinates + newBounds = (W.Coords (-top, left), W.Coords (-top + mapHeight - 1, left + mapWidth - 1)) + AreaDimensions mapWidth mapHeight = getAreaDimensions $ area myWorld + + entities = M.elems $ entitiesByName $ gs ^. entityMap + newList = V.fromList $ map mkPaint entities + +------- + +-- | Load a 'Scenario' and start playing the game. +startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m () +startGame = startGameWithSeed Nothing + +-- | Re-initialize the game from the stored reference to the current scenario. +-- +-- Note that "restarting" is intended only for "scenarios"; +-- with some scenarios, it may be possible to get stuck so that it is +-- either impossible or very annoying to win, so being offered an +-- option to restart is more user-friendly. +-- +-- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing +-- case upstream so that the Scenario passed to this function definitely exists. +restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m () +restartGame currentSeed siPair = startGameWithSeed (Just currentSeed) siPair Nothing + +-- | Load a 'Scenario' and start playing the game, with the +-- possibility for the user to override the seed. +startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> ScenarioInfoPair -> Maybe CodeToRun -> m () +startGameWithSeed userSeed siPair@(_scene, si) toRun = do + t <- liftIO getZonedTime + ss <- use $ gameState . scenarios + p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath) + gameState . currentScenarioPath .= Just p + gameState . scenarios . scenarioItemByPath p . _SISingle . _2 . scenarioStatus .= InProgress t 0 0 + scenarioToAppState siPair userSeed toRun + +-- | Initialize the 'AppState'. +initAppState :: AppOpts -> ExceptT Text IO AppState +initAppState AppOpts {..} = do + let isRunningInitialProgram = isJust scriptToRun || autoPlay + skipMenu = isJust userScenario || isRunningInitialProgram || isJust userSeed + gs <- initGameState + ui <- initUIState (not skipMenu) cheatMode + let rs = initRuntimeState + case skipMenu of + False -> return $ AppState gs ui rs + True -> do + (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap) + + let maybeAutoplay = do + guard autoPlay + soln <- scenario ^. scenarioSolution + return $ SuggestedSolution soln + let realToRun = maybeAutoplay <|> (ScriptPath <$> scriptToRun) + + execStateT + (startGameWithSeed userSeed (scenario, ScenarioInfo path NotStarted NotStarted NotStarted) realToRun) + (AppState gs ui rs) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 3cba087398..4a4cf54167 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -14,7 +14,6 @@ module Swarm.TUI.View ( -- * Dialog box drawDialog, - generateModal, chooseCursor, -- * Key hint menu @@ -77,6 +76,7 @@ import Swarm.Game.Entity as E import Swarm.Game.Recipe import Swarm.Game.Robot import Swarm.Game.Scenario (scenarioAuthor, scenarioDescription, scenarioName, scenarioObjectives) +import Swarm.Game.Scenario.EntityFacade import Swarm.Game.ScenarioInfo ( ScenarioItem (..), ScenarioStatus (..), @@ -91,12 +91,15 @@ import Swarm.Game.World qualified as W import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax import Swarm.Language.Typecheck (inferConst) -import Swarm.Language.Types (Polytype) import Swarm.TUI.Attr import Swarm.TUI.Border +import Swarm.TUI.Editor.EditorModel +import Swarm.TUI.Editor.EditorView qualified as EV +import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Model import Swarm.TUI.Panel +import Swarm.TUI.View.ViewUtils import Swarm.Util import Swarm.Version (NewReleaseFailure (..)) import System.Clock (TimeSpec (..)) @@ -271,7 +274,8 @@ drawGameUI s = hBox [ hLimitPercent 25 $ vBox - [ vLimitPercent 50 $ panel highlightAttr fr (FocusablePanel RobotPanel) plainBorder $ drawRobotPanel s + [ vLimitPercent 50 $ + panel highlightAttr fr (FocusablePanel RobotPanel) plainBorder $ drawRobotPanel s , panel highlightAttr fr @@ -283,6 +287,9 @@ drawGameUI s = .~ (if moreBot then Just (txt " · · · ") else Nothing) ) $ drawInfoPanel s + , hCenter $ + clickable (FocusablePanel WorldEditorPanel) $ + EV.drawWorldEditor fr $ s ^. uiState ] , vBox [ panel @@ -295,7 +302,10 @@ drawGameUI s = & addCursorPos & addClock ) - (drawWorld (s ^. uiState . uiShowRobots) (s ^. gameState)) + ( drawWorld + (s ^. uiState) + (s ^. gameState) + ) , drawKeyMenu s , clickable (FocusablePanel REPLPanel) $ panel @@ -317,7 +327,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 installed @@ -326,8 +336,8 @@ drawGameUI s = moreTop = s ^. uiState . uiMoreInfoTop moreBot = s ^. uiState . uiMoreInfoBot -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@(W.Coords (y, x)) = hBox $ tileMemberWidgets ++ [coordsWidget] where coordsWidget = @@ -346,8 +356,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)) @@ -389,10 +399,6 @@ drawTime t showTicks = maybeDrawTime :: Integer -> Bool -> GameState -> Maybe (Widget n) maybeDrawTime t showTicks gs = guard (clockInstalled gs) $> drawTime t showTicks --- | 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 - -- | Draw info about the current number of ticks per second. drawTPS :: AppState -> Widget Name drawTPS s = hBox (tpsInfo : rateInfo) @@ -425,10 +431,6 @@ chooseCursor s locs = case s ^. uiState . uiModal of Nothing -> showFirstCursor s locs Just _ -> Nothing --- | Width cap for modal and error message windows -maxModalWindowWidth :: Int -maxModalWindowWidth = 500 - -- | Render the error dialog window with a given error message renderErrorDialog :: Text -> Widget Name renderErrorDialog err = renderDialog (dialog (Just "Error") Nothing (maxModalWindowWidth `min` requiredWidth)) errContent @@ -471,77 +473,8 @@ drawModal s = \case QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg (s ^. uiState . uiMenu)) GoalModal g -> padLeftRight 1 (displayParagraphs g) KeepPlayingModal -> padLeftRight 1 (displayParagraphs ["Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu."]) - -quitMsg :: Menu -> Text -quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!" - where - quitAction = case m of - NoMenu -> "quit" - _ -> "return to the menu" - --- | Generate a fresh modal window of the requested type. -generateModal :: AppState -> ModalType -> Modal -generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth)) - where - currentScenario = s ^. uiState . scenarioRef - currentSeed = s ^. gameState . seed - haltingMessage = case s ^. uiState . uiMenu of - NoMenu -> Just "Quit" - _ -> Nothing - descriptionWidth = 100 - helpWidth = 80 - (title, buttons, requiredWidth) = - case mt of - HelpModal -> (" Help ", Nothing, helpWidth) - RobotsModal -> ("Robots", Nothing, descriptionWidth) - RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) - CommandsModal -> ("Available Commands", Nothing, descriptionWidth) - MessagesModal -> ("Messages", Nothing, descriptionWidth) - WinModal -> - let nextMsg = "Next challenge!" - stopMsg = fromMaybe "Return to the menu" haltingMessage - continueMsg = "Keep playing" - in ( "" - , Just - ( 0 - , [ (nextMsg, NextButton scene) - | Just scene <- [nextScenario (s ^. uiState . uiMenu)] - ] - ++ [ (stopMsg, QuitButton) - , (continueMsg, KeepPlayingButton) - ] - ) - , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 - ) - DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) - QuitModal -> - let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage - maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario) - in ( "" - , Just - ( 0 - , catMaybes - [ Just ("Keep playing", CancelButton) - , maybeStartOver - , Just (stopMsg, QuitButton) - ] - ) - , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 - ) - GoalModal _ -> - let goalModalTitle = case currentScenario of - Nothing -> "Goal" - Just (scenario, _) -> scenario ^. scenarioName - in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80) - KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 80) - --- | Get the name of the current New Game menu. -curMenuName :: AppState -> Maybe Text -curMenuName s = case s ^. uiState . uiMenu of - NewGameMenu (_ :| (parentMenu : _)) -> - Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) - NewGameMenu _ -> Just "Scenarios" - _ -> Nothing + TerrainPaletteModal -> EV.drawTerrainSelector s + EntityPaletteModal -> EV.drawEntityPaintSelector s robotsListWidget :: AppState -> Widget Name robotsListWidget s = hCenter table @@ -594,7 +527,11 @@ robotsListWidget s = hCenter table locWidget = hBox [worldCell, txt $ " " <> locStr] where rloc@(V2 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 @@ -712,9 +649,6 @@ drawConst c = hBox [padLeft (Pad $ 13 - T.length constName) (txt constName), txt constName = syntax . constInfo $ c constSig = " : " <> prettyText (inferConst c) -descriptionTitle :: Entity -> String -descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " " - -- | Generate a pop-up widget to display the description of an entity. descriptionWidget :: AppState -> Entity -> Widget Name descriptionWidget s e = padLeftRight 1 (explainEntry s e) @@ -817,6 +751,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") , Just (NoHighlight, "^o", "step") , Just (NoHighlight, "^zx", "speed") @@ -828,6 +763,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") ] @@ -868,8 +805,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 @@ -881,23 +818,39 @@ 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 -- | 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 EV.shouldHideWorldCell ui coords + then str " " + else drawCell + where + 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 - displayForEntity :: Entity -> Display - displayForEntity e = (if known e then id else hidden) (e ^. entityDisplay) + (_, maybeEntity) = EU.getContentAt worldEditor (g ^. world) coords + + displayForEntity :: EntityPaint -> Display + displayForEntity e = (if known e then id else hidden) $ getDisplay e - known e = + known (EntityFacade (EntityFacadeData _ _)) = True + known (EntityRef e) = e `hasProperty` Known || (e ^. entityName) `elem` (g ^. knownEntities) || case hidingMode g of @@ -907,12 +860,12 @@ displayEntityCell g coords = maybeToList (displayForEntity <$> W.lookupEntity co -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. -displayLoc :: Bool -> GameState -> W.Coords -> Display -displayLoc showRobots g coords = +displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display +displayLoc 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/ViewUtils.hs b/src/Swarm/TUI/View/ViewUtils.hs new file mode 100644 index 0000000000..9815b9863e --- /dev/null +++ b/src/Swarm/TUI/View/ViewUtils.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.View.ViewUtils where + +import Brick hiding (Direction) +import Brick.Widgets.Dialog +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map qualified as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Display +import Swarm.Game.Entity as E +import Swarm.Game.Scenario (scenarioName) +import Swarm.Game.ScenarioInfo (scenarioItemName) +import Swarm.Game.State +import Swarm.Game.Terrain (TerrainType, terrainMap) +import Swarm.Language.Pretty (prettyText) +import Swarm.Language.Types (Polytype) +import Swarm.TUI.Attr +import Swarm.TUI.Model +import Swarm.Util +import Witch (from, into) + +-- | Generate a fresh modal window of the requested type. +generateModal :: AppState -> ModalType -> Modal +generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth)) + where + currentScenario = s ^. uiState . scenarioRef + currentSeed = s ^. gameState . seed + haltingMessage = case s ^. uiState . uiMenu of + NoMenu -> Just "Quit" + _ -> Nothing + descriptionWidth = 100 + helpWidth = 80 + (title, buttons, requiredWidth) = + case mt of + HelpModal -> (" Help ", Nothing, helpWidth) + RobotsModal -> ("Robots", Nothing, descriptionWidth) + RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) + CommandsModal -> ("Available Commands", Nothing, descriptionWidth) + MessagesModal -> ("Messages", Nothing, descriptionWidth) + WinModal -> + let nextMsg = "Next challenge!" + stopMsg = fromMaybe "Return to the menu" haltingMessage + continueMsg = "Keep playing" + in ( "" + , Just + ( 0 + , [ (nextMsg, NextButton scene) + | Just scene <- [nextScenario (s ^. uiState . uiMenu)] + ] + ++ [ (stopMsg, QuitButton) + , (continueMsg, KeepPlayingButton) + ] + ) + , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 + ) + DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) + QuitModal -> + let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage + maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario) + in ( "" + , Just + ( 0 + , catMaybes + [ Just ("Keep playing", CancelButton) + , maybeStartOver + , Just (stopMsg, QuitButton) + ] + ) + , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 + ) + GoalModal _ -> + let goalModalTitle = case currentScenario of + Nothing -> "Goal" + Just (scenario, _) -> scenario ^. scenarioName + in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80) + KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 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) ++ " " + +-- | Width cap for modal and error message windows +maxModalWindowWidth :: Int +maxModalWindowWidth = 500 + +-- | Get the name of the current New Game menu. +curMenuName :: AppState -> Maybe Text +curMenuName s = case s ^. uiState . uiMenu of + NewGameMenu (_ :| (parentMenu : _)) -> + Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) + NewGameMenu _ -> Just "Scenarios" + _ -> Nothing + +quitMsg :: Menu -> Text +quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!" + where + quitAction = case m of + NoMenu -> "quit" + _ -> "return to the menu" diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index f46b9df547..a64c413148 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -21,6 +21,8 @@ module Swarm.Util ( uniq, getElemsInArea, manhattan, + binTuples, + histogram, -- * Directory utilities readFileMay, @@ -82,8 +84,9 @@ import Data.Bifunctor (first) import Data.Char (isAlphaNum) import Data.Either.Validation import Data.Int (Int64) -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 import Data.Maybe (fromMaybe, mapMaybe) @@ -204,6 +207,23 @@ getElemsInArea o@(V2 x y) d m = M.elems sm' & fst -- B> sm' = M.filterWithKey (const . (<= d) . manhattan o) sm +-- | Place the second element of the tuples into bins by +-- the value of the first element. +binTuples :: + (Foldable t, Ord a) => + t (a, b) -> + Map a (NE.NonEmpty b) +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 + ------------------------------------------------------------ -- Directory stuff diff --git a/swarm.cabal b/swarm.cabal index 9a5695a52b..df88250be2 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -96,6 +96,10 @@ library Swarm.Language.Pipeline Swarm.Language.Pipeline.QQ Swarm.Game.CESK + Swarm.Game.Scenario.Cells + Swarm.Game.Scenario.WorldDescription + Swarm.Game.Scenario.EntityFacade + Swarm.Game.Scenario.ScenarioUtil Swarm.Game.Scenario Swarm.Game.ScenarioInfo Swarm.Game.Display @@ -111,10 +115,19 @@ library Swarm.Game.WorldGen Swarm.TUI.Attr Swarm.TUI.Border + Swarm.TUI.Controller.ControllerUtils + Swarm.TUI.Editor.EditorController + Swarm.TUI.Editor.EditorJson + Swarm.TUI.Editor.EditorModel + Swarm.TUI.Editor.EditorView + Swarm.TUI.Editor.Util Swarm.TUI.List Swarm.TUI.Panel Swarm.TUI.Model + Swarm.TUI.Model.Names + Swarm.TUI.Model.ScenarioState Swarm.TUI.View + Swarm.TUI.View.ViewUtils Swarm.TUI.Controller Swarm.TUI.Inventory.Sorting Swarm.App @@ -151,6 +164,7 @@ library lsp >= 1.2 && < 1.7, megaparsec >= 9.0 && < 9.3, 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,