content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  -- | Slideshows.
  module Game.LambdaHack.Client.UI.Slideshow
    ( FontOverlayMap, maxYofFontOverlayMap
    , KeyOrSlot, MenuSlot, natSlots
    , ButtonWidth(..)
    , KYX, xytranslateKXY, xtranslateKXY, ytranslateKXY, yrenumberKXY
    , OKX, emptyOKX, xytranslateOKX, sideBySideOKX, labDescOKX
    , Slideshow(slideshow), emptySlideshow, unsnocSlideshow, toSlideshow
    , attrLinesToFontMap, menuToSlideshow, wrapOKX, splitOverlay, splitOKX
    , highSlideshow
  #ifdef EXPOSE_INTERNAL
      -- * Internal operations
    , keysOKX, showTable, showNearbyScores
  #endif
    ) where
  
  import Prelude ()
  
  import Game.LambdaHack.Core.Prelude
  
  import           Data.Binary
  import qualified Data.EnumMap.Strict as EM
  import           Data.Time.LocalTime
  
  import qualified Game.LambdaHack.Client.UI.Key as K
  import           Game.LambdaHack.Client.UI.Msg
  import           Game.LambdaHack.Client.UI.Overlay
  import           Game.LambdaHack.Client.UI.PointUI
  import qualified Game.LambdaHack.Common.HighScore as HighScore
  import qualified Game.LambdaHack.Definition.Color as Color
  
  type FontOverlayMap = EM.EnumMap DisplayFont Overlay
  
  maxYofFontOverlayMap :: FontOverlayMap -> Int
  maxYofFontOverlayMap ovs = maximum (0 : map maxYofOverlay (EM.elems ovs))
  
  type KeyOrSlot = Either K.KM MenuSlot
  
  newtype MenuSlot = MenuSlot Int
    deriving (Show, Eq, Ord, Binary, Enum)
  
  natSlots :: [MenuSlot]
  {-# INLINE natSlots #-}
  natSlots = [MenuSlot 0 ..]
  
  -- TODO: probably best merge the PointUI into that and represent
  -- the position as characters, too, translating to UI positions as needed.
  -- The problem is that then I need to do a lot of reverse translation
  -- when creating buttons.
  -- | Width of on-screen button text, expressed in characters,
  -- and so UI (mono font) width is deduced from the used font.
  data ButtonWidth = ButtonWidth
    { buttonFont  :: DisplayFont
    , buttonWidth :: Int }
    deriving (Show, Eq)
  
  -- | A key or a menu slot at a given position on the screen.
  type KYX = (KeyOrSlot, (PointUI, ButtonWidth))
  
  xytranslateKXY :: Int -> Int -> KYX -> KYX
  xytranslateKXY dx dy (km, (PointUI x y, len)) =
    (km, (PointUI (x + dx) (y + dy), len))
  
  xtranslateKXY :: Int -> KYX -> KYX
  xtranslateKXY dx = xytranslateKXY dx 0
  
  ytranslateKXY :: Int -> KYX -> KYX
  ytranslateKXY = xytranslateKXY 0
  
  yrenumberKXY :: Int -> KYX -> KYX
  yrenumberKXY ynew (km, (PointUI x _, len)) = (km, (PointUI x ynew, len))
  
  -- | An Overlay of text with an associated list of keys or slots
  -- that activate when the specified screen position is pointed at.
  -- The list should be sorted wrt rows and then columns.
  type OKX = (FontOverlayMap, [KYX])
  
  emptyOKX :: OKX
  emptyOKX = (EM.empty, [])
  
  xytranslateOKX ::Int -> Int -> OKX -> OKX
  xytranslateOKX dx dy (ovs, kyxs) =
    ( EM.map (xytranslateOverlay dx dy) ovs
    , map (xytranslateKXY dx dy) kyxs )
  
  sideBySideOKX :: Int -> Int -> OKX -> OKX -> OKX
  sideBySideOKX dx dy (ovs1, kyxs1) (ovs2, kyxs2) =
    let (ovs3, kyxs3) = xytranslateOKX dx dy (ovs2, kyxs2)
    in ( EM.unionWith (++) ovs1 ovs3
       , sortOn (\(_, (PointUI x y, _)) -> (y, x)) $ kyxs1 ++ kyxs3 )
  
  -- The bangs are to free the possibly very long input list ASAP.
  labDescOKX :: DisplayFont -> DisplayFont
             -> [(AttrString, AttrString, KeyOrSlot)]
             -> OKX
  labDescOKX labFont descFont l =
    let descFontSize | isPropFont descFont = length  -- may be less or a bit more
                     | otherwise = textSize descFont
        processRow :: (AttrString, AttrString, KeyOrSlot)
                   -> (AttrLine, (Int, AttrLine), KYX)
        processRow (!tLab, !tDesc, !ekm) =
          let labLen = textSize labFont tLab
              lenButton = labLen + descFontSize tDesc
          in ( attrStringToAL tLab
             , (labLen, attrStringToAL tDesc)
             , (ekm, (PointUI 0 0, ButtonWidth descFont lenButton)) )
        (tsLab, tsDesc, kxs) = unzip3 $ map processRow l
        ovs = EM.insertWith (++) labFont (offsetOverlay tsLab)
              $ EM.singleton descFont $ offsetOverlayX tsDesc
    in (ovs, zipWith yrenumberKXY [0..] kxs)
  
  -- | A list of active screenfulls to be shown one after another.
  -- Each screenful has an independent numbering of rows and columns.
  newtype Slideshow = Slideshow {slideshow :: [OKX]}
    deriving (Show, Eq)
  
  emptySlideshow :: Slideshow
  emptySlideshow = Slideshow []
  
  unsnocSlideshow :: Slideshow -> Maybe (Slideshow, OKX)
  unsnocSlideshow Slideshow{slideshow} =
    case reverse slideshow of
      [] -> Nothing
      okx : rest -> Just (Slideshow $ reverse rest, okx)
  
  toSlideshow :: FontSetup -> Bool -> [OKX] -> Slideshow
  toSlideshow FontSetup{..}displayTutorialHints okxs =
    Slideshow $ addFooters False okxs
   where
    atEnd = flip (++)
    appendToFontOverlayMap :: FontOverlayMap -> String
                           -> (FontOverlayMap, PointUI, DisplayFont, Int)
    appendToFontOverlayMap ovs msgPrefix =
      let msg | displayTutorialHints =
                msgPrefix
                ++ "  (ESC to exit, PGUP, HOME, mouse, wheel, arrows, etc.)"
              | otherwise = msgPrefix
          maxYminXofOverlay ov =
            let ymxOfOverlay (PointUI x y, _) = (- y, x)
            in minimum $ maxBound : map ymxOfOverlay ov
          -- @sortOn@ less efficient here, because function cheap.
          assocsYX = sortBy (comparing snd)
                     $ EM.assocs $ EM.map maxYminXofOverlay ovs
          (fontMax, yMax) = case assocsYX of
            [] -> (monoFont, 0)
            (font, (yNeg, _x)) : rest ->
              let unique = all (\(_, (yNeg2, _)) -> yNeg /= yNeg2) rest
              in ( if isSquareFont font && unique
                   then font
                   else monoFont
                 , - yNeg )
          pMax = PointUI 0 (yMax + 1)  -- append after last line
      in ( EM.insertWith atEnd fontMax [(pMax, stringToAL msg)] ovs
         , pMax
         , fontMax
         , length msg )
    addFooters :: Bool -> [OKX] -> [OKX]
    addFooters _ [] = error $ "" `showFailure` okxs
    addFooters _ [(als, [])] =
      -- TODO: make sure this case never coincides with the space button
      -- actually returning to top, as opposed to finishing preview.
      let (ovs, p, font, width) = appendToFontOverlayMap als "--end--"
      in [(ovs, [(Left K.safeSpaceKM, (p, ButtonWidth font width))])]
    addFooters False [(als, kxs)] = [(als, kxs)]
    addFooters True [(als, kxs)] =
      let (ovs, p, font, width) = appendToFontOverlayMap als "--back to top--"
      in [(ovs, kxs ++ [(Left K.safeSpaceKM, (p, ButtonWidth font width))])]
    addFooters _ ((als, kxs) : rest) =
      let (ovs, p, font, width) = appendToFontOverlayMap als "--more--"
      in (ovs, kxs ++ [(Left K.safeSpaceKM, (p, ButtonWidth font width))])
         : addFooters True rest
  
  -- | This appends vertically a list of blurbs into a single font overlay map.
  -- Not to be used if some blurbs need to be places overlapping vertically,
  -- e.g., when the square font symbol needs to be in the same line
  -- as the start of the descritpion of the denoted item
  -- or when mono font buttons need to be after a prompt.
  attrLinesToFontMap :: [(DisplayFont, [AttrLine])] -> FontOverlayMap
  attrLinesToFontMap blurb =
    let zipAttrLines :: Int -> [AttrLine] -> (Overlay, Int)
        zipAttrLines start als =
          ( zipWith (curry (first $ PointUI 0)) [start ..] als
          , start + length als )
        addOverlay :: (FontOverlayMap, Int) -> (DisplayFont, [AttrLine])
                   -> (FontOverlayMap, Int)
        addOverlay (!em, !start) (font, als) =
          let (als2, start2) = zipAttrLines start als
          in ( EM.insertWith (++) font als2 em
             , start2 )
        (ov, _) = foldl' addOverlay (EM.empty, 0) blurb
    in ov
  
  menuToSlideshow :: OKX -> Slideshow
  menuToSlideshow (als, kxs) =
    assert (not (EM.null als || null kxs)) $ Slideshow [(als, kxs)]
  
  wrapOKX :: DisplayFont -> Int -> Int -> Int -> [(K.KM, String)]
          -> (Overlay, [KYX])
  wrapOKX _ _ _ _ [] = ([], [])
  wrapOKX displayFont ystart xstart width ks =
    let overlayLineFromStrings :: Int -> Int -> [String] -> (PointUI, AttrLine)
        overlayLineFromStrings xlineStart y strings =
          let p = PointUI xlineStart y
          in (p, stringToAL $ unwords (reverse strings))
        f :: ((Int, Int), (Int, [String], Overlay, [KYX])) -> (K.KM, String)
          -> ((Int, Int), (Int, [String], Overlay, [KYX]))
        f ((y, x), (xlineStart, kL, kV, kX)) (key, s) =
          let len = textSize displayFont s
              len1 = len + textSize displayFont " "
          in if x + len >= width
             then let iov = overlayLineFromStrings xlineStart y kL
                  in f ((y + 1, 0), (0, [], iov : kV, kX)) (key, s)
             else ( (y, x + len1)
                  , ( xlineStart
                    , s : kL
                    , kV
                    , (Left key, ( PointUI x y
                                 , ButtonWidth displayFont (length s) ))
                      : kX ) )
        ((ystop, _), (xlineStop, kL1, kV1, kX1)) =
          foldl' f ((ystart, xstart), (xstart, [], [], [])) ks
        iov1 = overlayLineFromStrings xlineStop ystop kL1
    in (reverse $ iov1 : kV1, reverse kX1)
  
  keysOKX :: DisplayFont -> Int -> Int -> Int -> [K.KM] -> (Overlay, [KYX])
  keysOKX displayFont ystart xstart width keys =
    let wrapB :: String -> String
        wrapB s = "[" ++ s ++ "]"
        ks = map (\key -> (key, wrapB $ K.showKM key)) keys
    in wrapOKX displayFont ystart xstart width ks
  
  -- The font argument is for the report and keys overlay. Others already have
  -- assigned fonts.
  splitOverlay :: FontSetup -> Bool -> Int -> Int -> Int -> Report -> [K.KM]
               -> OKX
               -> Slideshow
  splitOverlay fontSetup displayTutorialHints
               width height wrap report keys (ls0, kxs0) =
    let renderedReport = renderReport True report
        reportAS = foldr (<\:>) [] renderedReport
    in toSlideshow fontSetup displayTutorialHints $
         splitOKX fontSetup False width height wrap reportAS keys (ls0, kxs0)
  
  -- Note that we only split wrt @White@ space, nothing else.
  splitOKX :: FontSetup -> Bool -> Int -> Int -> Int -> AttrString -> [K.KM]
           -> OKX
           -> [OKX]
  splitOKX FontSetup{..} msgLong width height wrap reportAS keys (ls0, kxs0) =
    assert (width > 2 && height > 2) $
      -- if the strings to split are long these minimums won't be enough,
      -- but content validation ensures larger values (perhaps large enough?)
    let reportParagraphs = linesAttr reportAS
        -- TODO: until SDL support for measuring prop font text is released,
        -- we have to use MonoFont for the paragraph that ends with buttons.
        (repProp, repMono) =
          if null keys
          then (reportParagraphs, emptyAttrLine)
          else case reverse reportParagraphs of
            [] -> ([], emptyAttrLine)
            l : rest ->
              (reverse rest, attrStringToAL $ attrLine l ++ [Color.nbspAttrW32])
        msgWrap = if msgLong && not (isSquareFont propFont)
                  then 2 * width
                  else wrap  -- TODO if with width fits on one screen, use it
        msgWidth = if msgLong && not (isSquareFont propFont)
                   then 2 * width
                   else width
        repProp0 = offsetOverlay $ case repProp of
          [] -> []
          r : rs ->
            -- Make lines of first paragraph long if it has 2 lines at most.
            -- The first line does not obscure anything and the second line
            -- is often short anyway.
            let firstWidth = if length (attrLine r) <= 2 * msgWidth
                             then msgWidth
                             else msgWrap
            in (indentSplitAttrString propFont firstWidth . attrLine) r
                 -- first possibly long
               ++ concatMap (indentSplitAttrString propFont msgWrap . attrLine) rs
        -- TODO: refactor this ugly pile of copy-paste
        repPropW = offsetOverlay
                   $ concatMap (indentSplitAttrString propFont width . attrLine)
                               repProp
        -- If the mono portion first on the line, let it take half width,
        -- but if previous lines shorter, match them and only buttons
        -- are permitted to stick out.
        monoWidth = if null repProp then msgWidth else msgWrap
        repMono0 = ytranslateOverlay (length repProp0)
                   $ offsetOverlay
                   $ indentSplitAttrString monoFont monoWidth $ attrLine repMono
        repMonoW = ytranslateOverlay (length repPropW)
                   $ offsetOverlay
                   $ indentSplitAttrString monoFont width $ attrLine repMono
        repWhole0 = offsetOverlay
                    $ concatMap (indentSplitAttrString propFont msgWidth
                                 . attrLine)
                                reportParagraphs
        repWhole1 = ytranslateOverlay 1 repWhole0
        lenOfRep0 = length repProp0 + length repMono0
        lenOfRepW = length repPropW + length repMonoW
        startOfKeys = if null repMono0
                      then 0
                      else textSize monoFont (attrLine $ snd $ last repMono0)
        startOfKeysW = if null repMonoW
                       then 0
                       else textSize monoFont (attrLine $ snd $ last repMonoW)
        pressAKey = stringToAS "A long report is shown. Press a key:"
                    ++ [Color.nbspAttrW32]
        (lX0, keysX0) = keysOKX monoFont 0 (length pressAKey) width keys
        (lX1, keysX1) = keysOKX monoFont 1 0 width keys
        (lX, keysX) = keysOKX monoFont (max 0 $ lenOfRep0 - 1) startOfKeys
                              (2 * width) keys
        (lXW, keysXW) = keysOKX monoFont (max 0 $ lenOfRepW - 1) startOfKeysW
                                (2 * width) keys
        splitO :: Int -> (Overlay, Overlay, [KYX]) -> OKX -> [OKX]
        splitO yoffset (hdrProp, hdrMono, rk) (ls, kxs) =
          let hdrOff | null hdrProp && null hdrMono = 0
                     | otherwise = 1 + maxYofOverlay hdrMono
              keyTranslate = map $ ytranslateKXY (hdrOff - yoffset)
              lineTranslate = EM.map $ ytranslateOverlay (hdrOff - yoffset)
              yoffsetNew = yoffset + height - hdrOff - 1
              ltOffset :: (PointUI, a) -> Bool
              ltOffset (PointUI _ y, _) = y < yoffsetNew
              (pre, post) = ( filter ltOffset <$> ls
                            , filter (not . ltOffset) <$> ls )
              prependHdr = EM.insertWith (++) propFont hdrProp
                           . EM.insertWith (++) monoFont hdrMono
          in if all null $ EM.elems post  -- all fits on one screen
             then [(prependHdr $ lineTranslate pre, rk ++ keyTranslate kxs)]
             else let (preX, postX) = span (\(_, pa) -> ltOffset pa) kxs
                  in (prependHdr $ lineTranslate pre, rk ++ keyTranslate preX)
                     : splitO yoffsetNew (hdrProp, hdrMono, rk) (post, postX)
        firstParaReport = firstParagraph reportAS
        hdrShortened = ( [(PointUI 0 0, firstParaReport)]
                           -- shortened for the main slides; in full beforehand
                       , take 3 lX1  -- 3 lines ought to be enough for everyone
                       , keysX1 )
        ((lsInit, kxsInit), (headerProp, headerMono, rkxs)) =
          -- Check whether all space taken by report and keys.
          if | (lenOfRep0 + length lX) < height ->  -- display normally
               (emptyOKX, (repProp0, lX ++ repMono0, keysX))
             | (lenOfRepW + length lXW) < height ->  -- display widely
               (emptyOKX, (repPropW, lXW ++ repMonoW, keysXW))
             | length reportParagraphs == 1
               && length (attrLine firstParaReport) <= 2 * width ->
               ( emptyOKX  -- already shown in full in @hdrShortened@
               , hdrShortened )
             | otherwise -> case lX0 of
                 [] ->
                   ( (EM.singleton propFont repWhole0, [])
                       -- showing in full in the init slide
                   , hdrShortened )
                 lX0first : _ ->
                   ( ( EM.insertWith (++) propFont repWhole1
                       $ EM.singleton monoFont
                           [(PointUI 0 0, firstParagraph pressAKey), lX0first]
                     , filter (\(_, (PointUI _ y, _)) -> y == 0) keysX0 )
                   , hdrShortened )
        initSlides = if EM.null lsInit
                     then assert (null kxsInit) []
                     else splitO 0 ([], [], []) (lsInit, kxsInit)
        -- If @ls0@ is not empty, we still want to display the report,
        -- one way or another.
        mainSlides = if EM.null ls0 && not (EM.null lsInit)
                     then assert (null kxs0) []
                     else splitO 0 (headerProp, headerMono, rkxs) (ls0, kxs0)
    in initSlides ++ mainSlides
  
  -- | Generate a slideshow with the current and previous scores.
  highSlideshow :: FontSetup
                -> Bool
                -> Int        -- ^ width of the display area
                -> Int        -- ^ height of the display area
                -> HighScore.ScoreTable -- ^ current score table
                -> Int        -- ^ position of the current score in the table
                -> Text       -- ^ the name of the game mode
                -> TimeZone   -- ^ the timezone where the game is run
                -> Slideshow
  highSlideshow fontSetup@FontSetup{monoFont} displayTutorialHints
                width height table pos gameModeName tz =
    let entries = (height - 3) `div` 3
        msg = HighScore.showAward entries table pos gameModeName
        tts = map offsetOverlay $ showNearbyScores tz pos table entries
        al = textToAS msg
        splitScreen ts =
          splitOKX fontSetup False width height width al [K.spaceKM, K.escKM]
                   (EM.singleton monoFont ts, [])
    in toSlideshow fontSetup displayTutorialHints $ concatMap splitScreen tts
  
  -- | Show a screenful of the high scores table.
  -- Parameter @entries@ is the number of (3-line) scores to be shown.
  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 emptyAttrLine : intercalate [emptyAttrLine] (map renderScore screenful)
  
  -- | Produce a couple of renderings of the high scores table.
  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 ]
  