{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Rendering attributes (/i.e./ foreground and background colors,
-- styles, /etc./) used by the Swarm TUI.
--
-- We export constants only for those we use in the Haskell code
-- and not those used in the world map, to avoid abusing attributes.
-- For example using the robot attribute to highlight some text.
--
-- The few attributes that we use for drawing the logo are an exception.
module Swarm.TUI.View.Attribute.Attr (
  swarmAttrMap,
  worldAttributes,
  worldPrefix,
  meterAttributeNames,
  messageAttributeNames,
  toAttrName,
  getWorldAttrName,
  mkBrickColor,

  -- ** Common attributes
  entityAttr,
  robotAttr,

  -- ** Swarm TUI Attributes
  highlightAttr,
  notifAttr,
  infoAttr,
  boldAttr,
  italicAttr,
  dimAttr,
  magentaAttr,
  cyanAttr,
  lightCyanAttr,
  yellowAttr,
  beigeAttr,
  blueAttr,
  greenAttr,
  redAttr,
  grayAttr,
  defAttr,
  customEditFocusedAttr,
) where

import Brick
import Brick.Forms (focusedFormInputAttr, invalidFormInputAttr)
import Brick.Widgets.Dialog
import Brick.Widgets.Edit qualified as E
import Brick.Widgets.List (listSelectedFocusedAttr)
import Control.Arrow ((***))
import Data.Colour.Palette.BrewerSet
import Data.Colour.SRGB (RGB (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Text (unpack)
import Graphics.Vty qualified as V
import Swarm.Game.Display (Attribute (..))
import Swarm.Game.Entity.Cosmetic
import Swarm.Game.Entity.Cosmetic.Assignment
import Swarm.TUI.View.Attribute.Util

toAttrName :: Attribute -> AttrName
toAttrName :: Attribute -> AttrName
toAttrName = \case
  Attribute
ARobot -> AttrName
robotAttr
  Attribute
AEntity -> AttrName
entityAttr
  AWorld Text
n -> AttrName
worldPrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName (Text -> String
unpack Text
n)
  Attribute
ADefault -> AttrName
defAttr

toVtyAttr :: PreservableColor -> V.Attr
toVtyAttr :: PreservableColor -> Attr
toVtyAttr PreservableColor
hifi = case (TrueColor -> Color) -> PreservableColor -> ColorLayers Color
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TrueColor -> Color
mkBrickColor PreservableColor
hifi of
  FgOnly Color
c -> Color -> Attr
fg Color
c
  BgOnly Color
c -> Color -> Attr
bg Color
c
  FgAndBg Color
foreground Color
background -> Color
foreground Color -> Color -> Attr
`on` Color
background

mkBrickColor :: TrueColor -> V.Color
mkBrickColor :: TrueColor -> Color
mkBrickColor = \case
  Triple (RGB Word8
r Word8
g Word8
b) -> Word8 -> Word8 -> Word8 -> Color
forall i. Integral i => i -> i -> i -> Color
V.linearColor Word8
r Word8
g Word8
b
  AnsiColor NamedColor
x -> case NamedColor
x of
    NamedColor
White -> Color
V.white
    NamedColor
BrightRed -> Color
V.brightRed
    NamedColor
Red -> Color
V.red
    NamedColor
Green -> Color
V.green
    NamedColor
Blue -> Color
V.blue
    NamedColor
BrightYellow -> Color
V.brightYellow
    NamedColor
Yellow -> Color
V.yellow

-- | A mapping from the defined attribute names to TUI attributes.
swarmAttrMap :: AttrMap
swarmAttrMap :: AttrMap
swarmAttrMap =
  Attr -> [(AttrName, Attr)] -> AttrMap
attrMap
    Attr
V.defAttr
    ([(AttrName, Attr)] -> AttrMap) -> [(AttrName, Attr)] -> AttrMap
forall a b. (a -> b) -> a -> b
$ NonEmpty (AttrName, Attr) -> [(AttrName, Attr)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (AttrName, Attr)
activityMeterAttributes
      [(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. Semigroup a => a -> a -> a
<> NonEmpty (AttrName, Attr) -> [(AttrName, Attr)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (AttrName, Attr)
robotMessageAttributes
      [(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. Semigroup a => a -> a -> a
<> ((WorldAttr, PreservableColor) -> (AttrName, Attr))
-> [(WorldAttr, PreservableColor)] -> [(AttrName, Attr)]
forall a b. (a -> b) -> [a] -> [b]
map (WorldAttr -> AttrName
getWorldAttrName (WorldAttr -> AttrName)
-> (PreservableColor -> Attr)
-> (WorldAttr, PreservableColor)
-> (AttrName, Attr)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** PreservableColor -> Attr
toVtyAttr) (Map WorldAttr PreservableColor -> [(WorldAttr, PreservableColor)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorldAttr PreservableColor
worldAttributes)
      [(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. Semigroup a => a -> a -> a
<> [ -- Robot attribute
           (AttrName
robotAttr, Color -> Attr
fg Color
V.white Attr -> Word8 -> Attr
`V.withStyle` Word8
V.bold)
         , -- UI rendering attributes
           (AttrName
highlightAttr, Color -> Attr
fg Color
V.cyan)
         , (AttrName
invalidFormInputAttr, Color -> Attr
fg Color
V.red)
         , (AttrName
focusedFormInputAttr, Attr
V.defAttr)
         , (AttrName
customEditFocusedAttr, Color
V.black Color -> Color -> Attr
`on` Color
V.yellow)
         , (AttrName
listSelectedFocusedAttr, Color -> Attr
bg Color
V.blue)
         , (AttrName
infoAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
100 Int
100 Int
100))
         , (AttrName
buttonSelectedAttr, Color -> Attr
bg Color
V.blue)
         , (AttrName
notifAttr, Color -> Attr
fg Color
V.yellow Attr -> Word8 -> Attr
`V.withStyle` Word8
V.bold)
         , (AttrName
dimAttr, Attr
V.defAttr Attr -> Word8 -> Attr
`V.withStyle` Word8
V.dim)
         , (AttrName
boldAttr, Attr
V.defAttr Attr -> Word8 -> Attr
`V.withStyle` Word8
V.bold)
         , (AttrName
italicAttr, Attr
V.defAttr Attr -> Word8 -> Attr
`V.withStyle` Word8
V.italic)
         , -- Basic colors
           (AttrName
redAttr, Color -> Attr
fg Color
V.red)
         , (AttrName
greenAttr, Color -> Attr
fg Color
V.green)
         , (AttrName
blueAttr, Color -> Attr
fg Color
V.blue)
         , (AttrName
yellowAttr, Color -> Attr
fg Color
V.yellow)
         , (AttrName
beigeAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
238 Int
217 Int
196))
         , (AttrName
cyanAttr, Color -> Attr
fg Color
V.cyan)
         , (AttrName
lightCyanAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
200 Int
255 Int
255))
         , (AttrName
magentaAttr, Color -> Attr
fg Color
V.magenta)
         , (AttrName
grayAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
128 Int
128 Int
128))
         , -- Default attribute
           (AttrName
defAttr, Attr
V.defAttr)
         ]

worldPrefix :: AttrName
worldPrefix :: AttrName
worldPrefix = String -> AttrName
attrName String
"world"

getWorldAttrName :: WorldAttr -> AttrName
getWorldAttrName :: WorldAttr -> AttrName
getWorldAttrName (WorldAttr String
n) = AttrName
worldPrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
n

entityAttr :: AttrName
entityAttr :: AttrName
entityAttr = WorldAttr -> AttrName
getWorldAttrName (WorldAttr -> AttrName) -> WorldAttr -> AttrName
forall a b. (a -> b) -> a -> b
$ (WorldAttr, PreservableColor) -> WorldAttr
forall a b. (a, b) -> a
fst (WorldAttr, PreservableColor)
entity

robotMessagePrefix :: AttrName
robotMessagePrefix :: AttrName
robotMessagePrefix = String -> AttrName
attrName String
"robotMessage"

robotMessageAttributes :: NonEmpty (AttrName, V.Attr)
robotMessageAttributes :: NonEmpty (AttrName, Attr)
robotMessageAttributes =
  NonEmpty AttrName -> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty AttrName
indices (NonEmpty Attr -> NonEmpty (AttrName, Attr))
-> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. (a -> b) -> a -> b
$ NonEmpty Attr -> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a. a -> Maybe a -> a
fromMaybe (Attr -> NonEmpty Attr
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> NonEmpty Attr) -> Attr -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ Color -> Attr
fg Color
V.white) (Maybe (NonEmpty Attr) -> NonEmpty Attr)
-> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ [Attr] -> Maybe (NonEmpty Attr)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Attr]
brewers
 where
  indices :: NonEmpty AttrName
indices = (Int -> AttrName) -> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((AttrName
robotMessagePrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<>) (AttrName -> AttrName) -> (Int -> AttrName) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AttrName
attrName (String -> AttrName) -> (Int -> String) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) (NonEmpty Int -> NonEmpty AttrName)
-> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> a -> b
$ (Int
0 :: Int) Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 ..]
  brewers :: [Attr]
brewers = (Kolor -> Attr) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (Color -> Attr
fg (Color -> Attr) -> (Kolor -> Color) -> Kolor -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kolor -> Color
kolorToAttrColor) ([Kolor] -> [Attr]) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> a -> b
$ ColorCat -> Int -> [Kolor]
brewerSet ColorCat
Set3 Int
12

messageAttributeNames :: NonEmpty AttrName
messageAttributeNames :: NonEmpty AttrName
messageAttributeNames = ((AttrName, Attr) -> AttrName)
-> NonEmpty (AttrName, Attr) -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (AttrName, Attr) -> AttrName
forall a b. (a, b) -> a
fst NonEmpty (AttrName, Attr)
robotMessageAttributes

activityMeterPrefix :: AttrName
activityMeterPrefix :: AttrName
activityMeterPrefix = String -> AttrName
attrName String
"activityMeter"

activityMeterAttributes :: NonEmpty (AttrName, V.Attr)
activityMeterAttributes :: NonEmpty (AttrName, Attr)
activityMeterAttributes =
  NonEmpty AttrName -> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty AttrName
indices (NonEmpty Attr -> NonEmpty (AttrName, Attr))
-> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. (a -> b) -> a -> b
$ NonEmpty Attr -> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a. a -> Maybe a -> a
fromMaybe (Attr -> NonEmpty Attr
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> NonEmpty Attr) -> Attr -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ Color -> Attr
bg Color
V.black) (Maybe (NonEmpty Attr) -> NonEmpty Attr)
-> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ [Attr] -> Maybe (NonEmpty Attr)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Attr]
brewers
 where
  indices :: NonEmpty AttrName
indices = (Int -> AttrName) -> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((AttrName
activityMeterPrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<>) (AttrName -> AttrName) -> (Int -> AttrName) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AttrName
attrName (String -> AttrName) -> (Int -> String) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) (NonEmpty Int -> NonEmpty AttrName)
-> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> a -> b
$ (Int
0 :: Int) Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 ..]
  brewers :: [Attr]
brewers = (Kolor -> Attr) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map Kolor -> Attr
bgWithAutoForeground ([Kolor] -> [Attr]) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> a -> b
$ [Kolor] -> [Kolor]
forall a. [a] -> [a]
reverse ([Kolor] -> [Kolor]) -> [Kolor] -> [Kolor]
forall a b. (a -> b) -> a -> b
$ ColorCat -> Int -> [Kolor]
brewerSet ColorCat
RdYlGn Int
7

meterAttributeNames :: NonEmpty AttrName
meterAttributeNames :: NonEmpty AttrName
meterAttributeNames = ((AttrName, Attr) -> AttrName)
-> NonEmpty (AttrName, Attr) -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (AttrName, Attr) -> AttrName
forall a b. (a, b) -> a
fst NonEmpty (AttrName, Attr)
activityMeterAttributes

-- | The default robot attribute.
robotAttr :: AttrName
robotAttr :: AttrName
robotAttr = String -> AttrName
attrName String
"robot"

-- | Some defined attribute names used in the Swarm TUI.
highlightAttr
  , notifAttr
  , infoAttr
  , boldAttr
  , italicAttr
  , dimAttr
  , defAttr ::
    AttrName
highlightAttr :: AttrName
highlightAttr = String -> AttrName
attrName String
"highlight"
notifAttr :: AttrName
notifAttr = String -> AttrName
attrName String
"notif"
infoAttr :: AttrName
infoAttr = String -> AttrName
attrName String
"info"
boldAttr :: AttrName
boldAttr = String -> AttrName
attrName String
"bold"
italicAttr :: AttrName
italicAttr = String -> AttrName
attrName String
"italics"
dimAttr :: AttrName
dimAttr = String -> AttrName
attrName String
"dim"
defAttr :: AttrName
defAttr = String -> AttrName
attrName String
"def"

customEditFocusedAttr :: AttrName
customEditFocusedAttr :: AttrName
customEditFocusedAttr = String -> AttrName
attrName String
"custom" AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> AttrName
E.editFocusedAttr

-- | Some basic colors used in TUI.
redAttr, greenAttr, blueAttr, yellowAttr, beigeAttr, cyanAttr, lightCyanAttr, magentaAttr, grayAttr :: AttrName
redAttr :: AttrName
redAttr = String -> AttrName
attrName String
"red"
greenAttr :: AttrName
greenAttr = String -> AttrName
attrName String
"green"
blueAttr :: AttrName
blueAttr = String -> AttrName
attrName String
"blue"
yellowAttr :: AttrName
yellowAttr = String -> AttrName
attrName String
"yellow"
beigeAttr :: AttrName
beigeAttr = String -> AttrName
attrName String
"beige"
cyanAttr :: AttrName
cyanAttr = String -> AttrName
attrName String
"cyan"
lightCyanAttr :: AttrName
lightCyanAttr = String -> AttrName
attrName String
"lightCyan"
magentaAttr :: AttrName
magentaAttr = String -> AttrName
attrName String
"magenta"
grayAttr :: AttrName
grayAttr = String -> AttrName
attrName String
"gray"