content: {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
  -- | Colours and text attributes.
  module Game.LambdaHack.Definition.Color
    ( -- * Colours
      Color(..)
    , defFG, isBright, darkCol, brightCol, stdCol, legalFgCol
    , cVeryBadEvent, cBadEvent, cRisk, cGraveRisk, cVeryGoodEvent, cGoodEvent
    , cVista, cSleep, cWakeUp, cGreed, cNeutralEvent, cRareNeutralEvent
    , cIdentification, cMeta, cBoring, cGameOver, cTutorialHint
    , colorToRGB
      -- * Complete text attributes
    , Highlight (..), Attr(..)
    , highlightToColor, defAttr
      -- * Characters with attributes
    , AttrChar(..), AttrCharW32(..)
    , attrCharToW32, attrCharFromW32
    , fgFromW32, bgFromW32, charFromW32, attrFromW32
    , spaceAttrW32, nbspAttrW32, trimmedLineAttrW32
    , attrChar2ToW32, attrChar1ToW32
    ) where
  
  import Prelude ()
  
  import Game.LambdaHack.Core.Prelude
  
  import           Control.DeepSeq
  import           Data.Binary
  import           Data.Bits ((.&.))
  import qualified Data.Char as Char
  import           GHC.Generics (Generic)
  
  -- | Colours supported by the major frontends.
  data Color =
      Black
    | Red
    | Green
    | Brown
    | Blue
    | Magenta
    | Cyan
    | White
    | AltWhite  -- only use for frontend hacks
    | BrBlack
    | BrRed
    | BrGreen
    | BrYellow
    | BrBlue
    | BrMagenta
    | BrCyan
    | BrWhite
    deriving (Show, Read, Eq, Ord, Enum, Generic)
  
  instance Binary Color where
    put = putWord8 . toEnum . fromEnum
    get = fmap (toEnum . fromEnum) getWord8
  
  instance NFData Color
  
  -- | The default colours, to optimize attribute setting.
  defFG :: Color
  defFG = White
  
  -- | A helper for the terminal frontends that display bright via bold.
  isBright :: Color -> Bool
  isBright c = c > BrBlack
  
  -- | Colour sets. Sorted.
  darkCol, brightCol, stdCol, legalFgCol :: [Color]
  darkCol = [Red .. Cyan]
  brightCol = [BrRed .. BrCyan]  -- BrBlack is not really that bright
  stdCol = darkCol ++ brightCol
  legalFgCol = darkCol ++ [White, BrBlack] ++ brightCol ++ [BrWhite]
  
  -- See the discussion of colours and the table of colours at
  -- https://github.com/LambdaHack/LambdaHack/wiki/Display#colours
  -- Another mention of colours, concerning terrain, is in PLAYING.md manual.
  -- The manual and this code should follow the wiki.
  cVeryBadEvent, cBadEvent, cRisk, cGraveRisk, cVeryGoodEvent, cGoodEvent, cVista, cSleep, cWakeUp, cGreed, cNeutralEvent, cRareNeutralEvent, cIdentification, cMeta, cBoring, cGameOver, cTutorialHint :: Color
  cVeryBadEvent = Red
  cBadEvent = BrRed
  cRisk = Magenta
  cGraveRisk = BrMagenta
  cVeryGoodEvent = Green
  cGoodEvent = BrGreen
  cVista = BrGreen
  cSleep = Blue
  cWakeUp = BrBlue
  cGreed = BrBlue
  cNeutralEvent = Cyan
  cRareNeutralEvent = BrCyan
  cIdentification = Brown
  cMeta = BrYellow
  cBoring = White
  cGameOver = BrWhite
  cTutorialHint = BrMagenta
  
  -- | Translationg to heavily modified Linux console color RGB values.
  --
  -- Warning: SDL frontend sadly duplicates this code.
  colorToRGB :: Color -> Text
  colorToRGB Black     = "#000000"
  colorToRGB Red       = "#D50505"
  colorToRGB Green     = "#059D05"
  colorToRGB Brown     = "#CA4A05"
  colorToRGB Blue      = "#0556F4"
  colorToRGB Magenta   = "#AF0EAF"
  colorToRGB Cyan      = "#059696"
  colorToRGB White     = "#B8BFCB"
  colorToRGB AltWhite  = "#C4BEB1"
  colorToRGB BrBlack   = "#6F5F5F"
  colorToRGB BrRed     = "#FF5555"
  colorToRGB BrGreen   = "#65F136"
  colorToRGB BrYellow  = "#EBD642"
  colorToRGB BrBlue    = "#4D98F4"
  colorToRGB BrMagenta = "#FF77FF"
  colorToRGB BrCyan    = "#52F4E5"
  colorToRGB BrWhite   = "#FFFFFF"
  
  -- -- | For reference, the original Linux console colors.
  -- -- Good old retro feel and more useful than xterm (e.g. brown).
  -- colorToRGB :: Color -> Text
  -- colorToRGB Black     = "#000000"
  -- colorToRGB Red       = "#AA0000"
  -- colorToRGB Green     = "#00AA00"
  -- colorToRGB Brown     = "#AA5500"
  -- colorToRGB Blue      = "#0000AA"
  -- colorToRGB Magenta   = "#AA00AA"
  -- colorToRGB Cyan      = "#00AAAA"
  -- colorToRGB White     = "#AAAAAA"
  -- colorToRGB AltWhite  = "#AAAAAA"
  -- colorToRGB BrBlack   = "#555555"
  -- colorToRGB BrRed     = "#FF5555"
  -- colorToRGB BrGreen   = "#55FF55"
  -- colorToRGB BrYellow  = "#FFFF55"
  -- colorToRGB BrBlue    = "#5555FF"
  -- colorToRGB BrMagenta = "#FF55FF"
  -- colorToRGB BrCyan    = "#55FFFF"
  -- colorToRGB BrWhite   = "#FFFFFF"
  
  -- | Additional map cell highlight, e.g., a colorful square around the cell
  -- or a colorful background.
  --
  -- Warning: the highlight underscored by the terminal cursor is
  -- the maximal element of this type present on a screen,
  -- so don't add new highlights to the end.
  data Highlight =
      HighlightNone
    | HighlightBackground
    | HighlightGreen
    | HighlightBlue
    | HighlightBrown
    | HighlightCyan
    | HighlightGrey
    | HighlightWhite
    | HighlightMagenta
    | HighlightRed
    | HighlightYellow
    | HighlightYellowAim
    | HighlightRedAim
    | HighlightNoneCursor
    deriving (Show, Eq, Ord, Enum, Bounded)
  
  highlightToColor :: Highlight -> Color
  highlightToColor hi = case hi of
    HighlightNone -> Black  -- should be transparent, but is OK in web frontend
    HighlightBackground -> BrBlack  -- gets a special colour, but as a background
    HighlightGreen -> Green
    HighlightBlue -> Blue
    HighlightBrown -> Brown
    HighlightCyan -> Cyan
    HighlightGrey -> BrBlack
    HighlightWhite -> White  -- bright, but no saturation, so doesn't obscure much
    HighlightMagenta -> BrMagenta  -- very rare, so bright is fine
    HighlightRed -> Red
    HighlightYellow -> BrYellow  -- obscures, but mostly used around bright white
    HighlightYellowAim -> BrYellow
    HighlightRedAim -> Red
    HighlightNoneCursor -> Black  -- used in ANSI for cursor via @maxIndexByA@
  
  -- | Text attributes: foreground color and highlight.
  data Attr = Attr
    { fg :: Color      -- ^ foreground colour
    , bg :: Highlight  -- ^ highlight
    }
    deriving (Show, Eq)
  
  -- | The default attribute, to optimize attribute setting.
  defAttr :: Attr
  defAttr = Attr defFG HighlightNone
  
  -- | Character to display, with its attribute.
  data AttrChar = AttrChar
    { acAttr :: Attr
    , acChar :: Char
    }
    deriving (Show, Eq)
  
  -- This implementation is faster than @Int@, because some vector updates
  -- can be done without going to and from @Int@.
  -- | Optimized representation of 'AttrChar'.
  newtype AttrCharW32 = AttrCharW32 {attrCharW32 :: Word32}
    deriving (Show, Eq, Ord, Enum, Binary)
  
  attrCharToW32 :: AttrChar -> AttrCharW32
  attrCharToW32 AttrChar{acAttr=Attr{..}, acChar} = AttrCharW32 $ toEnum $
    unsafeShiftL (fromEnum fg) 8 + fromEnum bg + unsafeShiftL (Char.ord acChar) 16
  
  attrCharFromW32 :: AttrCharW32 -> AttrChar
  attrCharFromW32 !w = AttrChar (attrFromW32 w) (charFromW32 w)
  
  fgFromW32 :: AttrCharW32 -> Color
  {-# INLINE fgFromW32 #-}
  fgFromW32 w =
    toEnum $ unsafeShiftR (fromEnum $ attrCharW32 w) 8 .&. (2 ^ (8 :: Int) - 1)
  
  bgFromW32 :: AttrCharW32 -> Highlight
  {-# INLINE bgFromW32 #-}
  bgFromW32 w =
    toEnum $ fromEnum $ attrCharW32 w .&. (2 ^ (8 :: Int) - 1)
  
  charFromW32 :: AttrCharW32 -> Char
  {-# INLINE charFromW32 #-}
  charFromW32 w =
    Char.chr $ unsafeShiftR (fromEnum $ attrCharW32 w) 16
  
  attrFromW32 :: AttrCharW32 -> Attr
  {-# INLINE attrFromW32 #-}
  attrFromW32 w = Attr (fgFromW32 w) (bgFromW32 w)
  
  spaceAttrW32 :: AttrCharW32
  spaceAttrW32 = attrCharToW32 $ AttrChar defAttr ' '
  
  nbspAttrW32 :: AttrCharW32
  nbspAttrW32 = attrCharToW32 $ AttrChar defAttr '\x00a0'
  
  trimmedLineAttrW32 :: AttrCharW32
  trimmedLineAttrW32 = attrChar2ToW32 BrBlack '$'
  
  attrChar2ToW32 :: Color -> Char -> AttrCharW32
  {-# INLINE attrChar2ToW32 #-}
  attrChar2ToW32 fg =
    let fgNum = unsafeShiftL (fromEnum fg) 8
    in \acChar -> AttrCharW32 $ toEnum $ fgNum + unsafeShiftL (Char.ord acChar) 16
  --
  -- These hacks save one allocation (?) (before fits-in-32bits check) compared
  -- to the above, but they fail in GHC 9.2.0 and possibly don't do anything
  -- for JS, which is the only real bottleneck, so disabled:
  --
  --import GHC.Prim (int2Word#)
  --  case unsafeShiftL (fromEnum fg) 8 + unsafeShiftL (Char.ord acChar) 16 of
  --    I# i -> AttrCharW32 $ W32# (int2Word# i)
  
  attrChar1ToW32 :: Char -> AttrCharW32
  {-# INLINE attrChar1ToW32 #-}
  attrChar1ToW32 =
    let fgNum = unsafeShiftL (fromEnum White) 8
    in \acChar -> AttrCharW32 $ toEnum $ fgNum + unsafeShiftL (Char.ord acChar) 16
  --
  --    case fgNum + unsafeShiftL (Char.ord acChar) 16 of
  --      I# i -> AttrCharW32 $ W32# (int2Word# i)
  