Util.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.TUI.View.Util where

import Brick hiding (Direction, Location)
import Brick.Widgets.Dialog
import Brick.Widgets.List qualified as BL
import Control.Lens hiding (Const, from)
import Control.Monad.Reader (withReaderT)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Graphics.Vty qualified as V
import Swarm.Game.Entity as E
import Swarm.Game.Location
import Swarm.Game.Scenario (scenarioName)
import Swarm.Game.ScenarioInfo (scenarioItemName)
import Swarm.Game.State
import Swarm.Game.Terrain
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Syntax (Syntax)
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Language.Types (Polytype)
import Swarm.TUI.Attr
import Swarm.TUI.Model
import Swarm.TUI.Model.UI
import Swarm.TUI.View.CellDisplay
import Swarm.Util (listEnums)
import Witch (from, into)

-- | Generate a fresh modal window of the requested type.
generateModal :: AppState -> ModalType -> Modal
generateModal s mt = Modal mt (dialog (Just $ str 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)
      ScenarioEndModal WinModal ->
        let nextMsg = "Next challenge!"
            stopMsg = fromMaybe "Return to the menu" haltingMessage
            continueMsg = "Keep playing"
         in ( ""
            , Just
                ( Button NextButton
                , [ (nextMsg, Button NextButton, Next scene)
                  | Just scene <- [nextScenario (s ^. uiState . uiMenu)]
                  ]
                    ++ [ (stopMsg, Button QuitButton, QuitAction)
                       , (continueMsg, Button KeepPlayingButton, KeepPlaying)
                       ]
                )
            , sum (map length [nextMsg, stopMsg, continueMsg]) + 32
            )
      ScenarioEndModal LoseModal ->
        let stopMsg = fromMaybe "Return to the menu" haltingMessage
            continueMsg = "Keep playing"
            maybeStartOver = do
              cs <- currentScenario
              return ("Start over", Button StartOverButton, StartOver currentSeed cs)
         in ( ""
            , Just
                ( Button QuitButton
                , catMaybes
                    [ Just (stopMsg, Button QuitButton, QuitAction)
                    , maybeStartOver
                    , Just (continueMsg, Button KeepPlayingButton, KeepPlaying)
                    ]
                )
            , sum (map length [stopMsg, continueMsg]) + 32
            )
      DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth)
      QuitModal ->
        let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage
            maybeStartOver = do
              cs <- currentScenario
              return ("Start over", Button StartOverButton, StartOver currentSeed cs)
         in ( ""
            , Just
                ( Button CancelButton
                , catMaybes
                    [ Just ("Keep playing", Button CancelButton, Cancel)
                    , maybeStartOver
                    , Just (stopMsg, Button QuitButton, QuitAction)
                    ]
                )
            , T.length (quitMsg (s ^. uiState . uiMenu)) + 4
            )
      GoalModal ->
        let goalModalTitle = case currentScenario of
              Nothing -> "Goal"
              Just (scenario, _) -> scenario ^. scenarioName
         in (" " <> T.unpack goalModalTitle <> " ", Nothing, descriptionWidth)
      KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80)
      TerrainPaletteModal -> ("Terrain", Nothing, w)
       where
        wordLength = maximum $ map (length . show) (listEnums :: [TerrainType])
        w = wordLength + 6
      EntityPaletteModal -> ("Entity", Nothing, 30)

-- | Render the type of the current REPL input to be shown to the user.
drawType :: Polytype -> Widget Name
drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText

-- | Draw markdown document with simple code/bold/italic attributes.
--
-- TODO: #574 Code blocks should probably be handled separately.
drawMarkdown :: Markdown.Document Syntax -> Widget Name
drawMarkdown d = do
  Widget Greedy Fixed $ do
    ctx <- getContext
    let w = ctx ^. availWidthL
    let docLines = Markdown.chunksOf w . Markdown.toStream <$> Markdown.paragraphs d
    render . layoutParagraphs $ vBox . map (hBox . map mTxt) <$> docLines
 where
  mTxt = \case
    Markdown.TextNode as t -> foldr applyAttr (txt t) as
    Markdown.CodeNode t -> withAttr highlightAttr $ txt t
    Markdown.RawNode f t -> withAttr (rawAttr f) $ txt t
  applyAttr a = withAttr $ case a of
    Markdown.Strong -> boldAttr
    Markdown.Emphasis -> italicAttr
  rawAttr = \case
    "entity" -> greenAttr
    "type" -> magentaAttr
    _snippet -> highlightAttr -- same as plain code

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"

locationToString :: Location -> String
locationToString (Location x y) =
  unwords $ map show [x, y]

-- | Display a list of text-wrapped paragraphs with one blank line after each.
displayParagraphs :: [Text] -> Widget Name
displayParagraphs = layoutParagraphs . map txtWrap

-- | Display a list of paragraphs with one blank line after each.
--
-- For the common case of `[Text]` use 'displayParagraphs'.
layoutParagraphs :: [Widget Name] -> Widget Name
layoutParagraphs ps = vBox $ padBottom (Pad 1) <$> ps

data EllipsisSide = Beginning | End

withEllipsis :: EllipsisSide -> Text -> Widget Name
withEllipsis side t =
  Widget Greedy Fixed $ do
    ctx <- getContext
    let w = ctx ^. availWidthL
        ellipsis = T.replicate 3 $ T.singleton '.'
        tLength = T.length t
        newText =
          if tLength > w
            then case side of
              Beginning -> ellipsis <> T.drop (w - T.length ellipsis) t
              End -> T.take (w - T.length ellipsis) t <> ellipsis
            else t
    render $ txt newText

-- | Make a widget scrolling if it is bigger than the available
--   vertical space.  Thanks to jtdaugherty for this code.
maybeScroll :: (Ord n, Show n) => n -> Widget n -> Widget n
maybeScroll vpName contents =
  Widget Greedy Greedy $ do
    ctx <- getContext
    result <- withReaderT (availHeightL .~ 10000) (render contents)
    if V.imageHeight (result ^. imageL) <= ctx ^. availHeightL
      then return result
      else
        render
          . withVScrollBars OnRight
          . viewport vpName Vertical
          . Widget Fixed Fixed
          $ return result