{-# OPTIONS_GHC -Wno-type-defaults #-}
module GameLogic
    ( chooseCharacter
    , applyEffect
    , EngineState
    , playerChoice
    , unitChoice
    , activePlayerChoice
    , continue
    , ChoiceTree(..)
    , ChoiceTree'(..)
    , buildChoiceTree
    , Token(..)
    , makeChoice
    , ctTree
    , ctDecisions
    , ctDecisionsL
    ) where

import GameModel
import Util (toMaybe, Never, (??), never)

import Data.Maybe (fromMaybe, mapMaybe, isJust)
import Data.List ( nub, intersperse )
import Data.List.NonEmpty as NonEmpty (NonEmpty, nonEmpty, toList, head, tail)
import Numeric.Natural (Natural)
import Lens.Micro
import Safe (atMay)

import Debug.Trace
import Mechanics (universalModifiers, globalHooks)
import Data.Monoid (Any(getAny), getSum)

-- | A version of `computeStat_` using `universalModifiers` as global modifiers
computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
computeStat = computeStat_ universalModifiers

-- | A version of `runHooks_` using `globalHooks` as the global hooks
runHooks :: Trigger -> BoardState -> BoardState
runHooks = runHooks_ globalHooks

data EngineState
  = PlayerChoice Player [Choice]
  | Roll
    Natural             -- ^ Number of dice
    Bool                -- ^ True = Xd6kh1, False = Xd6kl1
    (DieFace -> Choice) -- ^ Outcomes
  | Continue BoardState
  | Victory Player

playerChoice :: Player -> [Choice] -> EngineState
playerChoice = PlayerChoice

unitChoice :: CharacterIdentifier -> [Choice] -> EngineState
unitChoice = playerChoice . owner

activePlayerChoice :: BoardState -> [Choice] -> EngineState
activePlayerChoice = playerChoice . (^. activePlayer)

continue :: BoardState -> EngineState
continue = Continue

chooseCharacter :: BoardState -> Maybe EngineState
chooseCharacter board = playerChoice player <$> fmap toList (nonEmpty $ board ^.. possibleActivations)
  where
    player :: Player
    player = board ^. activePlayer
    possibleActivations :: SimpleFold BoardState Choice
    possibleActivations = untappedUnits . filtered ((== player) . owner) . to activateUnit
    activateUnit :: CharacterIdentifier -> Choice
    activateUnit cid = mkChoice ("Activate unit " ++ c) [ChooseActMove cid]
      where
        c = renderCharacterHandle board cid

forcedMovementValidDirections :: Natural -> Natural -> Point -> (Point, ForcedMoveType, Player) -> [OrthagonalDirection]
forcedMovementValidDirections w h currentLocation (locus, moveType, _) =
  case moveType of
    Shift -> orthagonalDirections
    Pull -> directionToLocus
    Push -> flipDirection <$> directionToLocus
  where
    directionToLocus = identifyCardinalDirection w h currentLocation locus

computePossibleSteps :: BoardState -> MovementSpecs -> Point -> [(Point, Natural)]
computePossibleSteps board (MovementSpecs {..}) currentLocation = mapMaybe getRemainingMov validDestinations
  where
    validDirections =
      maybe
        orthagonalDirections
        (usingBoardDimensions board forcedMovementValidDirections currentLocation)
        movForced
    validDestinations = mapMaybe (offsetB board currentLocation) validDirections
    currentTerrain = board ^. terrainAt currentLocation
    paysElevationCost = not (elem Stairs currentTerrain || elem Elevation currentTerrain || movFree)
    baseMovementCost = if Rough `elem` currentTerrain && not movFree then 2 else 1
    getRemainingMov :: Point -> Maybe (Point, Natural)
    getRemainingMov dest = toMaybe (not unreachable) (dest, remainingMovement)
      where
        (destCharacter, destTerrain) = board ^?! atPoint dest
        destElevated = Elevation `elem` destTerrain
        movingCharacter :: Maybe CharacterIdentifier
        movingCharacter = board ^? movingUnit . _Just . _1
        occupied = isJust destCharacter &&  destCharacter /= movingCharacter
        hostileOccupied = occupied && (owner <$> destCharacter) /= (owner <$> movingCharacter)
        hasMovementBlocker = Wall `elem` destTerrain || hostileOccupied
        totalCost = if paysElevationCost && destElevated then succ baseMovementCost else baseMovementCost
        unreachable = (movAmount < totalCost && not movMinimum) || hasMovementBlocker || (occupied && totalCost >= movAmount)
        remainingMovement = if unreachable then 0 else movAmount - totalCost

endOfMovementEffects :: MovementSpecs -> CharacterIdentifier -> [Effect]
endOfMovementEffects (MovementSpecs {..}) cid =
  [ConfirmMove]
  ++ [DropToken SpeedSlow cid | movSpendTokens   ]
  ++ [Event $   EndMove   cid | movEndMoveTrigger]

generateMovementChoice :: BoardState -> MovementSpecs -> CharacterIdentifier -> Point -> (Point, Natural) -> Choice
generateMovementChoice board specs@(MovementSpecs {..}) cid originalLocation (dest, remainingMov) =
  mkChoice
    (movVerb ++ ' ' : show direction)
    ( MoveTo dest
    : if remainingMov > 0
        then [Move updatedSpecs cid]
        else endOfMovementEffects specs cid
    )
  where
    direction = fromMaybe North $ usingBoardDimensions board identifyDirection originalLocation dest
    updatedSpecs = specs & movAmountL .~ remainingMov & movMinimumL .~ False

dontAct :: Choice
dontAct = mkChoice "Do nothing" []

applyEffect :: Effect -> BoardState -> EngineState
applyEffect NoOp board = continue board
applyEffect StartTurn board = case (chooseCharacter board, chooseCharacter opponentTurn) of
  (Just pickUnits, _) -> pickUnits
  (_, Just _) -> continue $ opponentTurn <++ [StartTurn]
  _ -> continue advanceRound
  where
    opponentTurn = switchActivePlayer board
    advanceRound =
      if board ^. roundNumber == 6
        then board
        else nextRound board
applyEffect (Event trigger) board = continue $ runHooks trigger board
applyEffect (ChooseActMove cid) _ = unitChoice cid [moveFirst, actFirst]
  where
    moveFirst = mkChoice "Move first" [basicMove cid, ActOrMove cid, EndTurn cid]
    actFirst = mkChoice "Act first" [Act cid, basicMove cid, EndTurn cid]
applyEffect (ActOrMove cid) _ = unitChoice cid [moveAgain, nowAct]
  where
    moveAgain = mkChoice "Move again" [basicMove cid]
    nowAct = mkChoice "Act" [Act cid]
applyEffect (InitMove (ProtoMovementSpecs {..}) cid) board = continue $ case adjustedFm of
  Just movForced -> changeMovingUnit board cid <++ [Move (MovementSpecs {..}) cid]
  Nothing -> board
  where
    movFree = getAny $ computeStat board cid FreeMove
    adjustedFm = case movForced' of
      Nothing -> Just Nothing
      Just (Right p, fmType, forcer) -> Just $ Just (p, fmType, forcer)
      Just (Left locusUnit, fmType, forcer) -> case unitPosition board locusUnit of
        Just p -> Just $ Just (p, fmType, forcer)
        Nothing -> Nothing -- Locus unit died before pull began
    characterMovement = board ^?! ixCharacter cid . to (getSpeed movFree)
    movAmount = fromMaybe characterMovement movAmount'
applyEffect (Move (MovementSpecs {movAmount = 0}) _) board = continue $ board <++ [ConfirmMove]
applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board cid of
  Nothing -> -- Unit died mid-move
    if movEndMoveTrigger
      then continue $ board <++ [endMoveTrigger]
      else continue board
  Just originalLocation ->
    let
      possibleSteps = computePossibleSteps board specs originalLocation
      movementChoices =
        generateMovementChoice
          board
          specs
          cid
          originalLocation
          <$> possibleSteps
      -- Possibilities:
      -- Standard move, first step, movement possible         (Standard movement choices + Don't move)
      -- Standard move, first step, movement impossible       (Silent don't move)
      -- Standard move, subsequent step, movement possible    (Standard movement choices + Finish moving)
      -- Standard move, subsequent step, movement impossible  (Silent finish moving)
      -- Compelled move, first step, movement possible        (Standard movement choices)
      -- Compelled move, first step, movement impossible      (Silent finish moving)
      -- Compelled move, subsequent step, movement possible   (Standard movement choices)
      -- Compelled move, subsequent step, movement impossible (Silent finish moving)
    in if null possibleSteps
      then continue $ board <++ if movMinimum
        then dontMoveEffects
        else finishMoveEffects
      else choiceBuilder $ (++ movementChoices) $ if movCompelled
        then []
        else if movMinimum
          then [dontMoveChoice]
          else [finishMoveChoice]
  where
    dontMoveEffects   = [ConfirmMove]
    dontMoveChoice    = mkChoice "Don't move" dontMoveEffects
    finishMoveEffects = endOfMovementEffects specs cid
    finishMoveChoice  = mkChoice "Finish moving" finishMoveEffects
    endMoveTrigger = Event $ EndMove cid
    choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3
applyEffect (MoveTo dest) board = continue $ moveUnit dest board
applyEffect (DropToken token unit) board = continue $
  ixCharacter unit %~ removeTokenInCategory token $ board
applyEffect ConfirmMove board = continue $ finalizeMove board
applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actionsL . each . to ($ cid) of
  [] -> continue board
  act -> unitChoice cid (dontAct : act)
applyEffect (Target fromPerspective range eligability ultimateEffect) board = unitChoice fromPerspective choices
  where
    locus = unitPosition board fromPerspective
    potentialUnits = maybe [] (cidsInRange board range) locus
    eligableUnits = filter (eligability board) potentialUnits
    buildChoice targetCid =
      mkChoice
        ("Target " ++ renderCharacterHandle board targetCid)
        [BodyBlock targetCid ultimateEffect]
    choices = buildChoice <$> eligableUnits
applyEffect (BodyBlock targettedUnit ultimateEffect) board = if canBB then allChoices else cantBBResult
  where
    potentialBBers = fromMaybe [] $ adjacentAllies board targettedUnit
    canBB = isNecromancer targettedUnit && potentialBBers /= []
    buildChoice bber = mkChoice ("Bodyblock with " ++ renderCharacterHandle board bber) (ultimateEffect bber)
    dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect targettedUnit)
    bbChoices = buildChoice <$> potentialBBers
    allChoices = unitChoice targettedUnit $ dontBodyblock : bbChoices
    cantBBResult = continue $ board <++ ultimateEffect targettedUnit
applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRolled keepHighest consequence
  where
    attacker' = board ^? ixCharacter attacker
    defender' = board ^? ixCharacter defender
    attackerDieBonus = computeStat board attacker AttackDice
    defenderDieBonus = computeStat board defender DefenseDice
    attackerPosition = unitPosition board attacker
    defenderPosition = unitPosition board defender
    potentialCoverDirections =
      usingBoardDimensions board identifyCardinalDirection <$> defenderPosition <*> attackerPosition
    potentialCoverLocations =
      fromMaybe [] $
      (mapMaybe . offsetB board <$> defenderPosition) <*> potentialCoverDirections
    coveringTerrain = nub $ (\p -> board ^. terrainAt p) =<< potentialCoverLocations
    defenderElevated = isElevated board defender
    validCover = if defenderElevated then [Wall] else [Wall, Elevation]
    hasCover = or $ (==) <$> validCover <*> coveringTerrain
    coverBonus = if not (melee attack) && hasCover then 1 else 0
    netDice = getSum $ attackerDieBonus - (defenderDieBonus + coverBonus)
    actualDiceRolled = fromIntegral $ if netDice <= 0 then 2 else netDice
    keepHighest = netDice > 0
    toHit = maybe 1 getDefense defender'
    attackerStrWeak = fromMaybe 0 $ attacker' ^? _Just . tokenCount . ofToken StrWeak
    tokenDamageModifier
      | attackerStrWeak < 0 = \x -> x-1
      | attackerStrWeak > 0 = (+1)
      | otherwise = id
    missDamage = InflictDamage (damageType attack) (tokenDamageModifier 1) defender
    hitDamage = InflictDamage (damageType attack) (tokenDamageModifier $ damageAmount attack) defender
    onMiss = [missDamage]
    onHit = hitDamage : otherEffects attack
    onHeadshot = onHit ++ headshotEffects attack
    consequence Six
      | not $ null $ headshotEffects attack = mkChoice "Headshot!" onHeadshot
    consequence r
      | r >= toHit = mkChoice "Hit!" onHit
      | otherwise = mkChoice "Graze" onMiss
applyEffect (InflictDamage damageType incomingAmount recipient) board = continue $ board' <++ damageEffects
  where
    incomingAmount' = fromIntegral incomingAmount
    recipient' = board ^? ixCharacter recipient
    armorType = maybe NoArmor (^. baseStats . armL) recipient'
    armorReduction = if armorType `blocks` damageType then 1 else 0
    tokenReduction = signum $ fromMaybe 0 $ recipient' ^? _Just . tokenCount . ofToken VitalVulnr
    totalReduction = if damageType == DevilDamage then min 0 tokenReduction else armorReduction + tokenReduction
    netDamage
      | totalReduction >= incomingAmount' = 0
      | otherwise = fromIntegral $ incomingAmount' - totalReduction
    board' = trace ("iA': " ++ show incomingAmount' ++ " | aR: " ++ show armorReduction ++ " | r: " ++ show recipient) $ board
      & ixCharacter recipient %~ clearUpToNTokens Health netDamage
      & if incomingAmount' > armorReduction
        then ixCharacter recipient %~ removeTokenInCategory VitalVulnr
        else id
    updatedHealth = fromMaybe 9999 $ board' ^? ixCharacter recipient . tokenCount . ofToken Health
    dead = updatedHealth == 0
    damageEffects = [Event $ TookDamage recipient, if dead then Kill recipient else NoOp]
applyEffect (InflictTokens tokenType numberToAdd target) board = continue $ board &
  ixCharacter target . tokenCount . ofToken tokenType +~ numberToAdd
applyEffect (Kill unit) board = if isNecromancer unit
  then Victory $ otherPlayer $ owner unit
  else continue $ unitRemoved <++ [deathAlert]
  where
    deathLocation = unitPosition board unit
    unitRemoved = removeUnit unit board
    deathAlert = maybe NoOp (Event . Died unit) deathLocation
applyEffect (EndTurn cid) board = continue $ afterPlayerSwitched <++ [StartTurn]
  where
    afterUnitTapped = board & ixCharacter cid %~ tap
    afterPlayerSwitched = switchActivePlayer afterUnitTapped

data ChoiceTree' inp where
  Node :: BoardState -> Player -> [ChoiceTreeChoice] -> ChoiceTree' Int
  Random ::
    Natural             -- ^ Number of dice
    -> Bool                -- ^ True = Xd6kh1, False = Xd6kl1
    -> (DieFace -> ChoiceTreeChoice) -- ^ Outcomes
    -> ChoiceTree' DieFace
  EndOfGame :: Maybe Player -> ChoiceTree' Never

data ChoiceTree = forall i. ChoiceTree (ChoiceTree' i)

instance Show (ChoiceTree' a) where
  show (EndOfGame Nothing) = "It's a draw!"
  show (EndOfGame (Just player)) = show player ++ " Wins!"
  show (Node board player choices) = show board ++ "\n\n\n[" ++ show player ++ "]\n" ++ viewChoices
    where
      choicesText :: [String]
      choicesText = firstDecisions choices
      numberedChoices :: [String]
      numberedChoices = zipWith (\n c -> show (1+n) ++ ") " ++ c) [0..] choicesText
      viewChoices :: String
      viewChoices = mconcat $ intersperse "\n" numberedChoices
  show (Random numDice rollType _) = "Roll " ++ show numDice ++ "d6 and take the " ++ (if rollType then "highest" else "lowest")

instance Show ChoiceTree where
  show (ChoiceTree t) = show t

data ChoiceTreeChoice = ChoiceTreeChoice (NonEmpty String) ChoiceTree

firstDecisions :: [ChoiceTreeChoice] -> [String]
firstDecisions choices = nub $ choices ^.. each . ctDecisionsL . to NonEmpty.head

ctDecisions :: ChoiceTreeChoice -> NonEmpty String
ctDecisions (ChoiceTreeChoice decs _) = decs
ctDecisionsL :: Lens' ChoiceTreeChoice (NonEmpty String)
ctDecisionsL f (ChoiceTreeChoice decs choices) = ChoiceTreeChoice <$> f decs ?? choices
ctTree :: ChoiceTreeChoice -> ChoiceTree
ctTree (ChoiceTreeChoice _ tree) = tree

convertChoice :: BoardState -> Choice -> ChoiceTreeChoice
convertChoice board choice =
  ChoiceTreeChoice
    (decisionSequence choice)
    (buildChoiceTree $ board <++ effects choice)

buildChoiceTree :: BoardState -> ChoiceTree
buildChoiceTree board = case popEffect board of
    Nothing -> ChoiceTree $ EndOfGame Nothing
    Just (effect, board') ->
      case applyEffect effect board' of
        PlayerChoice chooser choices -> ChoiceTree $ Node board' chooser (convertChoice board' <$> choices)
        Roll n d outcomes -> ChoiceTree $ Random n d (convertChoice board' <$> outcomes)
        Continue board'' -> buildChoiceTree board''
        Victory player -> ChoiceTree $ EndOfGame $ Just player

makeChoice :: n -> ChoiceTree' n -> Maybe ChoiceTree
makeChoice n (EndOfGame _) = never n
makeChoice die (Random _ _ outcomes) = Just $ ctTree $ outcomes die
makeChoice indx (Node b p options) = trimmedChoices <$> providedDecision
  where
    providedDecision :: Maybe String
    providedDecision = firstDecisions options `atMay` (indx - 1)
    matchingChoices :: String -> [ChoiceTreeChoice]
    matchingChoices decision = filter ((== decision) . NonEmpty.head . ctDecisions) options
    trimChoice :: ChoiceTreeChoice -> Either ChoiceTree ChoiceTreeChoice
    trimChoice (ChoiceTreeChoice decs tree) =
      case nonEmpty $ NonEmpty.tail decs of
        Just newDecs -> Right $ ChoiceTreeChoice newDecs tree
        Nothing -> Left tree
    trimmedChoices :: String -> ChoiceTree
    trimmedChoices decision = either id (ChoiceTree . Node b p) $ traverse trimChoice (matchingChoices decision)