{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Client.UI.Frame
( ColorMode(..)
, FrameST, FrameForall(..), FrameBase(..), Frame
, PreFrame3, PreFrames3, PreFrame, PreFrames
, SingleFrame(..), OverlaySpace
, blankSingleFrame, truncateOverlay, overlayFrame
#ifdef EXPOSE_INTERNAL
, truncateAttrLine
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Monad.ST.Strict
import qualified Data.IntMap.Strict as IM
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
data ColorMode =
ColorFull
| ColorBW
deriving ColorMode -> ColorMode -> Bool
(ColorMode -> ColorMode -> Bool)
-> (ColorMode -> ColorMode -> Bool) -> Eq ColorMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorMode -> ColorMode -> Bool
$c/= :: ColorMode -> ColorMode -> Bool
== :: ColorMode -> ColorMode -> Bool
$c== :: ColorMode -> ColorMode -> Bool
Eq
type FrameST s = G.Mutable U.Vector s Word32 -> ST s ()
newtype FrameForall = FrameForall {FrameForall -> forall s. FrameST s
unFrameForall :: forall s. FrameST s}
newtype FrameBase = FrameBase
{FrameBase -> forall s. ST s (Mutable Vector s Word32)
unFrameBase :: forall s. ST s (G.Mutable U.Vector s Word32)}
type Frame = ((FrameBase, FrameForall), (OverlaySpace, OverlaySpace))
type PreFrame3 = (PreFrame, (OverlaySpace, OverlaySpace))
type PreFrames3 = [Maybe PreFrame3]
type PreFrame = (U.Vector Word32, FrameForall)
type PreFrames = [Maybe PreFrame]
writeLine :: Int -> AttrString -> FrameForall
{-# INLINE writeLine #-}
writeLine :: Int -> AttrString -> FrameForall
writeLine offset :: Int
offset al :: AttrString
al = (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 -> AttrString -> ST s ()
writeAt _ [] = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeAt off :: Int
off (ac32 :: AttrCharW32
ac32 : rest :: AttrString
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 -> AttrString -> ST s ()
writeAt (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) AttrString
rest
Int -> AttrString -> ST s ()
writeAt Int
offset AttrString
al
data SingleFrame = SingleFrame
{ SingleFrame -> Array AttrCharW32
singleArray :: PointArray.Array Color.AttrCharW32
, SingleFrame -> OverlaySpace
singlePropOverlay :: OverlaySpace
, SingleFrame -> OverlaySpace
singleMonoOverlay :: OverlaySpace }
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)
type OverlaySpace = [(PointUI, AttrString)]
blankSingleFrame :: ScreenContent -> SingleFrame
blankSingleFrame :: ScreenContent -> SingleFrame
blankSingleFrame ScreenContent{Int
rwidth :: ScreenContent -> Int
rwidth :: Int
rwidth, Int
rheight :: ScreenContent -> Int
rheight :: Int
rheight} =
Array AttrCharW32 -> OverlaySpace -> OverlaySpace -> SingleFrame
SingleFrame (Int -> Int -> AttrCharW32 -> Array AttrCharW32
forall c. UnboxRepClass c => Int -> Int -> c -> Array c
PointArray.replicateA Int
rwidth Int
rheight AttrCharW32
Color.spaceAttrW32)
[]
[]
truncateOverlay :: Bool -> Int -> Int -> Bool -> Int -> Bool -> Overlay
-> OverlaySpace
truncateOverlay :: Bool
-> Int -> Int -> Bool -> Int -> Bool -> Overlay -> OverlaySpace
truncateOverlay halveXstart :: Bool
halveXstart width :: Int
width rheight :: Int
rheight wipeAdjacentRaw :: Bool
wipeAdjacentRaw fillLen :: Int
fillLen onBlank :: Bool
onBlank ov :: Overlay
ov =
let wipeAdjacent :: Bool
wipeAdjacent = Bool
wipeAdjacentRaw Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
onBlank
canvasLength :: Int
canvasLength = if Bool
onBlank then Int
rheight else Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
supHeight :: Int
supHeight = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ 0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((PointUI, AttrLine) -> Int) -> Overlay -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(PointUI _ y :: Int
y, _) -> Int
y) Overlay
ov
trimmedY :: Int
trimmedY = Int
canvasLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
ovTopFiltered :: Overlay
ovTopFiltered = ((PointUI, AttrLine) -> Bool) -> Overlay -> Overlay
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PointUI _ y :: Int
y, _) -> Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
trimmedY) Overlay
ov
trimmedAlert :: (PointUI, AttrLine)
trimmedAlert = ( Int -> Int -> PointUI
PointUI 0 Int
trimmedY
, String -> AttrLine
stringToAL "--a portion of the text trimmed--" )
extraLine :: Overlay
extraLine | Int
supHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 3
Bool -> Bool -> Bool
|| Int
supHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
trimmedY
Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
wipeAdjacent = []
| Bool
otherwise =
let supHs :: Overlay
supHs = ((PointUI, AttrLine) -> Bool) -> Overlay -> Overlay
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PointUI _ y :: Int
y, _) -> Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
supHeight) Overlay
ov
in if Overlay -> Bool
forall a. [a] -> Bool
null Overlay
supHs
then []
else let (PointUI xLast :: Int
xLast yLast :: Int
yLast, _) =
((PointUI, AttrLine) -> (PointUI, AttrLine) -> Ordering)
-> Overlay -> (PointUI, AttrLine)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((PointUI, AttrLine) -> Int)
-> (PointUI, AttrLine) -> (PointUI, AttrLine) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((PointUI, AttrLine) -> Int)
-> (PointUI, AttrLine) -> (PointUI, AttrLine) -> Ordering)
-> ((PointUI, AttrLine) -> Int)
-> (PointUI, AttrLine)
-> (PointUI, AttrLine)
-> Ordering
forall a b. (a -> b) -> a -> b
$ \(PointUI x :: Int
x _, _) -> Int
x) Overlay
supHs
in [(Int -> Int -> PointUI
PointUI Int
xLast (Int
yLast Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1), AttrLine
emptyAttrLine)]
ovTop :: [Overlay]
ovTop = IntMap Overlay -> [Overlay]
forall a. IntMap a -> [a]
IM.elems (IntMap Overlay -> [Overlay]) -> IntMap Overlay -> [Overlay]
forall a b. (a -> b) -> a -> b
$ (Overlay -> Overlay -> Overlay)
-> [(Int, Overlay)] -> IntMap Overlay
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
(++)
([(Int, Overlay)] -> IntMap Overlay)
-> [(Int, Overlay)] -> IntMap Overlay
forall a b. (a -> b) -> a -> b
$ ((PointUI, AttrLine) -> (Int, Overlay))
-> Overlay -> [(Int, Overlay)]
forall a b. (a -> b) -> [a] -> [b]
map (\pal :: (PointUI, AttrLine)
pal@(PointUI _ y :: Int
y, _) -> (Int
y, [(PointUI, AttrLine)
pal]))
(Overlay -> [(Int, Overlay)]) -> Overlay -> [(Int, Overlay)]
forall a b. (a -> b) -> a -> b
$ if Int
supHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
canvasLength
then Overlay
ovTopFiltered Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ [(PointUI, AttrLine)
trimmedAlert]
else Overlay
ov Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ Overlay
extraLine
f :: Int -> Int -> Overlay -> OverlaySpace
f lenPrev :: Int
lenPrev lenNext :: Int
lenNext lal :: Overlay
lal =
let xlal :: [(Int, (PointUI, AttrLine))]
xlal = ((PointUI, AttrLine) -> (Int, (PointUI, AttrLine)))
-> Overlay -> [(Int, (PointUI, AttrLine))]
forall a b. (a -> b) -> [a] -> [b]
map (\pll :: (PointUI, AttrLine)
pll@(PointUI x :: Int
x _, _) -> (Int
x, (PointUI, AttrLine)
pll)) Overlay
lal
in case ((Int, (PointUI, AttrLine))
-> (Int, (PointUI, AttrLine)) -> Ordering)
-> [(Int, (PointUI, AttrLine))] -> [(Int, (PointUI, AttrLine))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, (PointUI, AttrLine)) -> Int)
-> (Int, (PointUI, AttrLine))
-> (Int, (PointUI, AttrLine))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, (PointUI, AttrLine)) -> Int
forall a b. (a, b) -> a
fst) [(Int, (PointUI, AttrLine))]
xlal of
[] -> String -> OverlaySpace
forall a. HasCallStack => String -> a
error "empty list of overlay lines at the given row"
minAl :: (Int, (PointUI, AttrLine))
minAl : rest :: [(Int, (PointUI, AttrLine))]
rest ->
Int
-> Int
-> Int
-> (Int, (PointUI, AttrLine))
-> (PointUI, AttrString)
g Int
lenPrev Int
lenNext Int
fillLen (Int, (PointUI, AttrLine))
minAl
(PointUI, AttrString) -> OverlaySpace -> OverlaySpace
forall a. a -> [a] -> [a]
: ((Int, (PointUI, AttrLine)) -> (PointUI, AttrString))
-> [(Int, (PointUI, AttrLine))] -> OverlaySpace
forall a b. (a -> b) -> [a] -> [b]
map (Int
-> Int
-> Int
-> (Int, (PointUI, AttrLine))
-> (PointUI, AttrString)
g 0 0 0) [(Int, (PointUI, AttrLine))]
rest
g :: Int
-> Int
-> Int
-> (Int, (PointUI, AttrLine))
-> (PointUI, AttrString)
g lenPrev :: Int
lenPrev lenNext :: Int
lenNext fillL :: Int
fillL (xstartRaw :: Int
xstartRaw, (p :: PointUI
p, layerLine :: AttrLine
layerLine)) =
let xstart :: Int
xstart = if Bool
halveXstart then Int
xstartRaw Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 else Int
xstartRaw
maxLen :: Int
maxLen = if Bool
wipeAdjacent then Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
lenPrev Int
lenNext else 0
fillFromStart :: Int
fillFromStart = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
fillL (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxLen) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart
available :: Int
available = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart
in (PointUI
p, Bool -> Int -> Int -> AttrLine -> AttrString
truncateAttrLine Bool
wipeAdjacent Int
available Int
fillFromStart AttrLine
layerLine)
rightExtentOfLine :: (PointUI, AttrLine) -> Int
rightExtentOfLine (PointUI xstartRaw :: Int
xstartRaw _, al :: AttrLine
al) =
let xstart :: Int
xstart = if Bool
halveXstart then Int
xstartRaw Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 else Int
xstartRaw
in Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int
xstart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ AttrString -> Int
forall a. [a] -> Int
length (AttrLine -> AttrString
attrLine AttrLine
al))
lens :: [Int]
lens = (Overlay -> Int) -> [Overlay] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> (Overlay -> [Int]) -> Overlay -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PointUI, AttrLine) -> Int) -> Overlay -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (PointUI, AttrLine) -> Int
rightExtentOfLine) [Overlay]
ovTop
f2 :: Overlay -> OverlaySpace
f2 = ((PointUI, AttrLine) -> (PointUI, AttrString))
-> Overlay -> OverlaySpace
forall a b. (a -> b) -> [a] -> [b]
map (PointUI, AttrLine) -> (PointUI, AttrString)
g2
g2 :: (PointUI, AttrLine) -> (PointUI, AttrString)
g2 (p :: PointUI
p@(PointUI xstartRaw :: Int
xstartRaw _), layerLine :: AttrLine
layerLine) =
let xstart :: Int
xstart = if Bool
halveXstart then Int
xstartRaw Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 else Int
xstartRaw
available :: Int
available = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart
in (PointUI
p, Bool -> Int -> Int -> AttrLine -> AttrString
truncateAttrLine Bool
False Int
available 0 AttrLine
layerLine)
in [OverlaySpace] -> OverlaySpace
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([OverlaySpace] -> OverlaySpace) -> [OverlaySpace] -> OverlaySpace
forall a b. (a -> b) -> a -> b
$ if Bool
onBlank
then (Overlay -> OverlaySpace) -> [Overlay] -> [OverlaySpace]
forall a b. (a -> b) -> [a] -> [b]
map Overlay -> OverlaySpace
f2 [Overlay]
ovTop
else (Int -> Int -> Overlay -> OverlaySpace)
-> [Int] -> [Int] -> [Overlay] -> [OverlaySpace]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Int -> Overlay -> OverlaySpace
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]
ovTop
truncateAttrLine :: Bool -> Int -> Int -> AttrLine -> AttrString
truncateAttrLine :: Bool -> Int -> Int -> AttrLine -> AttrString
truncateAttrLine addSpaces :: Bool
addSpaces available :: Int
available fillFromStart :: Int
fillFromStart aLine :: AttrLine
aLine =
let al :: AttrString
al = AttrLine -> AttrString
attrLine AttrLine
aLine
len :: Int
len = AttrString -> Int
forall a. [a] -> Int
length AttrString
al
in if | AttrString -> Bool
forall a. [a] -> Bool
null AttrString
al -> if Bool
addSpaces
then Int -> AttrCharW32 -> AttrString
forall a. Int -> a -> [a]
replicate Int
fillFromStart AttrCharW32
Color.spaceAttrW32
else AttrString
al
| Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
available Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 Bool -> Bool -> Bool
&& Bool
addSpaces -> AttrString
al AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.spaceAttrW32]
| Bool
otherwise -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
available Int
len of
LT -> Int -> AttrString -> AttrString
forall a. Int -> [a] -> [a]
take (Int
available Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) AttrString
al AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.trimmedLineAttrW32]
GT | Bool
addSpaces ->
let alSpace :: AttrString
alSpace = AttrString
al AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.spaceAttrW32, AttrCharW32
Color.spaceAttrW32]
whiteN :: Int
whiteN = Int
fillFromStart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
in if Int
whiteN Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
then AttrString
alSpace
else AttrString
alSpace AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ Int -> AttrCharW32 -> AttrString
forall a. Int -> a -> [a]
replicate Int
whiteN AttrCharW32
Color.spaceAttrW32
_ -> AttrString
al
overlayFrame :: Int -> OverlaySpace -> PreFrame -> PreFrame
overlayFrame :: Int -> OverlaySpace -> PreFrame -> PreFrame
overlayFrame width :: Int
width ov :: OverlaySpace
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
((PointUI, AttrString) -> ST s ()) -> OverlaySpace -> ST s ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\(PointUI px :: Int
px py :: Int
py, l :: AttrString
l) ->
let offset :: Int
offset = Int
py Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
px Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
in FrameForall -> FrameST s
FrameForall -> forall s. FrameST s
unFrameForall (Int -> AttrString -> FrameForall
writeLine Int
offset AttrString
l) Mutable Vector s Word32
v) OverlaySpace
ov )