{-# 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 :: 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)
      ModalType
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
            )
      ModalType
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)

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

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"

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

withEllipsis :: Text -> Widget Name
withEllipsis :: Text -> Widget Name
withEllipsis 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 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 a b. (a -> b) -> a -> b
$
          forall n. VScrollBarOrientation -> Widget n -> Widget n
withVScrollBars VScrollBarOrientation
OnRight forall a b. (a -> b) -> a -> b
$
            forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
vpName ViewportType
Vertical forall a b. (a -> b) -> a -> b
$
              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