{-# 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.Model
import Swarm.TUI.Model.UI
import Swarm.TUI.View.Attribute.Attr
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 :: AppState -> ModalType -> Modal
generateModal AppState
s ModalType
mt = ModalType -> Dialog ButtonAction Name -> Modal
Modal ModalType
mt (forall n a.
Eq n =>
Maybe (Widget n)
-> Maybe (n, [([Char], n, a)]) -> Int -> Dialog a n
dialog (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. [Char] -> Widget n
str [Char]
title) Maybe (Name, [([Char], Name, ButtonAction)])
buttons (Int
maxModalWindowWidth forall a. Ord a => a -> a -> a
`min` Int
requiredWidth))
 where
  currentScenario :: Maybe ScenarioInfoPair
currentScenario = AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState (Maybe ScenarioInfoPair)
scenarioRef
  currentSeed :: Int
currentSeed = AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState Int
seed
  haltingMessage :: Maybe [Char]
haltingMessage = case AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu of
    Menu
NoMenu -> forall a. a -> Maybe a
Just [Char]
"Quit"
    Menu
_ -> forall a. Maybe a
Nothing
  descriptionWidth :: Int
descriptionWidth = Int
100
  helpWidth :: Int
helpWidth = Int
80
  ([Char]
title, Maybe (Name, [([Char], Name, ButtonAction)])
buttons, Int
requiredWidth) =
    case ModalType
mt of
      ModalType
HelpModal -> ([Char]
" Help ", forall a. Maybe a
Nothing, Int
helpWidth)
      ModalType
RobotsModal -> ([Char]
"Robots", forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
RecipesModal -> ([Char]
"Available Recipes", forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
CommandsModal -> ([Char]
"Available Commands", forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
MessagesModal -> ([Char]
"Messages", forall a. Maybe a
Nothing, Int
descriptionWidth)
      ScenarioEndModal ScenarioOutcome
WinModal ->
        let nextMsg :: [Char]
nextMsg = [Char]
"Next challenge!"
            stopMsg :: [Char]
stopMsg = forall a. a -> Maybe a -> a
fromMaybe [Char]
"Return to the menu" Maybe [Char]
haltingMessage
            continueMsg :: [Char]
continueMsg = [Char]
"Keep playing"
         in ( [Char]
""
            , forall a. a -> Maybe a
Just
                ( Button -> Name
Button Button
NextButton
                , [ ([Char]
nextMsg, Button -> Name
Button Button
NextButton, ScenarioInfoPair -> ButtonAction
Next ScenarioInfoPair
scene)
                  | Just ScenarioInfoPair
scene <- [Menu -> Maybe ScenarioInfoPair
nextScenario (AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu)]
                  ]
                    forall a. [a] -> [a] -> [a]
++ [ ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
                       , ([Char]
continueMsg, Button -> Name
Button Button
KeepPlayingButton, ButtonAction
KeepPlaying)
                       ]
                )
            , forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]
nextMsg, [Char]
stopMsg, [Char]
continueMsg]) forall a. Num a => a -> a -> a
+ Int
32
            )
      ScenarioEndModal ScenarioOutcome
LoseModal ->
        let stopMsg :: [Char]
stopMsg = forall a. a -> Maybe a -> a
fromMaybe [Char]
"Return to the menu" Maybe [Char]
haltingMessage
            continueMsg :: [Char]
continueMsg = [Char]
"Keep playing"
            maybeStartOver :: Maybe ([Char], Name, ButtonAction)
maybeStartOver = do
              ScenarioInfoPair
cs <- Maybe ScenarioInfoPair
currentScenario
              forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"Start over", Button -> Name
Button Button
StartOverButton, Int -> ScenarioInfoPair -> ButtonAction
StartOver Int
currentSeed ScenarioInfoPair
cs)
         in ( [Char]
""
            , forall a. a -> Maybe a
Just
                ( Button -> Name
Button Button
QuitButton
                , forall a. [Maybe a] -> [a]
catMaybes
                    [ forall a. a -> Maybe a
Just ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
                    , Maybe ([Char], Name, ButtonAction)
maybeStartOver
                    , forall a. a -> Maybe a
Just ([Char]
continueMsg, Button -> Name
Button Button
KeepPlayingButton, ButtonAction
KeepPlaying)
                    ]
                )
            , forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]
stopMsg, [Char]
continueMsg]) forall a. Num a => a -> a -> a
+ Int
32
            )
      DescriptionModal Entity
e -> (Entity -> [Char]
descriptionTitle Entity
e, forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
QuitModal ->
        let stopMsg :: [Char]
stopMsg = forall a. a -> Maybe a -> a
fromMaybe ([Char]
"Quit to" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " forall a. [a] -> [a] -> [a]
++) (forall target source. From source target => source -> target
into @String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppState -> Maybe Text
curMenuName AppState
s) forall a. [a] -> [a] -> [a]
++ [Char]
" menu") Maybe [Char]
haltingMessage
            maybeStartOver :: Maybe ([Char], Name, ButtonAction)
maybeStartOver = do
              ScenarioInfoPair
cs <- Maybe ScenarioInfoPair
currentScenario
              forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"Start over", Button -> Name
Button Button
StartOverButton, Int -> ScenarioInfoPair -> ButtonAction
StartOver Int
currentSeed ScenarioInfoPair
cs)
         in ( [Char]
""
            , forall a. a -> Maybe a
Just
                ( Button -> Name
Button Button
CancelButton
                , forall a. [Maybe a] -> [a]
catMaybes
                    [ forall a. a -> Maybe a
Just ([Char]
"Keep playing", Button -> Name
Button Button
CancelButton, ButtonAction
Cancel)
                    , Maybe ([Char], Name, ButtonAction)
maybeStartOver
                    , forall a. a -> Maybe a
Just ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
                    ]
                )
            , Text -> Int
T.length (Menu -> Text
quitMsg (AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu)) forall a. Num a => a -> a -> a
+ Int
4
            )
      ModalType
GoalModal ->
        let goalModalTitle :: Text
goalModalTitle = case Maybe ScenarioInfoPair
currentScenario of
              Maybe ScenarioInfoPair
Nothing -> Text
"Goal"
              Just (Scenario
scenario, ScenarioInfo
_) -> Scenario
scenario forall s a. s -> Getting a s a -> a
^. Lens' Scenario Text
scenarioName
         in ([Char]
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
goalModalTitle forall a. Semigroup a => a -> a -> a
<> [Char]
" ", forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
KeepPlayingModal -> ([Char]
"", forall a. a -> Maybe a
Just (Button -> Name
Button Button
CancelButton, [([Char]
"OK", Button -> Name
Button Button
CancelButton, ButtonAction
Cancel)]), Int
80)
      ModalType
TerrainPaletteModal -> ([Char]
"Terrain", forall a. Maybe a
Nothing, Int
w)
       where
        wordLength :: Int
wordLength = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) (forall e. (Enum e, Bounded e) => [e]
listEnums :: [TerrainType])
        w :: Int
w = Int
wordLength forall a. Num a => a -> a -> a
+ Int
6
      ModalType
EntityPaletteModal -> ([Char]
"Entity", forall a. Maybe a
Nothing, Int
30)

-- | Render the type of the current REPL input to be shown to the user.
drawType :: Polytype -> Widget Name
drawType :: Polytype -> Widget Name
drawType = forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
infoAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Int -> Widget n -> Widget n
padLeftRight Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Text -> Widget n
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
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 :: Document Syntax -> Widget Name
drawMarkdown Document Syntax
d = do
  forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed forall a b. (a -> b) -> a -> b
$ do
    Context Name
ctx <- forall n. RenderM n (Context n)
getContext
    let w :: Int
w = Context Name
ctx forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Context n) Int
availWidthL
    let docLines :: [[[StreamNode]]]
docLines = Int -> [StreamNode] -> [[StreamNode]]
Markdown.chunksOf Int
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStream a => a -> [StreamNode]
Markdown.toStream forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. Document c -> [Paragraph c]
Markdown.paragraphs Document Syntax
d
    forall n. Widget n -> RenderM n (Result n)
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Widget Name] -> Widget Name
layoutParagraphs forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
vBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall n. [Widget n] -> Widget n
hBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {n}. StreamNode -> Widget n
mTxt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[[StreamNode]]]
docLines
 where
  mTxt :: StreamNode -> Widget n
mTxt = \case
    Markdown.TextNode Set TxtAttr
as Text
t -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {n}. TxtAttr -> Widget n -> Widget n
applyAttr (forall n. Text -> Widget n
txt Text
t) Set TxtAttr
as
    Markdown.CodeNode Text
t -> forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
highlightAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
t
    Markdown.RawNode [Char]
f Text
t -> forall n. AttrName -> Widget n -> Widget n
withAttr ([Char] -> AttrName
rawAttr [Char]
f) forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
t
  applyAttr :: TxtAttr -> Widget n -> Widget n
applyAttr TxtAttr
a = forall n. AttrName -> Widget n -> Widget n
withAttr forall a b. (a -> b) -> a -> b
$ case TxtAttr
a of
    TxtAttr
Markdown.Strong -> AttrName
boldAttr
    TxtAttr
Markdown.Emphasis -> AttrName
italicAttr
  rawAttr :: [Char] -> AttrName
rawAttr = \case
    [Char]
"entity" -> AttrName
greenAttr
    [Char]
"type" -> AttrName
magentaAttr
    [Char]
_snippet -> AttrName
highlightAttr -- same as plain code

drawLabeledTerrainSwatch :: TerrainType -> Widget Name
drawLabeledTerrainSwatch :: TerrainType -> Widget Name
drawLabeledTerrainSwatch TerrainType
a =
  forall {n}. Widget n
tile forall n. Widget n -> Widget n -> Widget n
<+> forall n. [Char] -> Widget n
str [Char]
materialName
 where
  tile :: Widget n
tile = forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$ forall n. Display -> Widget n
renderDisplay forall a b. (a -> b) -> a -> b
$ Map TerrainType Display
terrainMap forall k a. Ord k => Map k a -> k -> a
M.! TerrainType
a
  materialName :: [Char]
materialName = forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show TerrainType
a

descriptionTitle :: Entity -> String
descriptionTitle :: Entity -> [Char]
descriptionTitle Entity
e = [Char]
" " forall a. [a] -> [a] -> [a]
++ forall source target. From source target => source -> target
from @Text (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. [a] -> [a] -> [a]
++ [Char]
" "

-- | Width cap for modal and error message windows
maxModalWindowWidth :: Int
maxModalWindowWidth :: Int
maxModalWindowWidth = Int
500

-- | Get the name of the current New Game menu.
curMenuName :: AppState -> Maybe Text
curMenuName :: AppState -> Maybe Text
curMenuName AppState
s = case AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu of
  NewGameMenu (List Name ScenarioItem
_ :| (List Name ScenarioItem
parentMenu : [List Name ScenarioItem]
_)) ->
    forall a. a -> Maybe a
Just (List Name ScenarioItem
parentMenu forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) e n.
(Splittable t, Traversable t, Semigroup (t e)) =>
Traversal' (GenericList n t e) e
BL.listSelectedElementL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ScenarioItem -> Text
scenarioItemName)
  NewGameMenu NonEmpty (List Name ScenarioItem)
_ -> forall a. a -> Maybe a
Just Text
"Scenarios"
  Menu
_ -> forall a. Maybe a
Nothing

quitMsg :: Menu -> Text
quitMsg :: Menu -> Text
quitMsg Menu
m = Text
"Are you sure you want to " forall a. Semigroup a => a -> a -> a
<> Text
quitAction forall a. Semigroup a => a -> a -> a
<> Text
"? All progress on this scenario will be lost!"
 where
  quitAction :: Text
quitAction = case Menu
m of
    Menu
NoMenu -> Text
"quit"
    Menu
_ -> Text
"return to the menu"

locationToString :: Location -> String
locationToString :: Location -> [Char]
locationToString (Location Int32
x Int32
y) =
  [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Int32
x, Int32
y]

-- | Display a list of text-wrapped paragraphs with one blank line after each.
displayParagraphs :: [Text] -> Widget Name
displayParagraphs :: [Text] -> Widget Name
displayParagraphs = [Widget Name] -> Widget Name
layoutParagraphs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n. Text -> Widget n
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 :: [Widget Name] -> Widget Name
layoutParagraphs [Widget Name]
ps = forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Widget Name]
ps

data EllipsisSide = Beginning | End

withEllipsis :: EllipsisSide -> Text -> Widget Name
withEllipsis :: EllipsisSide -> Text -> Widget Name
withEllipsis EllipsisSide
side Text
t =
  forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed forall a b. (a -> b) -> a -> b
$ do
    Context Name
ctx <- forall n. RenderM n (Context n)
getContext
    let w :: Int
w = Context Name
ctx forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Context n) Int
availWidthL
        ellipsis :: Text
ellipsis = Int -> Text -> Text
T.replicate Int
3 forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
'.'
        tLength :: Int
tLength = Text -> Int
T.length Text
t
        newText :: Text
newText =
          if Int
tLength forall a. Ord a => a -> a -> Bool
> Int
w
            then case EllipsisSide
side of
              EllipsisSide
Beginning -> Text
ellipsis forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
t
              EllipsisSide
End -> Int -> Text -> Text
T.take (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
t forall a. Semigroup a => a -> a -> a
<> Text
ellipsis
            else Text
t
    forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
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 :: forall n. (Ord n, Show n) => n -> Widget n -> Widget n
maybeScroll n
vpName Widget n
contents =
  forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy forall a b. (a -> b) -> a -> b
$ do
    Context n
ctx <- forall n. RenderM n (Context n)
getContext
    Result n
result <- forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (forall n. Lens' (Context n) Int
availHeightL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
10000) (forall n. Widget n -> RenderM n (Result n)
render Widget n
contents)
    if Image -> Int
V.imageHeight (Result n
result forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Result n) Image
imageL) forall a. Ord a => a -> a -> Bool
<= Context n
ctx forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Context n) Int
availHeightL
      then forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result
      else
        forall n. Widget n -> RenderM n (Result n)
render
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. VScrollBarOrientation -> Widget n -> Widget n
withVScrollBars VScrollBarOrientation
OnRight
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
vpName ViewportType
Vertical
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result