{-# LANGUAGE RankNTypes, TypeFamilies #-}
-- | Screen frames.
module Game.LambdaHack.Client.UI.Frame
  ( FrameST, FrameForall(..), FrameBase(..), Frame, PreFrame, PreFrames
  , SingleFrame(..)
  , blankSingleFrame, overlayFrame, overlayFrameWithLines
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , truncateAttrLine
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Monad.ST.Strict
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 qualified Game.LambdaHack.Common.PointArray as PointArray
import qualified Game.LambdaHack.Definition.Color as Color
import           Game.LambdaHack.Definition.Defs

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 {FrameForall -> forall s. FrameST s
unFrameForall :: forall s. FrameST s}

-- | Action that results in a base frame, to be modified further.
newtype FrameBase = FrameBase
  {FrameBase -> forall s. ST s (Mutable Vector s Word32)
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)

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

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

-- | Representation of an operation of overwriting a frame with a single line
-- at the given row.
writeLine :: Int -> AttrLine -> FrameForall
{-# INLINE writeLine #-}
writeLine :: Int -> AttrLine -> FrameForall
writeLine offset :: Int
offset l :: AttrLine
l = (forall s. FrameST s) -> FrameForall
FrameForall ((forall s. FrameST s) -> FrameForall)
-> (forall s. FrameST s) -> FrameForall
forall a b. (a -> b) -> a -> b
$ \v :: Mutable Vector s Word32
v -> do
  let writeAt :: Int -> AttrLine -> ST s ()
writeAt _ [] = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      writeAt off :: Int
off (ac32 :: AttrCharW32
ac32 : rest :: AttrLine
rest) = do
        MVector (PrimState (ST s)) Word32 -> Int -> Word32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.write MVector (PrimState (ST s)) Word32
Mutable Vector s Word32
v Int
off (AttrCharW32 -> Word32
Color.attrCharW32 AttrCharW32
ac32)
        Int -> AttrLine -> ST s ()
writeAt (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) AttrLine
rest
  Int -> AttrLine -> ST s ()
writeAt Int
offset AttrLine
l

-- | An overlay that fits on the screen (or is meant to be truncated on display)
-- and is padded to fill the whole screen
-- and is displayed as a single game screen frame.
--
-- Note that we don't provide a list of color-highlighed positions separately,
-- because overlays need to obscure not only map, but the highlights as well.
newtype SingleFrame = SingleFrame
  {SingleFrame -> Array AttrCharW32
singleFrame :: PointArray.Array Color.AttrCharW32}
  deriving (SingleFrame -> SingleFrame -> Bool
(SingleFrame -> SingleFrame -> Bool)
-> (SingleFrame -> SingleFrame -> Bool) -> Eq SingleFrame
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SingleFrame -> SingleFrame -> Bool
$c/= :: SingleFrame -> SingleFrame -> Bool
== :: SingleFrame -> SingleFrame -> Bool
$c== :: SingleFrame -> SingleFrame -> Bool
Eq, Int -> SingleFrame -> ShowS
[SingleFrame] -> ShowS
SingleFrame -> String
(Int -> SingleFrame -> ShowS)
-> (SingleFrame -> String)
-> ([SingleFrame] -> ShowS)
-> Show SingleFrame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SingleFrame] -> ShowS
$cshowList :: [SingleFrame] -> ShowS
show :: SingleFrame -> String
$cshow :: SingleFrame -> String
showsPrec :: Int -> SingleFrame -> ShowS
$cshowsPrec :: Int -> SingleFrame -> ShowS
Show)

blankSingleFrame :: ScreenContent -> SingleFrame
blankSingleFrame :: ScreenContent -> SingleFrame
blankSingleFrame ScreenContent{Int
rwidth :: ScreenContent -> Int
rwidth :: Int
rwidth, Int
rheight :: ScreenContent -> Int
rheight :: Int
rheight} =
  Array AttrCharW32 -> SingleFrame
SingleFrame (Array AttrCharW32 -> SingleFrame)
-> Array AttrCharW32 -> SingleFrame
forall a b. (a -> b) -> a -> b
$ Int -> Int -> AttrCharW32 -> Array AttrCharW32
forall c. UnboxRepClass c => Int -> Int -> c -> Array c
PointArray.replicateA Int
rwidth Int
rheight AttrCharW32
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.
truncateLines :: ScreenContent -> Bool -> Overlay -> Overlay
truncateLines :: ScreenContent -> Bool -> Overlay -> Overlay
truncateLines ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight} onBlank :: Bool
onBlank l :: Overlay
l =
  let canvasLength :: Int
canvasLength = if Bool
onBlank then Int
rheight else Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
      topLayer :: Overlay
topLayer = if Overlay -> Int
forall a. [a] -> Int
length Overlay
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
canvasLength
                 then Overlay
l Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ [[] | Overlay -> Int
forall a. [a] -> Int
length Overlay
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
canvasLength Bool -> Bool -> Bool
&& Overlay -> Int
forall a. [a] -> Int
length Overlay
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 3]
                 else Int -> Overlay -> Overlay
forall a. Int -> [a] -> [a]
take (Int
canvasLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Overlay
l
                      Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ [String -> AttrLine
stringToAL "--a portion of the text trimmed--"]
      f :: Int -> Int -> AttrLine -> AttrLine
f lenPrev :: Int
lenPrev lenNext :: Int
lenNext layerLine :: AttrLine
layerLine =
        Int -> AttrLine -> Int -> AttrLine
truncateAttrLine Int
rwidth AttrLine
layerLine (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
lenPrev Int
lenNext)
      lens :: [Int]
lens = (AttrLine -> Int) -> Overlay -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> Int) -> (AttrLine -> Int) -> AttrLine -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrLine -> Int
forall a. [a] -> Int
length) Overlay
topLayer
  in (Int -> Int -> AttrLine -> AttrLine)
-> [Int] -> [Int] -> Overlay -> Overlay
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Int -> AttrLine -> AttrLine
f (0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
lens) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop 1 [Int]
lens [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [0]) Overlay
topLayer

-- | Add a space at the message end, for display overlayed over the level map.
-- Also trim (do not wrap!) too long lines.
truncateAttrLine :: X -> AttrLine -> X -> AttrLine
truncateAttrLine :: Int -> AttrLine -> Int -> AttrLine
truncateAttrLine w :: Int
w xs :: AttrLine
xs lenMax :: Int
lenMax =
  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
w (AttrLine -> Int
forall a. [a] -> Int
length AttrLine
xs) of
    LT -> let discarded :: AttrLine
discarded = Int -> AttrLine -> AttrLine
forall a. Int -> [a] -> [a]
drop Int
w AttrLine
xs
          in if (AttrCharW32 -> Bool) -> AttrLine -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrLine
discarded
             then Int -> AttrLine -> AttrLine
forall a. Int -> [a] -> [a]
take Int
w AttrLine
xs
             else Int -> AttrLine -> AttrLine
forall a. Int -> [a] -> [a]
take (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) AttrLine
xs AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ [Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
Color.BrBlack '$']
    EQ -> AttrLine
xs
    GT -> let xsSpace :: AttrLine
xsSpace =
                if | AttrLine -> Bool
forall a. [a] -> Bool
null AttrLine
xs -> AttrLine
xs
                   | AttrLine -> AttrCharW32
forall a. [a] -> a
last AttrLine
xs AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32 -> AttrLine
xs AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.spaceAttrW32]
                   | Bool
otherwise -> AttrLine
xs AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.spaceAttrW32, AttrCharW32
Color.spaceAttrW32]
              whiteN :: Int
whiteN = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (40 Int -> Int -> Int
forall a. Num a => a -> a -> a
- AttrLine -> Int
forall a. [a] -> Int
length AttrLine
xsSpace) (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lenMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- AttrLine -> Int
forall a. [a] -> Int
length AttrLine
xsSpace)
          in AttrLine
xsSpace AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ Int -> AttrCharW32 -> AttrLine
forall a. Int -> a -> [a]
replicate Int
whiteN AttrCharW32
Color.spaceAttrW32

-- | 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 :: IntOverlay -> PreFrame -> PreFrame
overlayFrame :: IntOverlay -> PreFrame -> PreFrame
overlayFrame ov :: IntOverlay
ov (m :: Vector Word32
m, ff :: FrameForall
ff) = (Vector Word32
m, (forall s. FrameST s) -> FrameForall
FrameForall ((forall s. FrameST s) -> FrameForall)
-> (forall s. FrameST s) -> FrameForall
forall a b. (a -> b) -> a -> b
$ \v :: Mutable Vector s Word32
v -> do
  FrameForall -> FrameST s
FrameForall -> forall s. FrameST s
unFrameForall FrameForall
ff Mutable Vector s Word32
v
  ((Int, AttrLine) -> ST s ()) -> IntOverlay -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(offset :: Int
offset, l :: AttrLine
l) -> FrameForall -> FrameST s
FrameForall -> forall s. FrameST s
unFrameForall (Int -> AttrLine -> FrameForall
writeLine Int
offset AttrLine
l) Mutable Vector s Word32
v) IntOverlay
ov)

overlayFrameWithLines :: ScreenContent -> Bool -> Overlay -> PreFrame
                      -> PreFrame
overlayFrameWithLines :: ScreenContent -> Bool -> Overlay -> PreFrame -> PreFrame
overlayFrameWithLines coscreen :: ScreenContent
coscreen@ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth} onBlank :: Bool
onBlank l :: Overlay
l fr :: PreFrame
fr =
  let ov :: IntOverlay
ov = ((Int, AttrLine) -> (Int, AttrLine)) -> IntOverlay -> IntOverlay
forall a b. (a -> b) -> [a] -> [b]
map (\(y :: Int
y, al :: AttrLine
al) -> (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rwidth, AttrLine
al))
           (IntOverlay -> IntOverlay) -> IntOverlay -> IntOverlay
forall a b. (a -> b) -> a -> b
$ [Int] -> Overlay -> IntOverlay
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] (Overlay -> IntOverlay) -> Overlay -> IntOverlay
forall a b. (a -> b) -> a -> b
$ ScreenContent -> Bool -> Overlay -> Overlay
truncateLines ScreenContent
coscreen Bool
onBlank Overlay
l
  in IntOverlay -> PreFrame -> PreFrame
overlayFrame IntOverlay
ov PreFrame
fr