{-# LANGUAGE OverloadedStrings #-}

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

import Brick hiding (Direction, Location)
import Brick.Keybindings (Binding (..), 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.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.Land
import Swarm.Game.Location
import Swarm.Game.Scenario (scenarioMetadata, scenarioName)
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.Pretty (prettyTextLine)
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.Event (SwarmEvent)
import Swarm.TUI.Model.UI
import Swarm.TUI.View.Attribute.Attr
import Swarm.TUI.View.CellDisplay
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 (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 ScenarioInfoPair
currentScenario = AppState
s AppState
-> Getting
     (Maybe ScenarioInfoPair) AppState (Maybe ScenarioInfoPair)
-> Maybe ScenarioInfoPair
forall s a. s -> Getting a s a -> a
^. (UIState -> Const (Maybe ScenarioInfoPair) UIState)
-> AppState -> Const (Maybe ScenarioInfoPair) AppState
Lens' AppState UIState
uiState ((UIState -> Const (Maybe ScenarioInfoPair) UIState)
 -> AppState -> Const (Maybe ScenarioInfoPair) AppState)
-> ((Maybe ScenarioInfoPair
     -> Const (Maybe ScenarioInfoPair) (Maybe ScenarioInfoPair))
    -> UIState -> Const (Maybe ScenarioInfoPair) UIState)
-> Getting
     (Maybe ScenarioInfoPair) AppState (Maybe ScenarioInfoPair)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UIGameplay -> Const (Maybe ScenarioInfoPair) UIGameplay)
-> UIState -> Const (Maybe ScenarioInfoPair) UIState
Lens' UIState UIGameplay
uiGameplay ((UIGameplay -> Const (Maybe ScenarioInfoPair) UIGameplay)
 -> UIState -> Const (Maybe ScenarioInfoPair) UIState)
-> ((Maybe ScenarioInfoPair
     -> Const (Maybe ScenarioInfoPair) (Maybe ScenarioInfoPair))
    -> UIGameplay -> Const (Maybe ScenarioInfoPair) UIGameplay)
-> (Maybe ScenarioInfoPair
    -> Const (Maybe ScenarioInfoPair) (Maybe ScenarioInfoPair))
-> UIState
-> Const (Maybe ScenarioInfoPair) UIState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ScenarioInfoPair
 -> Const (Maybe ScenarioInfoPair) (Maybe ScenarioInfoPair))
-> UIGameplay -> Const (Maybe ScenarioInfoPair) UIGameplay
Lens' UIGameplay (Maybe ScenarioInfoPair)
scenarioRef
  currentSeed :: Int
currentSeed = AppState
s AppState -> Getting Int AppState Int -> Int
forall s a. s -> Getting a s a -> a
^. (GameState -> Const Int GameState)
-> AppState -> Const Int AppState
Lens' AppState GameState
gameState ((GameState -> Const Int GameState)
 -> AppState -> Const Int AppState)
-> ((Int -> Const Int Int) -> GameState -> Const Int GameState)
-> Getting Int AppState 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
  haltingMessage :: Maybe [Char]
haltingMessage = case AppState
s AppState -> Getting Menu AppState Menu -> Menu
forall s a. s -> Getting a s a -> a
^. (UIState -> Const Menu UIState) -> AppState -> Const Menu AppState
Lens' AppState UIState
uiState ((UIState -> Const Menu UIState)
 -> AppState -> Const Menu AppState)
-> ((Menu -> Const Menu Menu) -> UIState -> Const Menu UIState)
-> Getting Menu AppState Menu
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Menu -> Const Menu Menu) -> UIState -> Const Menu UIState
Lens' UIState Menu
uiMenu of
    Menu
NoMenu -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Quit"
    Menu
_ -> Maybe [Char]
forall a. Maybe a
Nothing
  descriptionWidth :: Int
descriptionWidth = Int
100
  ([Char]
title, Maybe (Name, [([Char], Name, ButtonAction)])
buttons, Int
requiredWidth) =
    case ModalType
mt of
      ModalType
HelpModal -> ([Char]
" Help ", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
RobotsModal -> ([Char]
"Robots", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
RecipesModal -> ([Char]
"Available Recipes", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
CommandsModal -> ([Char]
"Available Commands", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
MessagesModal -> ([Char]
"Messages", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
StructuresModal -> ([Char]
"Buildable Structures", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ScenarioEndModal ScenarioOutcome
WinModal ->
        let nextMsg :: [Char]
nextMsg = [Char]
"Next challenge!"
            stopMsg :: [Char]
stopMsg = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"Return to the menu" Maybe [Char]
haltingMessage
            continueMsg :: [Char]
continueMsg = [Char]
"Keep playing"
         in ( [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, ScenarioInfoPair -> ButtonAction
Next ScenarioInfoPair
scene)
                  | Just ScenarioInfoPair
scene <- [Menu -> Maybe ScenarioInfoPair
nextScenario (AppState
s AppState -> Getting Menu AppState Menu -> Menu
forall s a. s -> Getting a s a -> a
^. (UIState -> Const Menu UIState) -> AppState -> Const Menu AppState
Lens' AppState UIState
uiState ((UIState -> Const Menu UIState)
 -> AppState -> Const Menu AppState)
-> ((Menu -> Const Menu Menu) -> UIState -> Const Menu UIState)
-> Getting Menu AppState Menu
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Menu -> Const Menu Menu) -> UIState -> Const Menu UIState
Lens' UIState Menu
uiMenu)]
                  ]
                    [([Char], Name, ButtonAction)]
-> [([Char], Name, ButtonAction)] -> [([Char], Name, ButtonAction)]
forall a. [a] -> [a] -> [a]
++ [ ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
                       , ([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
            )
      ScenarioEndModal ScenarioOutcome
LoseModal ->
        let stopMsg :: [Char]
stopMsg = [Char] -> Maybe [Char] -> [Char]
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
              ([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 -> ScenarioInfoPair -> ButtonAction
StartOver Int
currentSeed ScenarioInfoPair
cs)
         in ( [Char]
""
            , (Name, [([Char], Name, ButtonAction)])
-> Maybe (Name, [([Char], Name, ButtonAction)])
forall a. a -> Maybe a
Just
                ( Button -> Name
Button 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
            )
      DescriptionModal Entity
e -> (Entity -> [Char]
descriptionTitle Entity
e, Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
QuitModal ->
        let 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
<$> AppState -> Maybe Text
curMenuName AppState
s) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" menu") Maybe [Char]
haltingMessage
            maybeStartOver :: Maybe ([Char], Name, ButtonAction)
maybeStartOver = do
              ScenarioInfoPair
cs <- Maybe ScenarioInfoPair
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 -> ScenarioInfoPair -> ButtonAction
StartOver Int
currentSeed ScenarioInfoPair
cs)
         in ( [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 (Menu -> Text
quitMsg (AppState
s AppState -> Getting Menu AppState Menu -> Menu
forall s a. s -> Getting a s a -> a
^. (UIState -> Const Menu UIState) -> AppState -> Const Menu AppState
Lens' AppState UIState
uiState ((UIState -> Const Menu UIState)
 -> AppState -> Const Menu AppState)
-> ((Menu -> Const Menu Menu) -> UIState -> Const Menu UIState)
-> Getting Menu AppState Menu
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Menu -> Const Menu Menu) -> UIState -> Const Menu UIState
Lens' UIState Menu
uiMenu)) Int -> Int -> Int
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 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 (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
descriptionWidth)
      ModalType
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)
      ModalType
TerrainPaletteModal -> ([Char]
"Terrain", Maybe (Name, [([Char], Name, ButtonAction)])
forall a. Maybe a
Nothing, Int
w)
       where
        tm :: TerrainMap
tm = AppState
s AppState -> Getting TerrainMap AppState TerrainMap -> TerrainMap
forall s a. s -> Getting a s a -> a
^. (GameState -> Const TerrainMap GameState)
-> AppState -> Const TerrainMap AppState
Lens' AppState GameState
gameState ((GameState -> Const TerrainMap GameState)
 -> AppState -> Const TerrainMap AppState)
-> ((TerrainMap -> Const TerrainMap TerrainMap)
    -> GameState -> Const TerrainMap GameState)
-> Getting TerrainMap AppState 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. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([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
      ModalType
EntityPaletteModal -> ([Char]
"Entity", Maybe (Name, [([Char], Name, ButtonAction)])
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]
"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 :: AppState -> Maybe Text
curMenuName :: AppState -> Maybe Text
curMenuName AppState
s = case AppState
s AppState -> Getting Menu AppState Menu -> Menu
forall s a. s -> Getting a s a -> a
^. (UIState -> Const Menu UIState) -> AppState -> Const Menu AppState
Lens' AppState UIState
uiState ((UIState -> Const Menu UIState)
 -> AppState -> Const Menu AppState)
-> ((Menu -> Const Menu Menu) -> UIState -> Const Menu UIState)
-> Getting Menu AppState Menu
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Menu -> Const Menu Menu) -> UIState -> Const Menu UIState
Lens' UIState Menu
uiMenu of
  NewGameMenu (List Name ScenarioItem
_ :| (List Name ScenarioItem
parentMenu : [List Name ScenarioItem]
_)) ->
    Text -> Maybe Text
forall a. a -> Maybe a
Just (List Name ScenarioItem
parentMenu List Name ScenarioItem
-> Getting Text (List Name ScenarioItem) Text -> Text
forall s a. s -> Getting a s a -> a
^. (ScenarioItem -> Const Text ScenarioItem)
-> List Name ScenarioItem -> Const Text (List Name ScenarioItem)
Traversal' (List Name ScenarioItem) ScenarioItem
forall (t :: * -> *) e n.
(Splittable t, Traversable t, Semigroup (t e)) =>
Traversal' (GenericList n t e) e
BL.listSelectedElementL ((ScenarioItem -> Const Text ScenarioItem)
 -> List Name ScenarioItem -> Const Text (List Name ScenarioItem))
-> ((Text -> Const Text Text)
    -> ScenarioItem -> Const Text ScenarioItem)
-> Getting Text (List Name ScenarioItem) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioItem -> Text)
-> (Text -> Const Text Text)
-> ScenarioItem
-> Const Text ScenarioItem
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)
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Scenarios"
  Menu
_ -> Maybe Text
forall a. Maybe a
Nothing

quitMsg :: Menu -> Text
quitMsg :: Menu -> Text
quitMsg Menu
m = Text
"Are you sure you want to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
quitAction Text -> Text -> Text
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Int32 -> [Char]) -> [Int32] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int32 -> [Char]
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 ([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 :: AppState -> SwarmEvent -> Text
bindingText :: AppState -> SwarmEvent -> Text
bindingText AppState
s 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
  conf :: KeyConfig SwarmEvent
conf = AppState
s AppState
-> Getting (KeyConfig SwarmEvent) AppState (KeyConfig SwarmEvent)
-> KeyConfig SwarmEvent
forall s a. s -> Getting a s a -> a
^. (KeyEventHandlingState
 -> Const (KeyConfig SwarmEvent) KeyEventHandlingState)
-> AppState -> Const (KeyConfig SwarmEvent) AppState
Lens' AppState KeyEventHandlingState
keyEventHandling ((KeyEventHandlingState
  -> Const (KeyConfig SwarmEvent) KeyEventHandlingState)
 -> AppState -> Const (KeyConfig SwarmEvent) AppState)
-> ((KeyConfig SwarmEvent
     -> Const (KeyConfig SwarmEvent) (KeyConfig SwarmEvent))
    -> KeyEventHandlingState
    -> Const (KeyConfig SwarmEvent) KeyEventHandlingState)
-> Getting (KeyConfig SwarmEvent) AppState (KeyConfig SwarmEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyConfig SwarmEvent
 -> Const (KeyConfig SwarmEvent) (KeyConfig SwarmEvent))
-> KeyEventHandlingState
-> Const (KeyConfig SwarmEvent) KeyEventHandlingState
Lens' KeyEventHandlingState (KeyConfig SwarmEvent)
keyConfig
  b :: Maybe Binding
b = KeyConfig SwarmEvent -> SwarmEvent -> Maybe Binding
forall k. (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding
firstActiveBinding KeyConfig SwarmEvent
conf 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