module Game.LambdaHack.Client.UI.Slideshow
( KYX, OKX, Slideshow(slideshow)
, emptySlideshow, unsnoc, toSlideshow, menuToSlideshow
, wrapOKX, splitOverlay, splitOKX, highSlideshow
#ifdef EXPOSE_INTERNAL
, moreMsg, endMsg, keysOKX, showTable, showNearbyScores
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Data.Time.LocalTime
import Game.LambdaHack.Client.UI.ItemSlot
import qualified Game.LambdaHack.Client.UI.Key as K
import Game.LambdaHack.Client.UI.Msg
import Game.LambdaHack.Client.UI.Overlay
import qualified Game.LambdaHack.Common.HighScore as HighScore
import qualified Game.LambdaHack.Definition.Color as Color
import Game.LambdaHack.Definition.Defs
type KYX = (Either [K.KM] SlotChar, (Y, X, X))
type OKX = (Overlay, [KYX])
newtype Slideshow = Slideshow {slideshow :: [OKX]}
deriving (Show, Eq)
emptySlideshow :: Slideshow
emptySlideshow = Slideshow []
unsnoc :: Slideshow -> Maybe (Slideshow, OKX)
unsnoc Slideshow{slideshow} =
case reverse slideshow of
[] -> Nothing
okx : rest -> Just (Slideshow $ reverse rest, okx)
toSlideshow :: [OKX] -> Slideshow
toSlideshow okxs = Slideshow $ addFooters False okxsNotNull
where
okxFilter (ov, kyxs) =
(ov, filter (either (not . null) (const True) . fst) kyxs)
okxsNotNull = map okxFilter okxs
addFooters _ [] = error $ "" `showFailure` okxsNotNull
addFooters _ [(als, [])] =
[( als ++ [stringToAL endMsg]
, [(Left [K.safeSpaceKM], (length als, 0, 15))] )]
addFooters False [(als, kxs)] = [(als, kxs)]
addFooters True [(als, kxs)] =
[( als ++ [stringToAL endMsg]
, kxs ++ [(Left [K.safeSpaceKM], (length als, 0, 15))] )]
addFooters _ ((als, kxs) : rest) =
( als ++ [stringToAL moreMsg]
, kxs ++ [(Left [K.safeSpaceKM], (length als, 0, 8))] )
: addFooters True rest
moreMsg :: String
moreMsg = "--more-- "
endMsg :: String
endMsg = "--back to top-- "
menuToSlideshow :: OKX -> Slideshow
menuToSlideshow (als, kxs) =
assert (not (null als || null kxs)) $ Slideshow [(als, kxs)]
wrapOKX :: Y -> X -> X -> [(K.KM, String)] -> OKX
wrapOKX ystart xstart xBound ks =
let f ((y, x), (kL, kV, kX)) (key, s) =
let len = length s
in if x + len > xBound
then f ((y + 1, 0), ([], kL : kV, kX)) (key, s)
else ( (y, x + len + 1)
, (s : kL, kV, (Left [key], (y, x, x + len)) : kX) )
(kL1, kV1, kX1) = snd $ foldl' f ((ystart, xstart), ([], [], [])) ks
catL = stringToAL . intercalate " " . reverse
in (reverse $ map catL $ kL1 : kV1, reverse kX1)
keysOKX :: Y -> X -> X -> [K.KM] -> OKX
keysOKX ystart xstart xBound keys =
let wrapB :: String -> String
wrapB s = "[" ++ s ++ "]"
ks = map (\key -> (key, wrapB $ K.showKM key)) keys
in wrapOKX ystart xstart xBound ks
splitOverlay :: X -> Y -> Report -> [K.KM] -> OKX -> Slideshow
splitOverlay width height report keys (ls0, kxs0) =
toSlideshow $ splitOKX width height (renderReport report) keys (ls0, kxs0)
splitOKX :: X -> Y -> AttrLine -> [K.KM] -> OKX -> [OKX]
splitOKX width height rrep keys (ls0, kxs0) =
assert (height > 2) $
let msgRaw = splitAttrLine width rrep
(lX0, keysX0) = keysOKX 0 0 maxBound keys
(lX, keysX) | null msgRaw = (lX0, keysX0)
| otherwise = keysOKX (length msgRaw - 1)
(length (last msgRaw) + 1)
width keys
msgOkx = (glueLines msgRaw lX, keysX)
((lsInit, kxsInit), (header, rkxs)) =
if length (glueLines msgRaw lX0) * 2 > height
then (msgOkx, ( [intercalate [Color.spaceAttrW32] lX0 <+:> rrep]
, keysX0 ))
else (([], []), msgOkx)
renumber y (km, (y0, x1, x2)) = (km, (y0 + y, x1, x2))
splitO yoffset (hdr, rk) (ls, kxs) =
let zipRenumber = map $ renumber $ length hdr - yoffset
(pre, post) = splitAt (height - 1) $ hdr ++ ls
yoffsetNew = yoffset + height - length hdr - 1
in if null post
then [(pre, rk ++ zipRenumber kxs)]
else let (preX, postX) =
break (\(_, (y1, _, _)) -> y1 >= yoffsetNew) kxs
in (pre, rk ++ zipRenumber preX)
: splitO yoffsetNew (hdr, rk) (post, postX)
initSlides = if null lsInit
then assert (null kxsInit) []
else splitO 0 ([], []) (lsInit, kxsInit)
mainSlides = if null ls0 && not (null lsInit)
then assert (null kxs0) []
else splitO 0 (header, rkxs) (ls0, kxs0)
in initSlides ++ mainSlides
highSlideshow :: X
-> Y
-> HighScore.ScoreTable
-> Int
-> Text
-> TimeZone
-> Slideshow
highSlideshow width height table pos gameModeName tz =
let entries = (height - 3) `div` 3
msg = HighScore.showAward entries table pos gameModeName
tts = showNearbyScores tz pos table entries
al = textToAL msg
splitScreen ts =
splitOKX width height al [K.spaceKM, K.escKM] (ts, [])
in toSlideshow $ concat $ map splitScreen tts
showTable :: TimeZone -> Int -> HighScore.ScoreTable -> Int -> Int -> [AttrLine]
showTable tz pos table start entries =
let zipped = zip [1..] $ HighScore.unTable table
screenful = take entries . drop (start - 1) $ zipped
renderScore (pos1, score1) =
map (if pos1 == pos then textFgToAL Color.BrWhite else textToAL)
$ HighScore.showScore tz pos1 score1
in [] : intercalate [[]] (map renderScore screenful)
showNearbyScores :: TimeZone -> Int -> HighScore.ScoreTable -> Int
-> [[AttrLine]]
showNearbyScores tz pos h entries =
if pos <= entries
then [showTable tz pos h 1 entries]
else [showTable tz pos h 1 entries,
showTable tz pos h (max (entries + 1) (pos - entries `div` 2)) entries]