{-# LANGUAGE RankNTypes #-}
-- | Screen frames.
--
-- Note that @PointArray.Array@ here represents a screen frame and so
-- screen positions are denoted by @Point@, contrary to the convention
-- that @Point@ refers to game map coordinates, as outlined
-- in description of 'PointSquare' that should normally be used in that role.
module Game.LambdaHack.Client.UI.Frame
  ( ColorMode(..)
  , FrameST, FrameForall(..), FrameBase(..), Frame
  , PreFrame3, PreFrames3, PreFrame, PreFrames
  , SingleFrame(..), OverlaySpace
  , blankSingleFrame, truncateOverlay, overlayFrame
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , truncateAttrLine
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Monad.ST.Strict
import           Data.Function
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as VM
import           Data.Word

import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.Overlay
import           Game.LambdaHack.Client.UI.PointUI
import qualified Game.LambdaHack.Common.PointArray as PointArray
import qualified Game.LambdaHack.Definition.Color as Color

-- | Color mode for the display.
data ColorMode =
    ColorFull  -- ^ normal, with full colours
  | ColorBW    -- ^ black and white only
  deriving Eq

type FrameST s = G.Mutable U.Vector s Word32 -> ST s ()

-- | Efficiently composable representation of an operation
-- on a frame, that is, on a mutable vector. When the composite operation
-- is eventually performed, the vector is frozen to become a 'SingleFrame'.
newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s}

-- | Action that results in a base frame, to be modified further.
newtype FrameBase = FrameBase
  {unFrameBase :: forall s. ST s (G.Mutable U.Vector s Word32)}

-- | A frame, that is, a base frame and all its modifications.
type Frame = ( (FrameBase, FrameForall)
             , (OverlaySpace, OverlaySpace, OverlaySpace) )

-- | Components of a frame, before it's decided if the first can be overwritten
-- in-place or needs to be copied.
type PreFrame3 = (PreFrame, (OverlaySpace, OverlaySpace, OverlaySpace))

-- | Sequence of screen frames, including delays. Potentially based on a single
-- base frame.
type PreFrames3 = [Maybe PreFrame3]

-- | A simpler variant of @PreFrame3@.
type PreFrame = (U.Vector Word32, FrameForall)

-- | A simpler variant of @PreFrames3@.
type PreFrames = [Maybe PreFrame]

-- | Representation of an operation of overwriting a frame with a single line
-- at the given row.
writeLine :: Int -> AttrString -> FrameForall
{-# INLINE writeLine #-}
writeLine offset al = FrameForall $ \v -> do
  let writeAt _ [] = return ()
      writeAt off (ac32 : rest) = do
        VM.write v off (Color.attrCharW32 ac32)
        writeAt (off + 1) rest
  writeAt offset al

-- | A frame that is padded to fill the whole screen with optional
-- overlays to display in proportional, square and monospace fonts.
--
-- Note that we don't provide a list of color-highlighed box positions
-- to be drawn separately, because overlays need to obscure not only map,
-- but the highlights as well, so highlights need to be included earlier.
--
-- See the description of 'PointSquare' for explanation of why screen
-- coordinates in @singleArray@ are @Point@ even though they should be
-- 'PointSquare'.
data SingleFrame = SingleFrame
  { singleArray         :: PointArray.Array Color.AttrCharW32
  , singlePropOverlay   :: OverlaySpace
  , singleSquareOverlay :: OverlaySpace
  , singleMonoOverlay   :: OverlaySpace }
  deriving (Show, Eq)

type OverlaySpace = [(PointUI, AttrString)]

blankSingleFrame :: ScreenContent -> SingleFrame
blankSingleFrame ScreenContent{rwidth, rheight} =
  SingleFrame (PointArray.replicateA rwidth rheight Color.spaceAttrW32)
              []
              []
              []

-- | Truncate the overlay: for each line, if it's too long, it's truncated
-- and if there are too many lines, excess is dropped and warning is appended.
-- The width, in the second argument, is calculated in characters,
-- not in UI (mono font) coordinates, so that taking and dropping characters
-- is performed correctly.
truncateOverlay :: Bool -> Int -> Int -> Bool -> Int -> Bool -> Overlay
                -> OverlaySpace
truncateOverlay halveXstart width rheight wipeAdjacentRaw fillLen onBlank ov =
  let wipeAdjacent = wipeAdjacentRaw && not onBlank
      canvasLength = if onBlank then rheight else rheight - 2
      supHeight = maxYofOverlay ov
      trimmedY = canvasLength - 1
      -- Sadly, this does not trim the other, concurrent, overlays that may
      -- obscure the last line and so contend with the "trimmed" message.
      -- Tough luck; just avoid overrunning overlays in higher level code.
      ovTopFiltered = filter (\(PointUI _ y, _) -> y < trimmedY) ov
      trimmedAlert = ( PointUI 0 trimmedY
                     , stringToAL "--a portion of the text trimmed--" )
      extraLine | supHeight < 3
                  || supHeight >= trimmedY
                  || not wipeAdjacent = []
                | otherwise =
        let supHs = filter (\(PointUI _ y, _) -> y == supHeight) ov
        in if null supHs
           then []
           else let (PointUI xLast yLast, _) =
                      minimumBy (comparing $ \(PointUI x _, _) -> x) supHs
                in [(PointUI xLast (yLast + 1), emptyAttrLine)]
      -- This is crude, because an al at lower x may be longer, but KISS.
      -- This also gives a solid rule which al overwrite others
      -- when merging overlays, independent of the order of merging
      -- (except for duplicate x, for which initial order is retained).
      -- The order functions is cheap, we use @sortBy@, not @sortOn@.
      ovTop = groupBy ((==) `on` \(PointUI _ y, _) -> y)
              $ sortBy (comparing $ \(PointUI x y, _) -> (y, x))
              $ if supHeight >= canvasLength
                then ovTopFiltered ++ [trimmedAlert]
                else ov ++ extraLine
      -- Unlike the trimming above, adding spaces around overlay depends
      -- on there being no gaps and a natural order.
      -- Probably also gives messy results when X offsets are not all the same.
      -- Below we at least mitigate the case of multiple lines per row.
      f _ _ [] = error "empty list of overlay lines at the given row"
      f (yPrev, lenPrev) (yNext, lenNext) (minAl@(PointUI _ yCur, _) : rest) =
        g (if yPrev == yCur - 1 then lenPrev else 0)
          (if yNext == yCur + 1 then lenNext else 0)
          fillLen
          minAl
        : map (g 0 0 0) rest
      g lenPrev lenNext fillL (p@(PointUI xstartRaw _), layerLine) =
        let xstart = if halveXstart then xstartRaw `div` 2 else xstartRaw
            -- TODO: lenPrev and lenNext is from the same kind of font;
            -- if fonts are mixed, too few spaces are added.
            -- We'd need to keep a global store of line lengths
            -- for every position on the screen, filled first going
            -- over all texts and only afterwards texts rendered.
            -- And prop font measure would still make this imprecise.
            -- TODO: rewrite ovBackdrop according to this idea,
            -- but then process square font only mode with the same mechanism.
            maxLen = if wipeAdjacent then max lenPrev lenNext else 0
            fillFromStart = max fillL (1 + maxLen) - xstart
            available = width - xstart
        in (p, truncateAttrLine wipeAdjacent available fillFromStart layerLine)
      rightExtentOfLine (PointUI xstartRaw _, al) =
        let xstart = if halveXstart then xstartRaw `div` 2 else xstartRaw
        in min (width - 1) (xstart + length (attrLine al))
      yAndLen [] = (-99, 0)
      yAndLen als@((PointUI _ y, _) : _) =
        (y, maximum $ map rightExtentOfLine als)
      lens = map yAndLen ovTop
      f2 = map g2
      g2 (p@(PointUI xstartRaw _), layerLine) =
        let xstart = if halveXstart then xstartRaw `div` 2 else xstartRaw
            available = width - xstart
        in (p, truncateAttrLine False available 0 layerLine)
  in concat $ if onBlank
              then map f2 ovTop
              else zipWith3 f ((-9, 0) : lens) (drop 1 lens ++ [(999, 0)]) ovTop

-- | Add a space at the message end, for display overlayed over the level map.
-- Also trim (do not wrap!) too long lines. Also add many spaces when under
-- longer lines.
truncateAttrLine :: Bool -> Int -> Int -> AttrLine -> AttrString
truncateAttrLine addSpaces available fillFromStart aLine =
  let al = attrLine aLine
      len = length al
  in if | null al -> if addSpaces
                     then replicate fillFromStart Color.spaceAttrW32
                     else al
        | len == available - 1 && addSpaces -> al ++ [Color.spaceAttrW32]
        | otherwise -> case compare available len of
            LT -> take (available - 1) al ++ [Color.trimmedLineAttrW32]
            GT | addSpaces ->
              let alSpace = al ++ [Color.spaceAttrW32, Color.spaceAttrW32]
                  whiteN = fillFromStart - len - 2
              in if whiteN <= 0
                 then alSpace  -- speedup (supposedly) for menus
                 else alSpace ++ replicate whiteN Color.spaceAttrW32
            _ -> al

-- | Overlays either the game map only or the whole empty screen frame.
-- We assume the lines of the overlay are not too long nor too many.
overlayFrame :: Int -> OverlaySpace -> PreFrame -> PreFrame
overlayFrame width ov (m, ff) =
  ( m
  , FrameForall $ \v -> do
      unFrameForall ff v
      mapM_ (\(PointUI px py, l) ->
               let offset = py * width + px `div` 2
               in unFrameForall (writeLine offset l) v) ov )