{-# LANGUAGE RankNTypes, TypeFamilies #-}
module Game.LambdaHack.Client.UI.Frame
( FrameST, FrameForall(..), FrameBase(..), Frame, PreFrame, PreFrames
, SingleFrame(..)
, blankSingleFrame, overlayFrame, overlayFrameWithLines
#ifdef EXPOSE_INTERNAL
, 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 ()
newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s}
newtype FrameBase = FrameBase
{unFrameBase :: forall s. ST s (G.Mutable U.Vector s Word32)}
type Frame = (FrameBase, FrameForall)
type PreFrame = (U.Vector Word32, FrameForall)
type PreFrames = [Maybe PreFrame]
writeLine :: Int -> AttrLine -> FrameForall
{-# INLINE writeLine #-}
writeLine offset l = FrameForall $ \v -> do
let writeAt _ [] = return ()
writeAt off (ac32 : rest) = do
VM.write v off (Color.attrCharW32 ac32)
writeAt (off + 1) rest
writeAt offset l
newtype SingleFrame = SingleFrame
{singleFrame :: PointArray.Array Color.AttrCharW32}
deriving (Eq, Show)
blankSingleFrame :: ScreenContent -> SingleFrame
blankSingleFrame ScreenContent{rwidth, rheight} =
SingleFrame $ PointArray.replicateA rwidth rheight Color.spaceAttrW32
truncateLines :: ScreenContent -> Bool -> Overlay -> Overlay
truncateLines ScreenContent{rwidth, rheight} onBlank l =
let canvasLength = if onBlank then rheight else rheight - 2
topLayer = if length l <= canvasLength
then l ++ [[] | length l < canvasLength && length l > 3]
else take (canvasLength - 1) l
++ [stringToAL "--a portion of the text trimmed--"]
f lenPrev lenNext layerLine =
truncateAttrLine rwidth layerLine (max lenPrev lenNext)
lens = map (min (rwidth - 1) . length) topLayer
in zipWith3 f (0 : lens) (drop 1 lens ++ [0]) topLayer
truncateAttrLine :: X -> AttrLine -> X -> AttrLine
truncateAttrLine w xs lenMax =
case compare w (length xs) of
LT -> let discarded = drop w xs
in if all (== Color.spaceAttrW32) discarded
then take w xs
else take (w - 1) xs ++ [Color.attrChar2ToW32 Color.BrBlack '$']
EQ -> xs
GT -> let xsSpace =
if | null xs -> xs
| last xs == Color.spaceAttrW32 -> xs ++ [Color.spaceAttrW32]
| otherwise -> xs ++ [Color.spaceAttrW32, Color.spaceAttrW32]
whiteN = max (40 - length xsSpace) (1 + lenMax - length xsSpace)
in xsSpace ++ replicate whiteN Color.spaceAttrW32
overlayFrame :: IntOverlay -> PreFrame -> PreFrame
overlayFrame ov (m, ff) = (m, FrameForall $ \v -> do
unFrameForall ff v
mapM_ (\(offset, l) -> unFrameForall (writeLine offset l) v) ov)
overlayFrameWithLines :: ScreenContent -> Bool -> Overlay -> PreFrame
-> PreFrame
overlayFrameWithLines coscreen@ScreenContent{rwidth} onBlank l fr =
let ov = map (\(y, al) -> (y * rwidth, al))
$ zip [0..] $ truncateLines coscreen onBlank l
in overlayFrame ov fr