{-# LANGUAGE OverloadedStrings #-}

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

import Brick hiding (Direction, Location)
import Brick.Keybindings (Binding (..), KeyConfig, firstActiveBinding, ppBinding)
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.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as M
import Data.Maybe (catMaybes, fromMaybe, isJust)
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.Land
import Swarm.Game.Scenario (scenarioMetadata, scenarioName)
import Swarm.Game.Scenario.Status
import Swarm.Game.ScenarioInfo (scenarioItemName)
import Swarm.Game.State
import Swarm.Game.State.Landscape
import Swarm.Game.State.Substate
import Swarm.Game.Terrain
import Swarm.Language.Syntax (Syntax)
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Language.Types (Polytype)
import Swarm.Pretty (prettyTextLine)
import Swarm.TUI.Model
import Swarm.TUI.Model.Event (SwarmEvent)
import Swarm.TUI.Model.Menu
import Swarm.TUI.Model.UI.Gameplay
import Swarm.TUI.View.Attribute.Attr
import Swarm.TUI.View.CellDisplay
import Swarm.Util (maximum0)
import Witch (from, into)

data ScenarioSeriesContext = ScenarioSeriesContext
  { ScenarioSeriesContext -> [ScenarioWith ScenarioPath]
scenarioSeries :: [ScenarioWith ScenarioPath]
  , ScenarioSeriesContext -> Maybe Text
currentMenuName :: Maybe Text
  , ScenarioSeriesContext -> Bool
hasMenu :: Bool
  }

generateScenarioEndModal ::
  ScenarioSeriesContext ->
  EndScenarioModalType ->
  ScenarioState ->
  Modal
generateScenarioEndModal :: ScenarioSeriesContext
-> EndScenarioModalType -> ScenarioState -> Modal
generateScenarioEndModal (ScenarioSeriesContext [ScenarioWith ScenarioPath]
scenarioList Maybe Text
scenarioMenuName Bool
isNoMenu) EndScenarioModalType
mt ScenarioState
s =
  ModalType -> Dialog ButtonAction Name -> Modal
Modal (EndScenarioModalType -> ModalType
EndScenarioModal EndScenarioModalType
mt) (Dialog ButtonAction Name -> Modal)
-> Dialog ButtonAction Name -> Modal
forall a b. (a -> b) -> a -> b
$
    Maybe (Widget Name)
-> Maybe (Name, [([Char], Name, ButtonAction)])
-> Int
-> Dialog ButtonAction Name
forall n a.
Eq n =>
Maybe (Widget n)
-> Maybe (n, [([Char], n, a)]) -> Int -> Dialog a n
dialog (Widget Name -> Maybe (Widget Name)
forall a. a -> Maybe a
Just (Widget Name -> Maybe (Widget Name))
-> Widget Name -> Maybe (Widget Name)
forall a b. (a -> b) -> a -> b
$ [Char] -> Widget Name
forall n. [Char] -> Widget n
str [Char]
title) Maybe (Name, [([Char], Name, ButtonAction)])
buttons (Int
maxModalWindowWidth Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
requiredWidth)
 where
  currentScenario :: Maybe (ScenarioWith ScenarioPath)
currentScenario = ScenarioState
s ScenarioState
-> Getting
     (Maybe (ScenarioWith ScenarioPath))
     ScenarioState
     (Maybe (ScenarioWith ScenarioPath))
-> Maybe (ScenarioWith ScenarioPath)
forall s a. s -> Getting a s a -> a
^. (UIGameplay
 -> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay)
-> ScenarioState
-> Const (Maybe (ScenarioWith ScenarioPath)) ScenarioState
Lens' ScenarioState UIGameplay
uiGameplay ((UIGameplay
  -> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay)
 -> ScenarioState
 -> Const (Maybe (ScenarioWith ScenarioPath)) ScenarioState)
-> ((Maybe (ScenarioWith ScenarioPath)
     -> Const
          (Maybe (ScenarioWith ScenarioPath))
          (Maybe (ScenarioWith ScenarioPath)))
    -> UIGameplay
    -> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay)
-> Getting
     (Maybe (ScenarioWith ScenarioPath))
     ScenarioState
     (Maybe (ScenarioWith ScenarioPath))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (ScenarioWith ScenarioPath)
 -> Const
      (Maybe (ScenarioWith ScenarioPath))
      (Maybe (ScenarioWith ScenarioPath)))
-> UIGameplay
-> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay
Lens' UIGameplay (Maybe (ScenarioWith ScenarioPath))
scenarioRef
  currentSeed :: Int
currentSeed = ScenarioState
s ScenarioState -> Getting Int ScenarioState Int -> Int
forall s a. s -> Getting a s a -> a
^. (GameState -> Const Int GameState)
-> ScenarioState -> Const Int ScenarioState
Lens' ScenarioState GameState
gameState ((GameState -> Const Int GameState)
 -> ScenarioState -> Const Int ScenarioState)
-> ((Int -> Const Int Int) -> GameState -> Const Int GameState)
-> Getting Int ScenarioState Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Randomness -> Const Int Randomness)
-> GameState -> Const Int GameState
Lens' GameState Randomness
randomness ((Randomness -> Const Int Randomness)
 -> GameState -> Const Int GameState)
-> ((Int -> Const Int Int) -> Randomness -> Const Int Randomness)
-> (Int -> Const Int Int)
-> GameState
-> Const Int GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Randomness -> Const Int Randomness
Lens' Randomness Int
seed

  ([Char]
title, Maybe (Name, [([Char], Name, ButtonAction)])
buttons, Int
requiredWidth) = case EndScenarioModalType
mt of
    ScenarioFinishModal ScenarioOutcome
WinModal -> ([Char], Maybe (Name, [([Char], Name, ButtonAction)]), Int)
mkWinModal
    ScenarioFinishModal ScenarioOutcome
LoseModal -> ([Char], Maybe (Name, [([Char], Name, ButtonAction)]), Int)
mkLoseModal
    EndScenarioModalType
QuitModal -> ([Char], Maybe (Name, [([Char], Name, ButtonAction)]), Int)
mkQuitModal
    EndScenarioModalType
KeepPlayingModal -> ([Char]
"", (Name, [([Char], Name, ButtonAction)])
-> Maybe (Name, [([Char], Name, ButtonAction)])
forall a. a -> Maybe a
Just (Button -> Name
Button Button
CancelButton, [([Char]
"OK", Button -> Name
Button Button
CancelButton, ButtonAction
Cancel)]), Int
80)

  mkWinModal :: ([Char], Maybe (Name, [([Char], Name, ButtonAction)]), Int)
mkWinModal =
    ( [Char]
""
    , (Name, [([Char], Name, ButtonAction)])
-> Maybe (Name, [([Char], Name, ButtonAction)])
forall a. a -> Maybe a
Just
        ( Button -> Name
Button Button
NextButton
        , [ ([Char]
nextMsg, Button -> Name
Button Button
NextButton, NonEmpty (ScenarioWith ScenarioPath) -> ButtonAction
Next NonEmpty (ScenarioWith ScenarioPath)
remainingScenarios)
          | Just NonEmpty (ScenarioWith ScenarioPath)
remainingScenarios <- [[ScenarioWith ScenarioPath]
-> Maybe (NonEmpty (ScenarioWith ScenarioPath))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ScenarioWith ScenarioPath]
scenarioList]
          ]
            [([Char], Name, ButtonAction)]
-> [([Char], Name, ButtonAction)] -> [([Char], Name, ButtonAction)]
forall a. [a] -> [a] -> [a]
++ [ ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction) -- TODO(#2376) QuitAction is not used
               , ([Char]
continueMsg, Button -> Name
Button Button
KeepPlayingButton, ButtonAction
KeepPlaying)
               ]
        )
    , [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]
nextMsg, [Char]
stopMsg, [Char]
continueMsg]) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32
    )
   where
    nextMsg :: [Char]
nextMsg = [Char]
"Next challenge!"

  maybeStartOver :: Maybe ([Char], Name, ButtonAction)
maybeStartOver = do
    ScenarioWith ScenarioPath
cs <- Maybe (ScenarioWith ScenarioPath)
currentScenario
    ([Char], Name, ButtonAction) -> Maybe ([Char], Name, ButtonAction)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"Start over", Button -> Name
Button Button
StartOverButton, Int -> ScenarioWith ScenarioPath -> ButtonAction
StartOver Int
currentSeed ScenarioWith ScenarioPath
cs)

  mkLoseModal :: ([Char], Maybe (Name, [([Char], Name, ButtonAction)]), Int)
mkLoseModal =
    ( [Char]
""
    , (Name, [([Char], Name, ButtonAction)])
-> Maybe (Name, [([Char], Name, ButtonAction)])
forall a. a -> Maybe a
Just
        ( Button -> Name
Button (Button -> Name) -> Button -> Name
forall a b. (a -> b) -> a -> b
$ if Maybe (ScenarioWith ScenarioPath) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ScenarioWith ScenarioPath)
currentScenario then Button
StartOverButton else Button
QuitButton
        , [Maybe ([Char], Name, ButtonAction)]
-> [([Char], Name, ButtonAction)]
forall a. [Maybe a] -> [a]
catMaybes
            [ ([Char], Name, ButtonAction) -> Maybe ([Char], Name, ButtonAction)
forall a. a -> Maybe a
Just ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
            , Maybe ([Char], Name, ButtonAction)
maybeStartOver
            , ([Char], Name, ButtonAction) -> Maybe ([Char], Name, ButtonAction)
forall a. a -> Maybe a
Just ([Char]
continueMsg, Button -> Name
Button Button
KeepPlayingButton, ButtonAction
KeepPlaying)
            ]
        )
    , [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]
stopMsg, [Char]
continueMsg]) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32
    )

  stopMsg :: [Char]
stopMsg = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char]
"Quit to" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) (forall target source. From source target => source -> target
into @String (Text -> [Char]) -> Maybe Text -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
scenarioMenuName) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" menu") Maybe [Char]
haltingMessage
  continueMsg :: [Char]
continueMsg = [Char]
"Keep playing"

  haltingMessage :: Maybe [Char]
haltingMessage =
    if Bool
isNoMenu
      then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Quit"
      else Maybe [Char]
forall a. Maybe a
Nothing

  mkQuitModal :: ([Char], Maybe (Name, [([Char], Name, ButtonAction)]), Int)
mkQuitModal =
    ( [Char]
""
    , (Name, [([Char], Name, ButtonAction)])
-> Maybe (Name, [([Char], Name, ButtonAction)])
forall a. a -> Maybe a
Just
        ( Button -> Name
Button Button
CancelButton
        , [Maybe ([Char], Name, ButtonAction)]
-> [([Char], Name, ButtonAction)]
forall a. [Maybe a] -> [a]
catMaybes
            [ ([Char], Name, ButtonAction) -> Maybe ([Char], Name, ButtonAction)
forall a. a -> Maybe a
Just ([Char]
"Keep playing", Button -> Name
Button Button
CancelButton, ButtonAction
Cancel)
            , Maybe ([Char], Name, ButtonAction)
maybeStartOver
            , ([Char], Name, ButtonAction) -> Maybe ([Char], Name, ButtonAction)
forall a. a -> Maybe a
Just ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
            ]
        )
    , Text -> Int
T.length (Bool -> Text
quitMsg Bool
isNoMenu) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
    )

-- | Generate a fresh modal window of the requested type.
generateModal :: ScenarioState -> MidScenarioModalType -> Modal
generateModal :: ScenarioState -> MidScenarioModalType -> Modal
generateModal ScenarioState
s MidScenarioModalType
mt =
  ModalType -> Dialog ButtonAction Name -> Modal
Modal (MidScenarioModalType -> ModalType
MidScenarioModal MidScenarioModalType
mt) (Dialog ButtonAction Name -> Modal)
-> Dialog ButtonAction Name -> Modal
forall a b. (a -> b) -> a -> b
$
    Maybe (Widget Name)
-> Maybe (Name, [([Char], Name, ButtonAction)])
-> Int
-> Dialog ButtonAction Name
forall n a.
Eq n =>
Maybe (Widget n)
-> Maybe (n, [([Char], n, a)]) -> Int -> Dialog a n
dialog (Widget Name -> Maybe (Widget Name)
forall a. a -> Maybe a
Just (Widget Name -> Maybe (Widget Name))
-> Widget Name -> Maybe (Widget Name)
forall a b. (a -> b) -> a -> b
$ [Char] -> Widget Name
forall n. [Char] -> Widget n
str [Char]
title) Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
buttons (Int
maxModalWindowWidth Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
requiredWidth)
 where
  currentScenario :: Maybe (ScenarioWith ScenarioPath)
currentScenario = ScenarioState
s ScenarioState
-> Getting
     (Maybe (ScenarioWith ScenarioPath))
     ScenarioState
     (Maybe (ScenarioWith ScenarioPath))
-> Maybe (ScenarioWith ScenarioPath)
forall s a. s -> Getting a s a -> a
^. (UIGameplay
 -> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay)
-> ScenarioState
-> Const (Maybe (ScenarioWith ScenarioPath)) ScenarioState
Lens' ScenarioState UIGameplay
uiGameplay ((UIGameplay
  -> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay)
 -> ScenarioState
 -> Const (Maybe (ScenarioWith ScenarioPath)) ScenarioState)
-> ((Maybe (ScenarioWith ScenarioPath)
     -> Const
          (Maybe (ScenarioWith ScenarioPath))
          (Maybe (ScenarioWith ScenarioPath)))
    -> UIGameplay
    -> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay)
-> Getting
     (Maybe (ScenarioWith ScenarioPath))
     ScenarioState
     (Maybe (ScenarioWith ScenarioPath))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (ScenarioWith ScenarioPath)
 -> Const
      (Maybe (ScenarioWith ScenarioPath))
      (Maybe (ScenarioWith ScenarioPath)))
-> UIGameplay
-> Const (Maybe (ScenarioWith ScenarioPath)) UIGameplay
Lens' UIGameplay (Maybe (ScenarioWith ScenarioPath))
scenarioRef

  descriptionWidth :: Int
descriptionWidth = Int
100
  ([Char]
title, Maybe a
buttons, Int
requiredWidth) =
    case MidScenarioModalType
mt of
      MidScenarioModalType
HelpModal -> ([Char]
" Help ", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
RobotsModal -> ([Char]
"Robots", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
RecipesModal -> ([Char]
"Available Recipes", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
CommandsModal -> ([Char]
"Available Commands", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
MessagesModal -> ([Char]
"Messages", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
StructuresModal -> ([Char]
"Buildable Structures", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      DescriptionModal Entity
e -> (Entity -> [Char]
descriptionTitle Entity
e, Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
GoalModal ->
        let goalModalTitle :: Text
goalModalTitle = case Maybe (ScenarioWith ScenarioPath)
currentScenario of
              Maybe (ScenarioWith ScenarioPath)
Nothing -> Text
"Goal"
              Just (ScenarioWith Scenario
scenario ScenarioPath
_) -> Scenario
scenario Scenario -> Getting Text Scenario Text -> Text
forall s a. s -> Getting a s a -> a
^. (ScenarioMetadata -> Const Text ScenarioMetadata)
-> Scenario -> Const Text Scenario
Lens' Scenario ScenarioMetadata
scenarioMetadata ((ScenarioMetadata -> Const Text ScenarioMetadata)
 -> Scenario -> Const Text Scenario)
-> ((Text -> Const Text Text)
    -> ScenarioMetadata -> Const Text ScenarioMetadata)
-> Getting Text Scenario Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ScenarioMetadata -> Const Text ScenarioMetadata
Lens' ScenarioMetadata Text
scenarioName
         in ([Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
goalModalTitle [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" ", Maybe a
forall a. Maybe a
Nothing, Int
descriptionWidth)
      MidScenarioModalType
TerrainPaletteModal -> ([Char]
"Terrain", Maybe a
forall a. Maybe a
Nothing, Int
w)
       where
        tm :: TerrainMap
tm = ScenarioState
s ScenarioState
-> Getting TerrainMap ScenarioState TerrainMap -> TerrainMap
forall s a. s -> Getting a s a -> a
^. (GameState -> Const TerrainMap GameState)
-> ScenarioState -> Const TerrainMap ScenarioState
Lens' ScenarioState GameState
gameState ((GameState -> Const TerrainMap GameState)
 -> ScenarioState -> Const TerrainMap ScenarioState)
-> ((TerrainMap -> Const TerrainMap TerrainMap)
    -> GameState -> Const TerrainMap GameState)
-> Getting TerrainMap ScenarioState TerrainMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Landscape -> Const TerrainMap Landscape)
-> GameState -> Const TerrainMap GameState
Lens' GameState Landscape
landscape ((Landscape -> Const TerrainMap Landscape)
 -> GameState -> Const TerrainMap GameState)
-> ((TerrainMap -> Const TerrainMap TerrainMap)
    -> Landscape -> Const TerrainMap Landscape)
-> (TerrainMap -> Const TerrainMap TerrainMap)
-> GameState
-> Const TerrainMap GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps)
-> Landscape -> Const TerrainMap Landscape
Lens' Landscape TerrainEntityMaps
terrainAndEntities ((TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps)
 -> Landscape -> Const TerrainMap Landscape)
-> ((TerrainMap -> Const TerrainMap TerrainMap)
    -> TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps)
-> (TerrainMap -> Const TerrainMap TerrainMap)
-> Landscape
-> Const TerrainMap Landscape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainMap -> Const TerrainMap TerrainMap)
-> TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps
Lens' TerrainEntityMaps TerrainMap
terrainMap
        wordLength :: Int
wordLength = [Int] -> Int
forall a. (Num a, Ord a) => [a] -> a
maximum0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (TerrainType -> Int) -> [TerrainType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
T.length (Text -> Int) -> (TerrainType -> Text) -> TerrainType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerrainType -> Text
getTerrainWord) (Map TerrainType TerrainObj -> [TerrainType]
forall k a. Map k a -> [k]
M.keys (Map TerrainType TerrainObj -> [TerrainType])
-> Map TerrainType TerrainObj -> [TerrainType]
forall a b. (a -> b) -> a -> b
$ TerrainMap -> Map TerrainType TerrainObj
terrainByName TerrainMap
tm)
        w :: Int
w = Int
wordLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6
      MidScenarioModalType
EntityPaletteModal -> ([Char]
"Entity", Maybe a
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 Polytype
ty = Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
  Context Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
  let w :: Int
w = Context Name
ctx Context Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context Name) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL
      renderedTy :: Text
renderedTy = Polytype -> Text
forall a. PrettyPrec a => a -> Text
prettyTextLine Polytype
ty
      displayedTy :: Text
displayedTy
        | Text -> Int
T.length Text
renderedTy Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 = Text
renderedTy
        | Bool
otherwise = Int -> Text -> Text
T.take (Int
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Text
renderedTy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
  Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> (Text -> Widget Name) -> Text -> RenderM Name (Result Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
infoAttr (Widget Name -> Widget Name)
-> (Text -> Widget Name) -> Text -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
padLeftRight Int
1 (Widget Name -> Widget Name)
-> (Text -> Widget Name) -> Text -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Widget Name
forall n. Text -> Widget n
txt (Text -> RenderM Name (Result Name))
-> Text -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Text
displayedTy

-- | 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
  Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
    Context Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
    let w :: Int
w = Context Name
ctx Context Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context Name) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL
    let docLines :: [[[StreamNode]]]
docLines = Int -> [StreamNode] -> [[StreamNode]]
Markdown.chunksOf Int
w ([StreamNode] -> [[StreamNode]])
-> (Paragraph Syntax -> [StreamNode])
-> Paragraph Syntax
-> [[StreamNode]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paragraph Syntax -> [StreamNode]
forall a. ToStream a => a -> [StreamNode]
Markdown.toStream (Paragraph Syntax -> [[StreamNode]])
-> [Paragraph Syntax] -> [[[StreamNode]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document Syntax -> [Paragraph Syntax]
forall c. Document c -> [Paragraph c]
Markdown.paragraphs Document Syntax
d
    Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> ([Widget Name] -> Widget Name)
-> [Widget Name]
-> RenderM Name (Result Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Widget Name] -> Widget Name
layoutParagraphs ([Widget Name] -> RenderM Name (Result Name))
-> [Widget Name] -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox ([Widget Name] -> Widget Name)
-> ([[StreamNode]] -> [Widget Name])
-> [[StreamNode]]
-> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StreamNode] -> Widget Name) -> [[StreamNode]] -> [Widget Name]
forall a b. (a -> b) -> [a] -> [b]
map ([Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox ([Widget Name] -> Widget Name)
-> ([StreamNode] -> [Widget Name]) -> [StreamNode] -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StreamNode -> Widget Name) -> [StreamNode] -> [Widget Name]
forall a b. (a -> b) -> [a] -> [b]
map StreamNode -> Widget Name
forall {n}. StreamNode -> Widget n
mTxt) ([[StreamNode]] -> Widget Name)
-> [[[StreamNode]]] -> [Widget Name]
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 -> (TxtAttr -> Widget n -> Widget n)
-> Widget n -> Set TxtAttr -> Widget n
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxtAttr -> Widget n -> Widget n
forall {n}. TxtAttr -> Widget n -> Widget n
applyAttr (Text -> Widget n
forall n. Text -> Widget n
txt Text
t) Set TxtAttr
as
    Markdown.CodeNode Text
t -> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
highlightAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
t
    Markdown.RawNode [Char]
f Text
t -> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr ([Char] -> AttrName
rawAttr [Char]
f) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
t
  applyAttr :: TxtAttr -> Widget n -> Widget n
applyAttr TxtAttr
a = AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName -> Widget n -> Widget n)
-> AttrName -> Widget n -> Widget n
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]
"structure" -> AttrName
redAttr
    [Char]
"tag" -> AttrName
yellowAttr
    [Char]
"robot" -> AttrName
beigeAttr
    [Char]
"type" -> AttrName
magentaAttr
    [Char]
_snippet -> AttrName
highlightAttr -- same as plain code

drawLabeledTerrainSwatch :: TerrainMap -> TerrainType -> Widget Name
drawLabeledTerrainSwatch :: TerrainMap -> TerrainType -> Widget Name
drawLabeledTerrainSwatch TerrainMap
tm TerrainType
a =
  Widget Name
forall {n}. Widget n
tile Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<+> [Char] -> Widget Name
forall n. [Char] -> Widget n
str [Char]
materialName
 where
  tile :: Widget n
tile =
    Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1)
      (Widget n -> Widget n)
-> (Maybe TerrainObj -> Widget n) -> Maybe TerrainObj -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> Widget n
forall n. Display -> Widget n
renderDisplay
      (Display -> Widget n)
-> (Maybe TerrainObj -> Display) -> Maybe TerrainObj -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> (TerrainObj -> Display) -> Maybe TerrainObj -> Display
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Display
forall a. Monoid a => a
mempty TerrainObj -> Display
terrainDisplay
      (Maybe TerrainObj -> Widget n) -> Maybe TerrainObj -> Widget n
forall a b. (a -> b) -> a -> b
$ TerrainType -> Map TerrainType TerrainObj -> Maybe TerrainObj
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TerrainType
a (TerrainMap -> Map TerrainType TerrainObj
terrainByName TerrainMap
tm)

  materialName :: [Char]
materialName = [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ TerrainType -> [Char]
forall a. Show a => a -> [Char]
show TerrainType
a

descriptionTitle :: Entity -> String
descriptionTitle :: Entity -> [Char]
descriptionTitle Entity
e = [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall source target. From source target => source -> target
from @Text (Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName) [Char] -> [Char] -> [Char]
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 :: Menu -> Maybe Text
curMenuName :: Menu -> Maybe Text
curMenuName Menu
m = case Menu
m of
  NewGameMenu (List Name (ScenarioItem ScenarioPath)
_ :| (List Name (ScenarioItem ScenarioPath)
parentMenu : [List Name (ScenarioItem ScenarioPath)]
_)) ->
    Text -> Maybe Text
forall a. a -> Maybe a
Just (List Name (ScenarioItem ScenarioPath)
parentMenu List Name (ScenarioItem ScenarioPath)
-> Getting Text (List Name (ScenarioItem ScenarioPath)) Text
-> Text
forall s a. s -> Getting a s a -> a
^. (ScenarioItem ScenarioPath
 -> Const Text (ScenarioItem ScenarioPath))
-> List Name (ScenarioItem ScenarioPath)
-> Const Text (List Name (ScenarioItem ScenarioPath))
Traversal'
  (List Name (ScenarioItem ScenarioPath)) (ScenarioItem ScenarioPath)
forall (t :: * -> *) e n.
(Splittable t, Traversable t, Semigroup (t e)) =>
Traversal' (GenericList n t e) e
BL.listSelectedElementL ((ScenarioItem ScenarioPath
  -> Const Text (ScenarioItem ScenarioPath))
 -> List Name (ScenarioItem ScenarioPath)
 -> Const Text (List Name (ScenarioItem ScenarioPath)))
-> ((Text -> Const Text Text)
    -> ScenarioItem ScenarioPath
    -> Const Text (ScenarioItem ScenarioPath))
-> Getting Text (List Name (ScenarioItem ScenarioPath)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioItem ScenarioPath -> Text)
-> (Text -> Const Text Text)
-> ScenarioItem ScenarioPath
-> Const Text (ScenarioItem ScenarioPath)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ScenarioItem ScenarioPath -> Text
forall a. ScenarioItem a -> Text
scenarioItemName)
  NewGameMenu NonEmpty (List Name (ScenarioItem ScenarioPath))
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Scenarios"
  Menu
_ -> Maybe Text
forall a. Maybe a
Nothing

quitMsg :: Bool -> Text
quitMsg :: Bool -> Text
quitMsg Bool
isNoMenu =
  [Text] -> Text
T.unwords
    [ Text
"Are you sure you want to"
    , Text
quitAction Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?"
    , Text
"All progress on this scenario will be lost!"
    ]
 where
  quitAction :: Text
quitAction =
    if Bool
isNoMenu
      then Text
"quit"
      else 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 = [Widget Name] -> Widget Name
layoutParagraphs ([Widget Name] -> Widget Name)
-> ([Text] -> [Widget Name]) -> [Text] -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Widget Name) -> [Text] -> [Widget Name]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Widget Name
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 = [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox ([Widget Name] -> Widget Name) -> [Widget Name] -> Widget Name
forall a b. (a -> b) -> a -> b
$ Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) (Widget Name -> Widget Name) -> [Widget Name] -> [Widget Name]
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 =
  Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
    Context Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
    let w :: Int
w = Context Name
ctx Context Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context Name) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL
        ellipsis :: Text
ellipsis = Int -> Text -> Text
T.replicate Int
3 (Text -> Text) -> Text -> Text
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
w
            then case EllipsisSide
side of
              EllipsisSide
Beginning -> Text
ellipsis Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
t
              EllipsisSide
End -> Int -> Text -> Text
T.take (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ellipsis
            else Text
t
    Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Text -> Widget Name
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 =
  Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
    Context n
ctx <- RenderM n (Context n)
forall n. RenderM n (Context n)
getContext
    Result n
result <- (Context n -> Context n)
-> RenderM n (Result n) -> RenderM n (Result n)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT ((Int -> Identity Int) -> Context n -> Identity (Context n)
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availHeightL ((Int -> Identity Int) -> Context n -> Identity (Context n))
-> Int -> Context n -> Context n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
10000) (Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render Widget n
contents)
    if Image -> Int
V.imageHeight (Result n
result Result n -> Getting Image (Result n) Image -> Image
forall s a. s -> Getting a s a -> a
^. Getting Image (Result n) Image
forall n (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Context n
ctx Context n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availHeightL
      then Result n -> RenderM n (Result n)
forall a. a -> ReaderT (Context n) (State (RenderState n)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result
      else
        Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render
          (Widget n -> RenderM n (Result n))
-> (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n)
-> RenderM n (Result n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VScrollBarOrientation -> Widget n -> Widget n
forall n. VScrollBarOrientation -> Widget n -> Widget n
withVScrollBars VScrollBarOrientation
OnRight
          (Widget n -> Widget n)
-> (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n)
-> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> ViewportType -> Widget n -> Widget n
forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
vpName ViewportType
Vertical
          (Widget n -> Widget n)
-> (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n)
-> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed
          (RenderM n (Result n) -> RenderM n (Result n))
-> RenderM n (Result n) -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ Result n -> RenderM n (Result n)
forall a. a -> ReaderT (Context n) (State (RenderState n)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result

-- | Draw the name of an entity, labelled with its visual
--   representation as a cell in the world.
drawLabelledEntityName :: Entity -> Widget n
drawLabelledEntityName :: forall n. Entity -> Widget n
drawLabelledEntityName Entity
e =
  [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
hBox
    [ Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
2) (Display -> Widget n
forall n. Display -> Widget n
renderDisplay (Entity
e Entity -> Getting Display Entity Display -> Display
forall s a. s -> Getting a s a -> a
^. Getting Display Entity Display
Lens' Entity Display
entityDisplay))
    , Text -> Widget n
forall n. Text -> Widget n
txt (Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName)
    ]

-- | Render the keybinding bound to a specific event.
bindingText :: KeyConfig SwarmEvent -> SwarmEvent -> Text
bindingText :: KeyConfig SwarmEvent -> SwarmEvent -> Text
bindingText KeyConfig SwarmEvent
keyConf SwarmEvent
e = Text -> (Binding -> Text) -> Maybe Binding -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Binding -> Text
ppBindingShort Maybe Binding
b
 where
  b :: Maybe Binding
b = KeyConfig SwarmEvent -> SwarmEvent -> Maybe Binding
forall k. (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding
firstActiveBinding KeyConfig SwarmEvent
keyConf SwarmEvent
e
  ppBindingShort :: Binding -> Text
ppBindingShort = \case
    Binding Key
V.KUp Set Modifier
m | Set Modifier -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Modifier
m -> Text
"↑"
    Binding Key
V.KDown Set Modifier
m | Set Modifier -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Modifier
m -> Text
"↓"
    Binding Key
V.KLeft Set Modifier
m | Set Modifier -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Modifier
m -> Text
"←"
    Binding Key
V.KRight Set Modifier
m | Set Modifier -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Modifier
m -> Text
"→"
    Binding
bi -> Binding -> Text
ppBinding Binding
bi