{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Screen frames and animations.
module Game.LambdaHack.Common.Animation
  ( Attr(..), defAttr, AttrChar(..)
  , SingleFrame(..), emptySingleFrame, xsizeSingleFrame, ysizeSingleFrame
  , Animation, Frames, renderAnim, restrictAnim
  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout
  , AcFrame(..)
  , DebugModeCli(..), defDebugModeCli
  ) where

import Control.Arrow ((***))
import Control.Monad
import Data.Binary
import Data.Bits
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.List as L
import Data.Maybe
import Data.Monoid
import Data.Text (Text)

import Game.LambdaHack.Common.Color
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.PointXY
import Game.LambdaHack.Common.Random

-- | The data sufficent to draw a single game screen frame.
--
-- The fields are not strict, because sometimes frames are not used,
-- e.g., when a keypress discards all frames not yet drawn and displayed.
data SingleFrame = SingleFrame
  { sfLevel  :: [[AttrChar]]  -- ^ content of the screen, line by line
  , sfTop    :: Text          -- ^ an extra line to show at the top
  , sfBottom :: Text          -- ^ an extra line to show at the bottom
  }
  deriving (Eq, Show)

instance Binary SingleFrame where
  put SingleFrame{..} = do
    put sfLevel
    put sfTop
    put sfBottom
  get = do
    sfLevel <- get
    sfTop <- get
    sfBottom <- get
    return SingleFrame{..}

-- | Animation is a list of frame modifications to play one by one,
-- where each modification if a map from positions to level map symbols.
newtype Animation = Animation [EM.EnumMap Point AttrChar]
  deriving (Eq, Show, Monoid)

-- | Sequences of screen frames, including delays.
type Frames = [Maybe SingleFrame]

emptySingleFrame :: SingleFrame
emptySingleFrame = SingleFrame{sfLevel = [], sfTop = "", sfBottom = ""}

xsizeSingleFrame :: SingleFrame -> X
xsizeSingleFrame SingleFrame{sfLevel=[]} = 0
xsizeSingleFrame SingleFrame{sfLevel=line : _} = length line

ysizeSingleFrame :: SingleFrame -> X
ysizeSingleFrame SingleFrame{sfLevel} = length sfLevel

-- | Render animations on top of a screen frame.
renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames
renderAnim lxsize lysize basicFrame (Animation anim) =
  let modifyFrame SingleFrame{sfLevel = levelOld, ..} am =
        let fLine y lineOld =
              let f l (x, acOld) =
                    let pos = toPoint lxsize (PointXY (x, y))
                        !ac = fromMaybe acOld $ EM.lookup pos am
                    in ac : l
              in L.foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))
            sfLevel =  -- Fully evaluated.
              let f l (y, lineOld) = let !line = fLine y lineOld in line : l
              in L.foldl' f [] (zip [lysize-1,lysize-2..0] (reverse levelOld))
        in Just SingleFrame{..}
  in map (modifyFrame basicFrame) anim

blank :: Maybe AttrChar
blank = Nothing

coloredSymbol :: Color -> Char -> Maybe AttrChar
coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol

mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar)
          -> [(Point, AttrChar)]
mzipPairs (p1, p2) (mattr1, mattr2) =
  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr
  in catMaybes $ if p1 /= p2
                 then [mzip (p1, mattr1), mzip (p2, mattr2)]
                 else -- If actor affects himself, show only the effect,
                      -- not the action.
                      [mzip (p1, mattr1)]

restrictAnim :: ES.EnumSet Point -> Animation -> Animation
restrictAnim vis (Animation as) =
  let f imap =
        let common = EM.intersection imap $ EM.fromSet (const ()) vis
          in if EM.null common then Nothing else Just common
  in Animation $ mapMaybe f as

-- | Attack animation. A part of it also reused for self-damage and healing.
twirlSplash :: (Point, Point) -> Color -> Color -> Animation
twirlSplash poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)
  [ (coloredSymbol BrWhite '*', blank)
  , (coloredSymbol c1      '/', coloredSymbol BrCyan '^')
  , (coloredSymbol c1      '-', blank)
  , (coloredSymbol c1      '\\',blank)
  , (coloredSymbol c1      '|', blank)
  , (coloredSymbol c2      '%', blank)
  , (coloredSymbol c2      '%', blank)
  , (blank                    , blank)
  ]

-- | Attack that hits through a block.
blockHit :: (Point, Point) -> Color -> Color -> Animation
blockHit poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)
  [ (coloredSymbol BrWhite '*', blank)
  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')
  , (coloredSymbol BrBlue  '{', blank)
  , (coloredSymbol BrBlue  '}', blank)
  , (coloredSymbol c1      '/', blank)
  , (coloredSymbol c2      '%', blank)
  , (coloredSymbol c2      '%', blank)
  , (blank                    , blank)
  ]

-- | Attack that is blocked.
blockMiss :: (Point, Point) -> Animation
blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss)
  [ (coloredSymbol BrWhite '*', blank)
  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '\'')
  , (coloredSymbol BrBlue  '}', blank)
  , (blank                    , blank)
  ]

-- | Death animation for an organic body.
deathBody :: Point -> Animation
deathBody pos = Animation $ map (maybe EM.empty (EM.singleton pos))
  [ coloredSymbol BrRed '\\'
  , coloredSymbol BrRed '\\'
  , coloredSymbol BrRed '|'
  , coloredSymbol BrRed '|'
  , coloredSymbol BrRed '%'
  , coloredSymbol BrRed '%'
  , coloredSymbol Red   '%'
  , coloredSymbol Red   '%'
  , coloredSymbol Red   ';'
  , coloredSymbol Red   ';'
  , coloredSymbol Red   ','
  ]

-- | Swap-places animation, both hostile and friendly.
swapPlaces :: (Point, Point) -> Animation
swapPlaces poss = Animation $ map (EM.fromList . mzipPairs poss)
  [ (coloredSymbol BrMagenta '.', coloredSymbol Magenta   'o')
  , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta   'p')
  , (coloredSymbol Magenta   'p', coloredSymbol BrMagenta 'd')
  , (coloredSymbol Magenta   'o', blank)
  ]

fadeout :: Bool -> Bool -> X -> Y -> Rnd Animation
fadeout out topRight lxsize lysize = do
  let xbound = lxsize - 1
      ybound = lysize - 1
      edge = EM.fromDistinctAscList $ zip [1..] ".%&%;:,."
      fadeChar r n x y =
        let d = x - 2 * y
            ndy = n - d - 2 * ybound
            ndx = n + d - xbound - 1  -- @-1@ for asymmetry
            mnx = if ndy > 0 && ndx > 0
                  then min ndy ndx
                  else max ndy ndx
            v3 = (r `xor` (x * y)) `mod` 3
            k | mnx < 3 || mnx > 10 = mnx
              | (min x (xbound - x - y) + n + v3) `mod` 15 < 11
                && mnx > 6 = mnx - v3
              | (x + 3 * y + v3) `mod` 30 < 19 = mnx + 1
              | otherwise = mnx
        in EM.findWithDefault ' ' k edge
      rollFrame n = do
        r <- random
        let l = [ ( PointXY (if topRight then x else xbound - x, y)
                  , fadeChar r n x y )
                | x <- [0..xbound]
                , y <- [max 0 (ybound - (n - x) `div` 2)..ybound]
                    ++ [0..min ybound ((n - xbound + x) `div` 2)]
                ]
        return $ EM.fromList $ map (toPoint lxsize *** AttrChar defAttr) l
      startN = if out then 3 else 1
      fs = [startN..3 * lxsize `divUp` 4 + 2]
  as <- mapM rollFrame $ if out then fs else reverse fs
  return $ Animation as

data AcFrame =
    AcConfirm !SingleFrame
  | AcRunning !SingleFrame
  | AcNormal !SingleFrame
  | AcDelay
  deriving (Show, Eq)

instance Binary AcFrame where
  put (AcConfirm fr) = putWord8 0 >> put fr
  put (AcRunning fr) = putWord8 1 >> put fr
  put (AcNormal fr)  = putWord8 2 >> put fr
  put AcDelay        = putWord8 3
  get = do
    tag <- getWord8
    case tag of
      0 -> liftM AcConfirm get
      1 -> liftM AcRunning get
      2 -> liftM AcNormal get
      3 -> return AcDelay
      _ -> fail "no parse (AcFrame)"

data DebugModeCli = DebugModeCli
  { sfont          :: !(Maybe String)
      -- ^ Font to use for the main game window.
  , smaxFps        :: !(Maybe Int)
      -- ^ Maximal frames per second.
      -- This is better low and fixed, to avoid jerkiness and delays
      -- that tell the player there are many intelligent enemies on the level.
      -- That's better than scaling AI sofistication down based
      -- on the FPS setting and machine speed.
  , snoDelay       :: !Bool
      -- ^ Don't maintain any requested delays between frames,
      -- e.g., for screensaver.
  , snoMore        :: !Bool
      -- ^ Auto-answer all prompts, e.g., for screensaver.
  , snoAnim        :: !(Maybe Bool)
      -- ^ Don't show any animations.
  , snewGameCli    :: !Bool
      -- ^ Start a new game, overwriting the save file.
  , ssavePrefixCli :: !(Maybe String)
      -- ^ Prefix of the save game file.
  , sfrontendStd   :: !Bool
      -- ^ Whether to use the stdout/stdin frontend.
  , sdbgMsgCli     :: !Bool
      -- ^ Show clients' internal debug messages.
  }
  deriving (Show, Eq)

defDebugModeCli :: DebugModeCli
defDebugModeCli = DebugModeCli
  { sfont = Nothing
  , smaxFps = Nothing
  , snoDelay = False
  , snoMore = False
  , snoAnim = Nothing
  , snewGameCli = False
  , ssavePrefixCli = Nothing
  , sfrontendStd = False
  , sdbgMsgCli = False
  }

instance Binary DebugModeCli where
  put DebugModeCli{..} = do
    put sfont
    put smaxFps
    put snoDelay
    put snoMore
    put snoAnim
    put snewGameCli
    put ssavePrefixCli
    put sfrontendStd
    put sdbgMsgCli
  get = do
    sfont <- get
    smaxFps <- get
    snoDelay <- get
    snoMore <- get
    snoAnim <- get
    snewGameCli <- get
    ssavePrefixCli <- get
    sfrontendStd <- get
    sdbgMsgCli <- get
    return DebugModeCli{..}