world editor prototype

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)
@@ -81,33 +81,18 @@ 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.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.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 +274,65 @@ 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
     ControlChar 'v'
       | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not
+    -- toggle world editor mode if in "cheat mode"
+    ControlChar 'e'
+      | s ^. uiState . uiCheatMode ->
+        uiState . uiWorldEditor . isWorldEditorEnabled %= not
+    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 =
+            uiState . uiWorldEditor . terrainList
+              %= BL.listMoveToElement (EU.getTerrainAt 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 maybeTerrainType = fmap snd $ BL.listSelectedElement $ worldEditor ^. terrainList
+        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
+      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
+          case mouseCoordsM of
+            Nothing -> uiState . uiWorldCursor .= mouseCoordsM
+            Just mouseCoords -> do
+              selectorStage <- use $ uiState . uiWorldEditor . boundsSelectionStep
+              -- We swap the horizontal and vertical coordinate, and invert the vertical cooridnate.
+              -- TODO What is mouseLocToWorldCoords??
+              let toWorldCoords (W.Coords (mx, my)) = W.Coords (my, -mx)
+              case selectorStage of
+                UpperLeftPending -> uiState . uiWorldEditor . boundsSelectionStep .= LowerRightPending mouseCoords
+                -- TODO: Validate that the lower-right click is below and to the right of the top-left coord
+                LowerRightPending upperLeftMouseCoords -> do
+                  uiState . uiWorldEditor . editingBounds
+                    .= Just (toWorldCoords upperLeftMouseCoords, toWorldCoords mouseCoords)
+                  uiState . uiWorldEditor . boundsSelectionStep .= SelectionComplete
+                  setFocus WorldEditorPanel
+                SelectionComplete -> 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 +343,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 +355,7 @@ handleMainEvent ev = do
         Just (FocusablePanel x) -> ($ ev) $ case x of
           REPLPanel -> handleREPLEvent
           WorldPanel -> handleWorldEvent
+          WorldEditorPanel -> EC.handleWorldEditorPanelEvent
           RobotPanel -> handleRobotPanelEvent
           InfoPanel -> handleInfoPanelEvent infoScroll
         _ -> continueWithoutRedraw
@@ -367,21 +401,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,6 +419,10 @@ 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 <- nestEventM' listWidget $ BL.handleListEvent ev
+        uiState . uiWorldEditor . terrainList .= newList
       Just _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)
       _ -> return ()
 

src/Swarm/TUI/Controller/ControllerUtils.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Swarm.TUI.Controller.ControllerUtils where
+
+import Brick hiding (Direction)
+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]

src/Swarm/TUI/Editor/EditorController.hs

@@ -0,0 +1,46 @@
+module Swarm.TUI.Editor.EditorController where
+
+import Brick hiding (Direction)
+import Brick.Focus
+import Control.Lens
+import Control.Monad.IO.Class (liftIO)
+import Graphics.Vty qualified as V
+import Swarm.Game.State
+import Swarm.TUI.Controller.ControllerUtils
+import Swarm.TUI.Editor.Util qualified as EU
+import Swarm.TUI.Model
+
+------------------------------------------------------------
+-- World Editor panel events
+------------------------------------------------------------
+
+activateWorldEditorFunction :: WorldEditorFocusable -> EventM Name AppState ()
+activateWorldEditorFunction BrushSelector = openModal TerrainPaletteModal
+activateWorldEditorFunction EntitySelector =
+  liftIO $ putStrLn "TODO"
+activateWorldEditorFunction AreaSelector = do
+  selectorStage <- use $ uiState . uiWorldEditor . boundsSelectionStep
+  case selectorStage of
+    SelectionComplete -> uiState . uiWorldEditor . boundsSelectionStep .= UpperLeftPending
+    _ -> return ()
+activateWorldEditorFunction OutputPathSelector =
+  liftIO $ putStrLn "File selection"
+
+-- | Handle user input events in the robot panel.
+handleWorldEditorPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
+handleWorldEditorPanelEvent = \case
+  Key V.KEsc -> uiState . uiWorldEditor . boundsSelectionStep .= SelectionComplete
+  Key V.KEnter -> do
+    fring <- use $ uiState . uiWorldEditor . editorFocusRing
+    case focusGetCurrent fring of
+      Just (WorldEditorPanelControl x) -> activateWorldEditorFunction x
+      _ -> return ()
+  ControlChar 's' -> do
+    worldEditor <- use $ uiState . uiWorldEditor
+    let fp = worldEditor ^. outputFilePath
+    maybeBounds <- use $ uiState . uiWorldEditor . editingBounds
+    w <- use $ gameState . world
+    liftIO $ writeFile fp $ EU.getEditedMapAsString worldEditor maybeBounds w
+  CharKey '\t' -> uiState . uiWorldEditor . editorFocusRing %= focusNext
+  Key V.KBackTab -> uiState . uiWorldEditor . editorFocusRing %= focusPrev
+  _ -> return ()

src/Swarm/TUI/Editor/EditorView.hs

@@ -0,0 +1,92 @@
+module Swarm.TUI.Editor.EditorView where
+
+import Brick hiding (Direction)
+import Brick.Focus
+import Brick.Widgets.List qualified as BL
+import Control.Lens hiding (Const, from)
+import Data.List qualified as L
+import Swarm.Game.World qualified as W
+import Swarm.TUI.Attr
+import Swarm.TUI.Border
+import Swarm.TUI.Model
+import Swarm.TUI.Panel
+
+import Swarm.TUI.View.ViewUtils
+
+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
+
+  innerWidget =
+    padLeftRight 1 $
+      hLimit 30 $
+        vBox
+          [ brushWidget
+          , -- , entityWidget
+            areaWidget
+          , outputWidget
+          ]
+
+  worldEditor = uis ^. uiWorldEditor
+  maybeSelectedTerrain = fmap snd $ BL.listSelectedElement $ worldEditor ^. terrainList
+  maybeAreaBounds = worldEditor ^. editingBounds
+
+  -- TODO: Use withFocusRing
+  mkFormControl n w =
+    clickable n $ transformation w
+   where
+    transformation =
+      if Just n == maybeCurrentFocus
+        then withAttr BL.listSelectedFocusedAttr
+        else id
+
+  brushWidget =
+    mkFormControl (WorldEditorPanelControl BrushSelector) $
+      padRight (Pad 1) (str "Brush:") <+> brushWidgetContent
+
+  brushWidgetContent =
+    maybe emptyWidget drawLabeledTerrainSwatch maybeSelectedTerrain
+
+  -- entityWidget =
+  --   mkFormControl (WorldEditorPanelControl EntitySelector) $
+  --     padRight (Pad 1) (str "Entity:") <+> entityWidgetContent
+
+  -- entityWidgetContent =
+  --   maybe emptyWidget drawLabeledTerrainSwatch maybeSelectedTerrain
+
+  areaContent = case worldEditor ^. 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 primaryCorner@(x1, y1), W.Coords (x2, y2)) =
+    str $ L.intercalate " @ " [rectSize, show primaryCorner]
+   where
+    width = x2 - x1
+    -- NOTE: The height coordinate is inverted so we do opposite subtraction order here:
+    height = y1 - y2
+    rectSize = L.intercalate "x" [show width, show height]
+
+  outputWidget =
+    mkFormControl (WorldEditorPanelControl OutputPathSelector) $
+      padRight (Pad 1) (str "Output:") <+> outputWidgetContent
+
+  outputWidgetContent = str $ worldEditor ^. outputFilePath

src/Swarm/TUI/Editor/Util.hs

@@ -0,0 +1,29 @@
+module Swarm.TUI.Editor.Util where
+
+import Control.Lens hiding (Const, from)
+import Data.Char qualified as DC
+import Data.Int (Int64)
+import Data.Map qualified as Map
+import Data.Maybe qualified as Maybe
+import Swarm.Game.Entity (Entity)
+import Swarm.Game.Terrain (TerrainType)
+import Swarm.Game.World qualified as W
+import Swarm.TUI.Model
+
+getTerrainAt :: WorldEditor -> W.World Int Entity -> W.Coords -> TerrainType
+getTerrainAt editor w coords = case editor ^. isWorldEditorEnabled of
+  True -> Maybe.fromMaybe underlyingCell $ Map.lookup coords paintMap
+  False -> underlyingCell
+ where
+  paintMap = editor ^. paintedTerrain
+  underlyingCell = toEnum $ W.lookupTerrain coords w
+
+getEditedMapAsString :: WorldEditor -> Maybe (W.Coords, W.Coords) -> W.World Int Entity -> String
+getEditedMapAsString _ Nothing _ = "EMPTY BOUNDS"
+getEditedMapAsString worldEditor (Just (W.Coords (xLeft, yTop), W.Coords (xRight, yBottom))) w =
+  unlines $ map renderLine [yTop .. yBottom]
+ where
+  getTerrain = getTerrainAt worldEditor w
+  drawCell :: Int64 -> Int64 -> Char
+  drawCell rowIndex = DC.chr . (+ DC.ord '0') . fromEnum . getTerrain . W.Coords . (rowIndex,)
+  renderLine rowIndex = map (drawCell rowIndex) [xLeft .. xRight]