Util.hs

{-# LANGUAGE OverloadedStrings #-}

module Swarm.TUI.View.Util where

import Brick hiding (Direction)
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.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.Scenario (scenarioName)
import Swarm.Game.ScenarioInfo (scenarioItemName)
import Swarm.Game.State
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Types (Polytype)
import Swarm.TUI.Attr
import Swarm.TUI.Model
import Swarm.TUI.Model.UI
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)
      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
            )
      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)

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

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"

-- | Display a list of text-wrapped paragraphs with one blank line after
--   each.
displayParagraphs :: [Text] -> Widget Name
displayParagraphs = vBox . map (padBottom (Pad 1) . txtWrap)

withEllipsis :: Text -> Widget Name
withEllipsis 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 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