{-# LANGUAGE RankNTypes #-}
-- | Verifying, aggregating and displaying binding of keys to commands.
module Game.LambdaHack.Client.UI.KeyBindings
  ( keyHelp, okxsN
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.Map.Strict as M
import qualified Data.Text as T

import           Game.LambdaHack.Client.UI.Content.Input
import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.ContentClientUI
import           Game.LambdaHack.Client.UI.HumanCmd
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.Overlay
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Client.UI.Slideshow
import qualified Game.LambdaHack.Definition.Color as Color

-- | Produce a set of help/menu screens from the key bindings.
--
-- When the intro screen mentions KP_5, this really is KP_Begin,
-- but since that is harder to understand we assume a different, non-default
-- state of NumLock in the help text than in the code that handles keys.
keyHelp :: CCUI -> FontSetup -> [(Text, OKX)]
keyHelp CCUI{ coinput=coinput@InputContent{..}
            , coscreen=ScreenContent{rwidth, rheight} } FontSetup{..} =
  let
    movBlurb1 =
      [ "Walk throughout a level with mouse or numeric keypad (right diagram below)"
      , "or the Vi editor keys (middle) or the left-hand movement keys (left). Run until"
      , "disturbed with Shift or Control. Go-to a position with LMB (left mouse button)."
      , "In aiming mode, the same keys (and mouse) move the aiming crosshair."
      ]
    movSchema =
      [ "     q w e     y k u     7 8 9"
      , "      \\|/       \\|/       \\|/"
      , "     a-s-d     h-.-l     4-5-6"
      , "      /|\\       /|\\       /|\\"
      , "     z x c     b j n     1 2 3"
      ]
    movBlurb2 =
      [ "Press `KP_5` (`5` on keypad) to wait, bracing for impact, which reduces any"
      , "damage taken and prevents displacement by foes. Press `S-KP_5` or `C-KP_5`"
      , "(the same key with Shift or Control) to lurk 0.1 of a turn, without bracing."
      , ""
      , "Displace enemies by running into them with Shift/Control or S-LMB. Search,"
      , "open, descend and melee by bumping into walls, doors, stairs and enemies."
      , "The best, and not on cooldown, melee weapon is automatically chosen"
      , "for attack from your equipment and from among your body parts."
      ]
    minimalBlurb =
      [ "The following few commands, joined with the movement and running keys,"
      , "let you accomplish almost anything in the game, though not necessarily"
      , "with the fewest keystrokes. You can also play the game exclusively"
      , "with a mouse, or both mouse and keyboard (e.g., mouse for go-to"
      , "and terrain inspection and keyboard for everything else). Lastly,"
      , "you can select a command with arrows or mouse directly from the help"
      , "screen or the dashboard and execute it on the spot."
      ]
    itemAllEnding =
      [ "Note how lower case item commands (stash item, equip item) place items"
      , "into a particular item store, while upper case item commands (manage Inventory,"
      , "manage Outfit) open management menu for a store. Once a store menu is opened,"
      , "you can switch stores with `<` and `>`, so the multiple commands only determine"
      , "the starting item store. Each store is accessible from the dashboard as well."
      ]
    mouseBasicsBlurb =
      [ "Screen area and UI mode (exploration/aiming) determine mouse click"
      , "effects. Here we give an overview of effects of each button over"
      , "the game map area. The list includes not only left and right buttons,"
      , "but also the optional middle mouse button (MMB) and the mouse wheel,"
      , "which is also used over menus to move selection. For mice without RMB,"
      , "one can use Control key with LMB and for mice without MMB, one can use"
      , "C-RMB or C-S-LMB."
      ]
    mouseAreasBlurb =
      [ "Next we show mouse button effects per screen area, in exploration and"
      , "(if different) aiming mode. Note that mouse is optional. Keyboard suffices,"
      , "occasionally requiring a lookup for an obscure command key in help screens."
      ]
    mouseAreasMini =
      [ "Mouse button effects per screen area, in exploration and in aiming modes"
      ]
    movTextEnd = "Press SPACE or PGDN to advance or ESC to see the map again."
    lastHelpEnd = "Use PGUP to go back and ESC to see the map again."
    seeAlso = "For more playing instructions see file PLAYING.md."
    offsetCol2 = 12
    pickLeaderDescription =
      [ fmt offsetCol2 "0, 1 ... 9"
                       "pick a particular actor as the new pointman"
      ]
    casualDescription = "Minimal cheat sheet for casual play"
    fmt0 n k h = T.justifyLeft n ' ' k <> " " <> h
    fmt n k h = " " <> fmt0 n k h
    keyCaption = fmt offsetCol2 "keys" "command"
    mouseOverviewCaption = fmt offsetCol2 "keys" "command (exploration/aiming)"
    spLen = textSize monoFont " "
    okxs cat headers footers = xytranslateOKX spLen 0 $
      okxsN coinput monoFont propFont offsetCol2 (const False)
            True cat headers footers
    mergeOKX :: OKX -> OKX -> OKX
    mergeOKX okx1 okx2 =
      let off = 1 + maxYofFontOverlayMap (fst okx1)
      in sideBySideOKX 0 off okx1 okx2
    catLength cat = length $ filter (\(_, (cats, desc, _)) ->
      cat `elem` cats && (desc /= "" || CmdInternal `elem` cats)) bcmdList
    keyM = 13
    keyB = 31
    truncatem b = if T.length b > keyB
                  then T.take (keyB - 1) b <> "$"
                  else b
    fmm a b c = fmt (keyM + 1) a $ fmt0 keyB (truncatem b) (truncatem c)
    areaCaption t = fmm t "LMB (left mouse button)" "RMB (right mouse button)"
    keySel :: (forall a. (a, a) -> a) -> K.KM
           -> [(CmdArea, KeyOrSlot, Text)]
    keySel sel key =
      let cmd = case M.lookup key bcmdMap of
            Just (_, _, cmd2) -> cmd2
            Nothing -> error $ "" `showFailure` key
          caCmds = case cmd of
            ByAimMode AimModeCmd{exploration=ByArea lexp, aiming=ByArea laim} ->
              sort $ sel (lexp, laim \\ lexp)
            _ -> error $ "" `showFailure` cmd
          caMakeChoice (ca, cmd2) =
            let (km, desc) = case M.lookup cmd2 brevMap of
                  Just ks ->
                    let descOfKM km2 = case M.lookup km2 bcmdMap of
                          Just (_, "", _) -> Nothing
                          Just (_, desc2, _) -> Just (km2, desc2)
                          Nothing -> error $ "" `showFailure` km2
                    in case mapMaybe descOfKM ks of
                      [] -> error $ "" `showFailure` (ks, cmd2)
                      kmdesc3 : _ -> kmdesc3
                  Nothing -> (key, "(not described:" <+> tshow cmd2 <> ")")
            in (ca, Left km, desc)
      in map caMakeChoice caCmds
    doubleIfSquare n | isSquareFont monoFont = 2 * n
                     | otherwise = n
    okm :: (forall a. (a, a) -> a) -> K.KM -> K.KM -> [Text] -> OKX
    okm sel key1 key2 header =
      let kst1 = keySel sel key1
          kst2 = keySel sel key2
          f (ca1, Left km1, _) (ca2, Left km2, _) y =
            assert (ca1 == ca2 `blame` (ca1, ca2, km1, km2, kst1, kst2))
              [ (Left km1, ( PointUI (doubleIfSquare $ keyM + 4) y
                           , ButtonWidth monoFont keyB ))
              , (Left km2, ( PointUI (doubleIfSquare $ keyB + keyM + 5) y
                           , ButtonWidth monoFont keyB )) ]
          f c d e = error $ "" `showFailure` (c, d, e)
          kxs = concat $ zipWith3 f kst1 kst2 [1 + length header..]
          menuLeft = map (\(ca1, _, _) -> textToAL $ areaDescription ca1) kst1
          menuMiddle = map (\(_, _, desc) -> textToAL desc) kst1
          menuRight = map (\(_, _, desc) -> textToAL desc) kst2
          y0 = 1 + length header
      in ( EM.unionsWith (++)
             [ typesetInMono $ "" : header
             , EM.singleton monoFont
               $ typesetXY (doubleIfSquare 2, y0) menuLeft
             , EM.singleton propFont
               $ typesetXY (doubleIfSquare $ keyM + 4, y0) menuMiddle
             , EM.singleton propFont
               $ typesetXY (doubleIfSquare $ keyB + keyM + 5, y0) menuRight ]
         , kxs )
    typesetInSquare :: [Text] -> FontOverlayMap
    typesetInSquare =
      EM.singleton squareFont . typesetXY (spLen, 0) . map textToAL
    typesetInMono :: [Text] -> FontOverlayMap
    typesetInMono =
      EM.singleton monoFont . typesetXY (spLen, 0) . map textToAL
    typesetInProp :: [Text] -> FontOverlayMap
    typesetInProp =
      EM.singleton propFont . typesetXY (spLen, 0) . map textToAL
    sideBySide :: [(Text, OKX)] -> [(Text, OKX)]
    sideBySide ((_t1, okx1) : (t2, okx2) : rest) | not (isSquareFont propFont) =
      (t2, sideBySideOKX rwidth 0 okx1 okx2) : sideBySide rest
    sideBySide l = l
  in sideBySide $ concat
    [ if catLength CmdMinimal
         + length movBlurb1 + length movSchema + length movBlurb2
         + length minimalBlurb
         + 6 > rheight then
        [ ( movTextEnd
          , mergeOKX
              (mergeOKX ( typesetInMono ["", casualDescription <+> "(1/2)", ""]
                        , [] )
                        (mergeOKX (typesetInProp movBlurb1, [])
                                  (typesetInSquare $ "" : movSchema, [])))
              (typesetInProp $ "" : movBlurb2, []) )
        , ( movTextEnd
          , okxs CmdMinimal
                 ( ["", casualDescription <+> "(2/2)", ""]
                 , minimalBlurb ++ [""]
                 , [keyCaption] )
                 ([], []) ) ]
      else
        [ ( movTextEnd
          , mergeOKX
              (mergeOKX ( typesetInMono ["", casualDescription, ""]
                        , [] )
                        (mergeOKX (typesetInProp movBlurb1, [])
                                  (typesetInSquare $ "" : movSchema, [])))
              (okxs CmdMinimal
                    ( []
                    , [""] ++ movBlurb2 ++ [""]
                       ++ minimalBlurb ++ [""]
                    , [keyCaption] )
                    ([], [""])) ) ]
    , if 45 > rheight then
        [ ( movTextEnd
          , let (ls, _) = okxs CmdMouse
                               ( ["", "Optional mouse commands", ""]
                               , mouseBasicsBlurb ++ [""]
                               , [mouseOverviewCaption] )
                               ([], [])
            in (ls, []) )  -- don't capture mouse wheel, etc.
        , ( movTextEnd
          , mergeOKX
              (typesetInMono $ "" : mouseAreasMini, [])
              (mergeOKX
                 (okm fst K.leftButtonReleaseKM K.rightButtonReleaseKM
                      [areaCaption "Exploration"])
                 (okm snd K.leftButtonReleaseKM K.rightButtonReleaseKM
                      [areaCaption "Aiming Mode"])) ) ]
      else
        [ ( movTextEnd
          , let (ls, _) = okxs CmdMouse
                               ( ["", "Optional mouse commands", ""]
                               , mouseBasicsBlurb ++ [""]
                               , [mouseOverviewCaption] )
                               ([], [])
                okx0 = (ls, [])  -- don't capture mouse wheel, etc.
            in mergeOKX
                 (mergeOKX
                    okx0
                    (typesetInProp $ "" : mouseAreasBlurb, []))
                 (mergeOKX
                    (okm fst K.leftButtonReleaseKM K.rightButtonReleaseKM
                         [areaCaption "Exploration"])
                    (okm snd K.leftButtonReleaseKM K.rightButtonReleaseKM
                         [areaCaption "Aiming Mode"] )) ) ]
    , if catLength CmdItem + catLength CmdMove + 9 + 9 > rheight then
        [ ( movTextEnd
          , okxs CmdItem
                 (["", categoryDescription CmdItem], [], ["", keyCaption])
                 ([], "" : itemAllEnding) )
        , ( movTextEnd
          , okxs CmdMove
                 (["", categoryDescription CmdMove], [], ["", keyCaption])
                 (pickLeaderDescription, []) ) ]
      else
        [ ( movTextEnd
          , mergeOKX
              (okxs CmdItem
                    (["", categoryDescription CmdItem], [], ["", keyCaption])
                    ([], "" : itemAllEnding))
              (okxs CmdMove
                    ( ["", "", categoryDescription CmdMove]
                    , []
                    , ["", keyCaption] )
                    (pickLeaderDescription, [""])) ) ]
    , if catLength CmdAim + catLength CmdMeta + 9 > rheight then
        [ ( movTextEnd
          , okxs CmdAim
                 (["", categoryDescription CmdAim], [], ["", keyCaption])
                 ([], []) )
        , ( lastHelpEnd
          , okxs CmdMeta
                 (["", categoryDescription CmdMeta], [], ["", keyCaption])
                 ([], ["", seeAlso]) ) ]
      else
        [ ( lastHelpEnd
          , mergeOKX
              (okxs CmdAim
                    (["", categoryDescription CmdAim], [], ["", keyCaption])
                    ([], []))
              (okxs CmdMeta
                    ( ["", "", categoryDescription CmdMeta]
                    , []
                    , ["", keyCaption] )
                    ([], ["", seeAlso, ""])) ) ]
    ]

-- | Turn the specified portion of bindings into a menu.
--
-- The length of the button may be wrong if the two supplied fonts
-- have very different widths.
okxsN :: InputContent -> DisplayFont -> DisplayFont -> Int -> (HumanCmd -> Bool)
      -> Bool -> CmdCategory -> ([Text], [Text], [Text]) -> ([Text], [Text])
      -> OKX
okxsN InputContent{..} labFont descFont offsetCol2 greyedOut
      showManyKeys cat (headerMono1, headerProp, headerMono2)
      (footerMono, footerProp) =
  let fmt k h = (T.singleton '\x00a0' <> k, h)
      coImage :: HumanCmd -> [K.KM]
      coImage cmd = M.findWithDefault (error $ "" `showFailure` cmd) cmd brevMap
      disp = T.intercalate " or " . map (T.pack . K.showKM)
      keyKnown km = case K.key km of
        K.Unknown{} -> False
        _ -> True
      keys :: [(KeyOrSlot, (Bool, (Text, Text)))]
      keys = [ (Left km, (greyedOut cmd, fmt keyNames desc))
             | (_, (cats, desc, cmd)) <- bcmdList
             , let kms = coImage cmd
                   knownKeys = filter keyKnown kms
                   keyNames =
                     disp $ (if showManyKeys then id else take 1) knownKeys
                   kmsRes = if desc == "" then knownKeys else kms
                   km = case kmsRes of
                     [] -> K.escKM
                     km1 : _ -> km1
             , cat `elem` cats
             , desc /= "" || CmdInternal `elem` cats]
      spLen = textSize labFont " "
      f (ks, (_, (_, t2))) y =
        (ks, ( PointUI spLen y
             , ButtonWidth labFont (offsetCol2 + 2 + T.length t2 - 1)))
      kxs = zipWith f keys
              [length headerMono1 + length headerProp + length headerMono2 ..]
      ts = map (\t -> (False, (t, ""))) headerMono1
           ++ map (\t -> (False, ("", t))) headerProp
           ++ map (\t -> (False, (t, ""))) headerMono2
           ++ map snd keys
           ++ map (\t -> (False, (t, ""))) footerMono
           ++ map (\t -> (False, ("", t))) footerProp
      greyToAL (b, (t1, t2)) =
        if b
        then let al1 = textFgToAL Color.BrBlack t1
             in (al1, ( if T.null t1 then 0 else spLen * (offsetCol2 + 2)
                      , textFgToAL Color.BrBlack t2 ))
        else let al1 = textToAL t1
             in (al1, ( if T.null t1 then 0 else spLen * (offsetCol2 + 2)
                      , textToAL t2 ))
      (greyLab, greyDesc) = unzip $ map greyToAL ts
  in ( EM.insertWith (++) descFont (offsetOverlayX greyDesc)
       $ EM.singleton labFont (offsetOverlay greyLab)
     , kxs )