maleghast-engine/src/GameModel.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Eta reduce" #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module GameModel
    ( DieFace(..)
    , bestOrWorst
    , EnvTile(..)
    , Armor(..)
    , DamageType(..)
    , Attack(Attack)
    , headshotEffectsL
    , meleeL
    , otherEffectsL
    , damageTypeL
    , damageAmountL
    , headshotEffects
    , melee
    , otherEffects
    , damageType
    , damageAmount
    , simpleRangedAttack
    , simpleMeleeAttack
    , blocks
    , Point(..)
    , Trigger(..)
    , OrthagonalDirection(..)
    , orthagonalDirections
    , offset
    , cardinalDirections
    , offsetCardinal
    , identifyDirection
    , identifyCardinalDirection
    , adjacentPoints
    , distanceCardinal
    , MovementSpecs(..)
    , movVerbL
    , movFreeL
    , movMinimumL
    , movAmountL
    , movForcedL
    , movSpendTokensL
    , movEndMoveTriggerL
    , movCompelledL
    , Effect(..)
    , Player(..)
    , PPair
    , forPlayer
    , everybody
    , otherPlayer
    , Token(..)
    , ofToken
    , Stat(..)
    , BaseStats(..)
    , nameL
    , hpL
    , movL
    , dfL
    , armL
    , traitsL
    , actionsL
    , instantiate
    , Character(..)
    , baseStats
    , movedThisRound
    , tokenCount
    , removeTokenInCategory
    , clearUpToNTokens
    , getSpeed
    , getDefense
    , CharacterIdentifier
    , owner
    , ownerL
    , isNecromancer
    , showCID
    , untapped
    , BoardState
    , atPoint
    , tiles
    , width
    , height
    , characters
    , soul
    , movingUnit
    , roundNumber
    , turn
    , effectStack
    , activePlayer
    , switchActivePlayer
    , popEffect
    , usingBoardDimensions
    , offsetB
    , cidsInRange
    , isAlive
    , pushEffects
    , unitPosition
    , terrainAt
    , characterAt
    , adjacentUnits
    , adjacentAllies
    , isElevated
    , removeUnit
    , nextRound
    , changeMovingUnit
    , moveUnit
    , finalizeMove
    , (<++)
    , Choice
    , decisionSequenceL
    , effectsL
    , decisionSequence
    , effects
    , mkChoice
    , prependDecision
    , tap
    , characterLocations
    , eachCID
    , ixCharacter
    , ofPlayer
    , untappedUnits
    , newBoard
    , characterHandle
    , renderCharacterHandle
    , ForcedMoveType(..)
    , flipDirection
    , ProtoMovementSpecs(..)
    , basicMove
    , forcedMove
    , allStatsAreMonoids
    , HasMonoidInstance
    , Hook(..)
    , hookTriggerL
    , hookEffectL
    , Modifier(..)
    , Trait(..)
    , traitNameL
    , traitHooksL
    , traitModifiersL
    , computeStat_
    , runHooks_
    ) where

import Util (toMaybe, dup, secondClassLensNames, (??))

import Control.Applicative (Alternative (..))
import Control.Arrow ((>>>), Arrow (second))
import Control.Monad (join, mfilter, zipWithM)
import Data.Ix (inRange)
import Data.List (intersperse, elemIndex)
import Data.List.NonEmpty as NonEmpty (cons, NonEmpty, singleton)
import Data.Maybe (mapMaybe, catMaybes)
import Numeric.Natural (Natural)
import Safe (headMay)
import Lens.Micro
import Data.Monoid (Sum, Any)
import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics)
import Lens.Micro.Extras (preview)
import Data.Data ((:~:)(..))
import System.Random (Random(..))

data DieFace = One | Two | Three | Four | Five | Six
  deriving (Eq, Ord, Enum, Read)

instance Random DieFace where
  randomR (low, hi) g = (toEnum r, g')
    where
      lowN = fromEnum low
      hiN  = fromEnum hi
      (r, g') = randomR (lowN, hiN) g
  random g = randomR (One, Six) g

bestOrWorst :: Bool -> [DieFace] -> DieFace
bestOrWorst True = maximum
bestOrWorst False = minimum

instance Show DieFace where
  show One   = "1"
  show Two   = "2"
  show Three = "3"
  show Four  = "4"
  show Five  = "5"
  show Six   = "6"

instance Num DieFace where
  One   + One   = Two
  Two   + One   = Three
  Three + One   = Four
  Four  + One   = Five
  One   + Two   = Three
  Two   + Two   = Four
  Three + Two   = Five
  Two   + Three = Five
  _     + _     = Six

  Six   - One   = Five
  Six   - Two   = Four
  Six   - Three = Three
  Six   - Four  = Two
  Five  - One   = Four
  Five  - Two   = Three
  Five  - Three = Two
  Four  - One   = Three
  Four  - Two   = Two
  _     - _     = One

  One   * n     = n
  n     * One   = n
  Two   * n     = n + n
  n     * Two   = n + n
  _     * _     = Six

  abs n = n

  signum = const One

  fromInteger 1 = One
  fromInteger 2 = Two
  fromInteger 3 = Three
  fromInteger 4 = Four
  fromInteger 5 = Five
  fromInteger 6 = Six
  fromInteger n = error ("The integer literal " ++ show n ++ " is not a face on a d6")

type CharacterIdentifier = (Player, Int)

owner :: CharacterIdentifier -> Player
owner = fst

ownerL :: Lens' CharacterIdentifier Player
ownerL = _1

isNecromancer :: CharacterIdentifier -> Bool
isNecromancer = snd >>> (== 0)

showCID :: CharacterIdentifier -> Char
showCID (cidOwner, idx) = (if cidOwner == Max then upperLetters else lowerLetters) !! idx
  where
    lowerLetters = "abcdefghijklmnopqrstuvwxyz"
    upperLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

data Player
  = Max
  | Min
  deriving (Eq, Ord, Show)

data PPair t = PPair t t

toPPair :: (Player -> t) -> PPair t
toPPair f = PPair (f Min) (f Max)

forPlayer :: Player -> Lens' (PPair a) a
forPlayer Min f (PPair p_min p_max) = PPair <$> f p_min ?? p_max
forPlayer Max f (PPair p_min p_max) = PPair p_min <$> f p_max

everybody :: Traversal (PPair a) (PPair b) a b
everybody f (PPair p_min p_max) = PPair <$> f p_min <*> f p_max

data EnvTile
  = Wall
  | Rough
  | Hazard
  | Elevation
  | Stairs
  deriving (Enum, Read, Eq, Show)

data Armor
  = NoArmor
  | PhysicalArmor
  | MagicArmor
  | SuperArmor
  deriving (Enum, Read, Eq)

instance Show Armor where
  show NoArmor       = "-"
  show PhysicalArmor = "PHY"
  show MagicArmor    = "MAG"
  show SuperArmor    = "SUP"

data DamageType
  = BasicDamage
  | SpecialDamage
  | Unblockable
  | DevilDamage
  deriving (Enum, Read, Eq, Show)

blocks :: Armor -> DamageType -> Bool
blocks _ Unblockable = False
blocks _ DevilDamage = False
blocks PhysicalArmor BasicDamage = True
blocks MagicArmor SpecialDamage = True
blocks SuperArmor _ = True
blocks _ _ = False

newtype Point = Point Natural
  deriving (Show, Read, Eq, Ord)

enumeratePoints :: Natural -> Natural -> [Point]
enumeratePoints w h = Point <$> [0..w * h - 1]

data Trigger
  = TurnStart
  | TookDamage CharacterIdentifier
  | Died CharacterIdentifier Point
  | EndMove CharacterIdentifier
  deriving (Eq, Show)

data OrthagonalDirection
  = North
  | East
  | South
  | West
  deriving (Enum, Read, Eq, Ord, Show)

orthagonalDirections :: [OrthagonalDirection]
orthagonalDirections = [North, East, South, West]

flipDirection :: OrthagonalDirection -> OrthagonalDirection
flipDirection North = South
flipDirection East  = West
flipDirection South = North
flipDirection West  = East

offset :: Natural -> Natural -> Point -> OrthagonalDirection -> Maybe Point
offset width _      (Point indx) North = toMaybe (indx >= width)                  (Point $ indx - width)
offset width height (Point indx) South = toMaybe (indx `div` width < height - 1) (Point $ indx + width)
offset width _      (Point indx) West  = toMaybe (indx `rem` width > 0)          (Point $ indx - 1)
offset width _      (Point indx) East  = toMaybe (indx `rem` width < width - 1)  (Point $ indx + 1)

identifyDirection :: Natural -> Natural -> Point -> Point -> Maybe OrthagonalDirection
identifyDirection w h from to = headMay $ filter ((== Just to) . offset w h from) orthagonalDirections

identifyCardinalDirection :: Natural -> Natural -> Point -> Point -> [OrthagonalDirection]
identifyCardinalDirection w _ from to = northOrSouth ++ eastOrWest
  where
    (fromX, fromY) = coordinates w from
    (toX, toY) = coordinates w to
    northOrSouth
      | fromY < toY = [South]
      | fromY > toY = [North]
      | otherwise   = [     ]
    eastOrWest
      | fromX < toX = [East]
      | fromX > toX = [West]
      | otherwise   = [    ]

cardinalDirections :: [[OrthagonalDirection]]
cardinalDirections = [[North], [North, East], [East], [South, East], [South], [South, West], [West], [North, West]]

offsetCardinal :: Natural -> Natural -> Point -> [OrthagonalDirection] -> Maybe Point
offsetCardinal w h point = foldr ((=<<) . flip (offset w h)) (Just point)

adjacentPoints :: Natural -> Natural -> Point -> [Point]
adjacentPoints w h center = mapMaybe (offsetCardinal w h center) cardinalDirections

coordinates :: Natural -> Point -> (Natural, Natural)
coordinates w (Point x) = (x `rem` w, x `div` w)

distanceCardinal :: Natural -> Natural -> Point -> Point -> Natural
distanceCardinal w _ a b = max xDist yDist
  where
    (aX, aY) = coordinates w a
    (bX, bY) = coordinates w b
    xDist = max aX bX - min aX bX
    yDist = max aY bY - min aY bY

data ForcedMoveType
  = Push
  | Pull
  | Shift
  deriving (Show, Eq)

data Token a where
  StrWeak    :: Token Int
  VitalVulnr :: Token Int
  SpeedSlow  :: Token Int
  Berserk    :: Token Natural
  Doom       :: Token Natural
  Plague     :: Token Natural
  Mutation   :: Token Natural
  Reload     :: Token Natural
  Health     :: Token Natural


-- | Details which characterize any kind of movement
data MovementSpecs = MovementSpecs
  { movVerb            :: String                 -- ^ The verb used to describe this move, e.g. "Move" or "Step"
  , movFree            :: Bool                   -- ^ Indicates whether moving with free movement
  , movMinimum         :: Bool                   -- ^ This movement gets to move at least 1 tile regardless of cost
  , movAmount          :: Natural                -- ^ The amount of MV available to spend
  , movForced          :: Maybe (Point, ForcedMoveType, Player)   -- ^ If this is a forced move, the locus, direction, and compelling player
  , movSpendTokens     :: Bool                   -- ^ Whether this movement uses up movement tokens
  , movEndMoveTrigger  :: Bool                   -- ^ Whether this movement should trigger "after MOVE" effects
  , movCompelled       :: Bool                   -- ^ If movement can be stopped prematurely
  }

-- | A version of `MovementSpecs` where some values will be populated dynamically
data ProtoMovementSpecs = ProtoMovementSpecs
  { movVerb            :: String -- ^ The verb used to describe this move, e.g. "Move" or "Step"
  , movFree'           :: Maybe Bool -- ^ Whether moving with free movement, or Nothing to compute at init
  , movMinimum         :: Bool -- ^ This movement gets to move at least 1 tile regardless of cost
  , movAmount'         :: Maybe Natural -- ^ How many spaces to move, or Nothing to compute at init
  , movForced'         :: Maybe (Either CharacterIdentifier Point, ForcedMoveType, Player) -- ^ If this is a forced move, the locus, direction, and compelling player
  , movSpendTokens     :: Bool -- ^ Whether this movement spends speed/slow tokens
  , movEndMoveTrigger  :: Bool -- ^ Whether this movement should trigger "after MOVE" effects
  , movCompelled       :: Bool -- ^ If movement can be stopped prematurely
  }

basicMove :: CharacterIdentifier -> Effect
basicMove = InitMove $ ProtoMovementSpecs
  { movVerb = "Move"
  , movFree' = Nothing
  , movMinimum = True
  , movAmount' = Nothing
  , movForced' = Nothing
  , movSpendTokens = True
  , movEndMoveTrigger = True
  , movCompelled = False
  }

forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> CharacterIdentifier -> Effect
forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs
  { movVerb = show fmType
  , movFree' = Just True
  , movMinimum = False
  , movAmount' = Just amt
  , movForced' = Just (locus, fmType, compeller)
  , movSpendTokens = False
  , movEndMoveTrigger = False
  , movCompelled = True
  }

data Effect

  -- | Does nothing
  = NoOp

  | StartTurn

  -- | Send some trigger to every Unit
  | Event Trigger

  -- | Active player chooses whether they want to move or act first
  | ChooseActMove CharacterIdentifier

  -- | Active player may choose whether they want to act or move
  | ActOrMove CharacterIdentifier

  -- | Mark the start of movement
  -- Can be finalized later with FinalizeMove
  | InitMove ProtoMovementSpecs CharacterIdentifier

  -- | Active player may MOVE this character
  -- Should evaluate to a choice for every OrthagonalDirection which is valid to move in,
  -- where each choice includes another Move.  Additionally, the user may choose
  -- to neglect to move.  The first move of a turn should also push an EndMove onto the
  -- stack.
  | Move
    MovementSpecs -- ^ Details about the movement
    CharacterIdentifier -- ^ Which character is being moved

  -- | Pick up a character and put them down on another space
  -- Should trigger effects like overwatch and hazard damage
  | MoveTo Point

  -- | Remove up to one token from the given category from a unit
  | forall n. Num n => DropToken
    (Token n) -- ^ The token category to drop from
    CharacterIdentifier -- ^ Which character drops a token

  -- | Confirms a Move, placing the unit in the target space
  | ConfirmMove

  -- | Allow a character to Act
  | Act CharacterIdentifier

  -- | Target a unit in a given range, then run a different event
  | Target
    CharacterIdentifier -- ^ ACTing unit
    (Natural, Natural) -- ^ Range
    (BoardState -> CharacterIdentifier -> Bool) -- ^ Target filter
    (CharacterIdentifier -> [Effect]) -- ^ Ultimate effect

  -- | Check if a character can body block
  -- If they can, offer a choice of target to the targetted player.  Pass result on to
  -- the effect.
  | BodyBlock CharacterIdentifier (CharacterIdentifier -> [Effect])

  -- | Resolve an attack
  | ResolveAttack
    CharacterIdentifier -- ^ Attacker
    Attack -- ^ Attack information
    CharacterIdentifier -- ^ Target

  | InflictDamage
    DamageType
    Natural             -- ^ Damage amount
    CharacterIdentifier -- ^ Target

  | forall n. Num n => InflictTokens
    (Token n) -- ^ Token kind
    n -- ^ Token amount
    CharacterIdentifier -- ^ Target

  | Kill CharacterIdentifier

  -- | Tap the active unit, change the active player
  | EndTurn CharacterIdentifier

data Attack = Attack
  { headshotEffects :: [Effect]
  , melee           :: Bool
  , otherEffects    :: [Effect]
  , damageType      :: DamageType
  , damageAmount    :: Natural
  }

simpleRangedAttack :: [Effect] -> DamageType -> Natural -> Attack
simpleRangedAttack = Attack [] False

simpleMeleeAttack :: [Effect] -> DamageType -> Natural -> Attack
simpleMeleeAttack = Attack [] True

data Choice = Choice
  { decisionSequence :: NonEmpty String
  , effects :: [Effect]
  }

otherPlayer :: Player -> Player
otherPlayer Max = Min
otherPlayer Min = Max

data Stat a where
  AttackDice  :: Stat (Sum Int)
  DefenseDice :: Stat (Sum Int)
  FreeMove    :: Stat Any

statEq :: Stat a -> Stat b -> Maybe (a :~: b)
statEq AttackDice  AttackDice  = Just Refl
statEq DefenseDice DefenseDice = Just Refl
statEq FreeMove    FreeMove    = Just Refl
statEq _           _           = Nothing

data HasMonoidInstance a = forall m. Monoid m => HasMonoidInstance (a :~: m)

allStatsAreMonoids :: Stat a -> HasMonoidInstance a
allStatsAreMonoids AttackDice  = HasMonoidInstance Refl
allStatsAreMonoids DefenseDice = HasMonoidInstance Refl
allStatsAreMonoids FreeMove    = HasMonoidInstance Refl

data BaseStats = BaseStats
  { name        :: String
  , hp          :: Natural
  , mov         :: Natural
  , df          :: DieFace
  , arm         :: Armor
  , traits      :: [Trait]
  , actions     :: [CharacterIdentifier -> Choice]
  }

-- | Some effect which is activated by some trigger event
data Hook h = Hook
  { hookTrigger :: Trigger -- ^ The trigger which should activate this effect
  -- | What this effect does.  Recieves board & this character's CID
  , hookEffect  :: BoardState -> h
  }

-- | A modifier which conditionally affects thet value of some stat for a unit
data Modifier = forall a. Monoid a => Modifier
  { modifierStat   :: Stat a -- ^ Which stat this modifier effects
  -- | What the effects of this modifier are
  , modifierEffect :: BoardState -> CharacterIdentifier -> a
  }

queryModifier :: BoardState -> CharacterIdentifier -> Stat a -> Modifier -> a
queryModifier board cid queryStat (Modifier {..}) = case queryStat `statEq` modifierStat of
  Just Refl -> modifierEffect board cid
  Nothing -> case allStatsAreMonoids queryStat of HasMonoidInstance Refl -> mempty

-- | A passive trait on a unit
-- Can affect a unit or surrounding units by directly and conditionally modifying that
-- units stats, or by running certain 'Effect's on a given trigger
data Trait = Trait
  { traitName      :: String -- ^ The name of this trait, e.g. "Formation"
  , traitHooks     :: [Hook (CharacterIdentifier -> [Effect])] -- ^ Any hooks which this trait needs
  , traitModifiers :: [Modifier] -- ^ Any modifiers this trait imposes
  }

instance Show BaseStats where
  show stats = "===== " ++ name stats ++ " =====\nMV: " ++ show (mov stats) ++  "      DF: " ++ show (df stats) ++ "+      ARM: " ++ show (arm stats)

newtype TokenCount = TokenCount (forall n. Token n -> n)

instance Show TokenCount where
  show tc = mconcat $ intersperse "\n" $ filter (/=[])
    [ showHealth
    , showReload
    , " "
    , showDualTokens ("Strength", "Weakness") ("+1 damage", "-1 damage") StrWeak
    , showDualTokens ("Vitality", "Vulnerability") ("take -1 damage", "take +1 damage") VitalVulnr
    , showDualTokens ("Speed", "Slow") ("move +2 spaces", "move at most one space") SpeedSlow
    , showMonoToken "Berserk" "splash self after ACTing" Berserk
    , showMonoToken "Doom" "die after round 4" Doom
    , showMonoToken "Plague" "take 1 damage / turn" Plague
    , showMonoToken "Mutation" "spend as any other token" Mutation
    ]
    where
      showTokensInner :: Integral n => String -> String -> n -> String
      showTokensInner name effectText count
        | count > 0 = name ++ ": " ++ replicate (fromIntegral count) '*' ++ if effectText /= "" then " (" ++ effectText ++ ")" else ""
        | otherwise = ""
      showMonoToken name effectText t = showTokensInner name effectText (tc ^. ofToken t)
      showDualTokens (goodName, badName) (goodEffect, badEffet) t
        | count >= 0 = showTokensInner goodName goodEffect count
        | otherwise = showTokensInner badName badEffet (negate count)
        where
          count = tc ^. ofToken t
      hp  = fromIntegral $ tc ^. ofToken Health
      rel = fromIntegral $ tc ^. ofToken Reload
      showHealth
        | hp == 0 = "HP: 💀"
        | otherwise = "HP: " ++ replicate hp '*'
      showReload
        | rel == 0 = []
        | rel == 1 = "Needs reload!"
        | rel == 2 = "Needs reload! (Twice)"
        | otherwise = "Needs reload! (" ++ replicate rel '*' ++ ")"

tokenEq :: Token a -> Token b -> Maybe (a :~: b)
tokenEq StrWeak    StrWeak    = Just Refl
tokenEq VitalVulnr VitalVulnr = Just Refl
tokenEq SpeedSlow  SpeedSlow  = Just Refl
tokenEq Berserk    Berserk    = Just Refl
tokenEq Doom       Doom       = Just Refl
tokenEq Plague     Plague     = Just Refl
tokenEq Mutation   Mutation   = Just Refl
tokenEq Reload     Reload     = Just Refl
tokenEq Health     Health     = Just Refl
tokenEq _          _          = Nothing

ofToken :: forall n. Token n -> Lens' TokenCount n
ofToken token f (TokenCount initCount) = update' <$> innerMapped
  where
    innerMapped = f $ initCount token
    update :: n -> forall m. Token m -> m
    update newTokenVal queryToken =
      case tokenEq token queryToken of
        Just Refl -> newTokenVal
        Nothing -> initCount queryToken
    update' :: n -> TokenCount
    update' newVal = TokenCount $ update newVal

data Character = Character
  { _baseStats        :: BaseStats
  , _movedThisRound   :: Bool
  , _tokenCount       :: TokenCount
  }

instance Show Character where
  show c = show (_baseStats c) ++ (if _movedThisRound c then "\n(already moved this round)" else "\n") ++ '\n' : show (_tokenCount c)

noTokens :: TokenCount
noTokens = TokenCount noTokens'
  where
    noTokens' :: Token n -> n
    noTokens' StrWeak    = 0
    noTokens' VitalVulnr = 0
    noTokens' SpeedSlow  = 0
    noTokens' Berserk    = 0
    noTokens' Doom       = 0
    noTokens' Plague     = 0
    noTokens' Mutation   = 0
    noTokens' Reload     = 0
    noTokens' Health     = 0

data BoardState = BoardState
  { _tiles :: [(Maybe CharacterIdentifier, [EnvTile])]
  , _width :: Natural
  , _height :: Natural
  , _characters :: PPair [Character]
  , _soul :: PPair Natural
  , _movingUnit :: Maybe (CharacterIdentifier, Point)
  , _roundNumber :: Natural
  , _turn :: Player
  , _effectStack :: [Effect]
  }

makeLenses ''Character

makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''Attack

makeLensesWith secondClassLensNames ''Choice

makeLenses ''BoardState

makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''BaseStats

makeLensesWith secondClassLensNames ''MovementSpecs

makeLensesWith secondClassLensNames ''Hook

makeLensesWith secondClassLensNames ''Trait

instantiate :: BaseStats -> Character
instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats

clearUpToNTokens :: (Num a, Ord a) => Token a -> a -> Character -> Character
clearUpToNTokens t n = tokenCount . ofToken t %~ clearUpToN n
  where
    clearUpToN toClear currentCount
      | currentCount > 0 && toClear < 0 || currentCount < 0 && toClear > 0 = currentCount
      | abs currentCount > abs toClear = currentCount - toClear
      | otherwise = 0

removeTokenInCategory :: Num a => Token a -> Character -> Character
removeTokenInCategory t = tokenCount . ofToken t %~ minusSignum
  where
    minusSignum n = n - signum n

getSpeed :: Bool -> Character -> Natural
getSpeed preventReducions c
  | spdTokenCount > 0 = 2 + baseSpeed
  | spdTokenCount < 0 && not preventReducions = 1
  | otherwise         = baseSpeed
  where
    baseSpeed = c ^. baseStats . movL
    spdTokenCount = c ^. tokenCount . ofToken SpeedSlow

getDefense :: Character -> DieFace
getDefense = df . _baseStats

tap :: Character -> Character
tap = movedThisRound .~ True

untapped :: Character -> Bool
untapped = not . _movedThisRound

untap :: Character -> Character
untap = movedThisRound .~ False

-- | Compute a stat for a unit by accumulating the modifiers for the stat in all places
--
-- This includes so called global modifiers, but in order to keep game rules seperate from
-- the model, global modifiers must be provided as the first argument.
computeStat_ :: [Modifier] -> BoardState -> CharacterIdentifier -> Stat a -> a
computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of
  HasMonoidInstance Refl ->
    let
      queryStatsL = each . to (queryModifier board cid stat)
      globalBonus = globalModifiers ^. queryStatsL
      traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL
    in globalBonus <> traitBonus

-- | Activate all of the relevant hooks on the board
--
-- Searches through all hooks in traits and global hooks, accumulates all their effects,
-- then adds all the resulting effects to the effect stack.  Similar to `computeStat_`,
-- this is additionall searches so called global hooks, but only recognizes global hooks
-- passed as an argument.
runHooks_ :: [Hook [Effect]] -> Trigger -> BoardState -> BoardState
runHooks_ globalHooks trigger board = board <++ characterEffects  <++ globalEffects
  where
    filterActivatedL :: Traversal' (Hook a) (Hook a)
    filterActivatedL = filtered ((==trigger) . hookTrigger)
    unitHooksL :: SimpleFold Character (BoardState -> CharacterIdentifier -> [Effect])
    unitHooksL = baseStats . traitsL . each . traitHooksL . each . filterActivatedL . hookEffectL
    charRunHooks :: (CharacterIdentifier, Character) -> [Effect]
    charRunHooks (cid, c) =
      (c ^. unitHooksL) board cid
    characterEffects :: [Effect]
    characterEffects = board ^. enumerateUnits . to charRunHooks
    globalEffects :: [Effect]
    globalEffects = (globalHooks ^. each . filterActivatedL . hookEffectL) board

instance Show BoardState where
  show board = join (intersperse "\n" showTiles) ++ '\n':showRound  ++ "\n" ++ showCharacters
    where
      renderUpperCorner :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderUpperCorner (_, (_, tiles))
        | Wall  `elem` tiles = '█'
        | Rough `elem` tiles = '~'
        | otherwise        = ' '
      renderLowerLeftCorner :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderLowerLeftCorner t@(_, (_, tiles))
        | Wall      `elem` tiles = '█'
        | Elevation `elem` tiles = '▛'
        | otherwise            = renderUpperCorner t
      renderLowerRightCorner :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderLowerRightCorner t@(_, (_, tiles))
        | Wall      `elem` tiles = '█'
        | Elevation `elem` tiles = '▜'
        | otherwise            = renderUpperCorner t
      renderBorderTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderBorderTile (_, (_, tiles))
        |Wall   `elem` tiles = '█'
        |Hazard `elem` tiles = '⩚'
        |Rough  `elem` tiles = '~'
        | otherwise         = ' '
      renderLowerBorderTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderLowerBorderTile t@(_, (_, tiles))
        |Wall      `elem` tiles = '█'
        |Elevation `elem` tiles = '▀'
        | otherwise             = renderBorderTile t
      renderUpperCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderUpperCenterTile t@(_, (_, tiles))
        | Wall      `elem` tiles = '█'
        | Stairs    `elem` tiles = '≣'
        | otherwise              = renderBorderTile t
      renderLowerCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderLowerCenterTile t@(_, (_, tiles))
        | Wall      `elem` tiles = '█'
        | Elevation `elem` tiles = '▀'
        | otherwise            = renderUpperCenterTile t
      renderLeftCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderLeftCenterTile t@(_, (_, tiles))
        | Wall   `elem` tiles = '█'
        | Stairs `elem` tiles = '▙'
        | otherwise            = renderBorderTile t
      renderRightCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderRightCenterTile t@(_, (_, tiles))
        | Wall   `elem` tiles = '█'
        | Stairs `elem` tiles = '▟'
        | otherwise            = renderBorderTile t
      renderMidTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderMidTile (_, (_, tiles))
        | Wall   `elem` tiles = '█'
        | otherwise           = ' '
      renderTrueCenter :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char
      renderTrueCenter (p, (Nothing, tiles))
        | board ^? movingUnit . _Just . _2 == Just p = '*'
        | Wall `elem` tiles = '█'
        | otherwise         = ' '
      renderTrueCenter (p, (Just cid, _))
        | board ^? movingUnit . _Just . _2 == Just p = '*'
        | board ^? movingUnit . _Just . _1 == Just cid = ' '
        | otherwise = showCID cid
      renderTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> [String]
      renderTile t =
        [ [renderUpperCorner t    , renderBorderTile t     , renderUpperCenterTile t, renderBorderTile t     , renderUpperCorner t     ]
        , [renderLeftCenterTile t , renderMidTile t        , renderTrueCenter t     , renderMidTile t        , renderRightCenterTile t ]
        , [renderLowerLeftCorner t, renderLowerBorderTile t, renderLowerCenterTile t, renderLowerBorderTile t, renderLowerRightCorner t]
        ]
      renderRow :: [(Point, (Maybe CharacterIdentifier, [EnvTile]))] -> [String]
      renderRow tiles = foldr (zipWith $ (++) . ('│':)) (repeat "│") (renderTile <$> tiles)
      hIndicies = [0..board ^. width - 1]
      vIndicies = [0..board ^. height - 1]
      arrIndicies :: [[Point]]
      arrIndicies = zipWith (\x y -> Point $ x + y * _height board) hIndicies . replicate (fromIntegral $ _width board) <$> vIndicies
      arrValues :: [[(Point, (Maybe CharacterIdentifier, [EnvTile]))]]
      arrValues = arrIndicies & traversed . traversed %~ (\p -> (p, board ^?! atPoint p))
      hLine :: String
      hLine = "─────"
      mkLine :: Char -> Char -> Char -> String
      mkLine l m r = l : (replicate (fromIntegral $ board ^. width) hLine & intersperse [m] & mconcat) ++ [r]
      floor :: String
      floor = mkLine '├' '┼' '┤'
      roof :: String
      roof = mkLine '┌' '┬' '┐'
      basement :: String
      basement = mkLine '└' '┴' '┘'
      showTiles :: [String]
      showTiles = mconcat $ [roof] : intersperse [floor] (renderRow <$> arrValues) ++ [[basement]]
      showRound :: String
      showRound = "Round: " ++ show (board ^. roundNumber)
      showCharPair (cid, c) = "\n\n===== [" ++ showCID cid : "] " ++ drop 6 (show c)
      showCharacters = board ^.. enumerateUnits . to showCharPair . each

newBoard :: Natural -> Natural -> (Point -> Maybe (Player, BaseStats)) -> (Point -> [EnvTile]) -> BoardState
newBoard width height initialLayout terrain = BoardState
    { _tiles = tiles
    , _width = width
    , _height = height
    , _characters = characters
    , _soul = toPPair $ const 0
    , _movingUnit = Nothing
    , _roundNumber = 1
    , _turn = Max
    , _effectStack = [StartTurn]
    }
  where
    allPoints = enumeratePoints width height
    buildCharacter :: (Point, Maybe (Player, BaseStats)) -> Maybe (Player, (Point, BaseStats))
    buildCharacter (p, Just (player, stats)) = Just (player, (p, stats))
    buildCharacter (_, Nothing) = Nothing
    protocharacters :: [(Player, (Point, BaseStats))]
    protocharacters = mapMaybe (buildCharacter . second initialLayout . dup) allPoints
    pointToCID :: Player -> Point -> Maybe CharacterIdentifier
    pointToCID player point = (player,) <$> characterIndex
      where
        playersOccupiedTiles :: [Point]
        playersOccupiedTiles = map (fst . snd) $ filter ((==player) . fst) protocharacters
        characterIndex :: Maybe Int
        characterIndex = elemIndex point playersOccupiedTiles
    tiles :: [(Maybe CharacterIdentifier, [EnvTile])]
    tiles = (\p -> (pointToCID Min p <|> pointToCID Max p, terrain p)) <$> enumeratePoints width height
    characters :: PPair [Character]
    characters = toPPair (\player -> protocharacters ^.. each . filtered ((==player) . fst). _2  . _2 . to instantiate)

activePlayer :: Lens' BoardState Player
activePlayer = turn

switchActivePlayer :: BoardState -> BoardState
switchActivePlayer = turn %~ otherPlayer

popEffect :: BoardState -> Maybe (Effect, BoardState)
popEffect board@(BoardState {_effectStack = topEffect : remainingEffects})
    = Just (topEffect, board {_effectStack = remainingEffects})
popEffect _ = Nothing

usingBoardDimensions :: BoardState -> (Natural -> Natural -> a) -> a
usingBoardDimensions (BoardState {_width, _height}) f = f _width _height

offsetB :: BoardState -> Point -> OrthagonalDirection -> Maybe Point
offsetB b = usingBoardDimensions b offset

eachCID :: Monoid m => Getting m BoardState CharacterIdentifier
eachCID = tiles . each . _1 . _Just

ixCharacter :: CharacterIdentifier -> Traversal' BoardState Character
ixCharacter (player, indx) = characters . forPlayer player . ix indx

renderCharacterHandle :: BoardState -> CharacterIdentifier -> String
renderCharacterHandle board cid = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid

eachCharacter :: Traversal' BoardState Character
eachCharacter = characters . everybody . traverse

characterLocations :: Monoid m => Getting m BoardState (Point, CharacterIdentifier)
characterLocations = to listCIDsWithLocations' . each
  where
    listCIDsWithLocations' :: BoardState -> [(Point, CharacterIdentifier)]
    listCIDsWithLocations' (BoardState {_tiles}) = catMaybes $ zipWith (\p (cid, _) -> (Point p,) <$> cid) [0..] _tiles

cidsInRange :: BoardState -> (Natural, Natural) -> Point -> [CharacterIdentifier]
cidsInRange board range locus = board ^.. inner
  where
    inner :: SimpleFold BoardState CharacterIdentifier
    inner = characterLocations . filtered (fst >>> usingBoardDimensions board distanceCardinal locus >>> inRange range) . _2

ofPlayer :: Player -> Traversal' CharacterIdentifier CharacterIdentifier
ofPlayer player = filtered (owner >>> (== player))

-- | A traversal over pairs in the form (`CharacterIdentifier`, `Character`)
--
-- On modifying these pairs:  Modifications to the `Character` will be applied to the
-- original character, but __changes to the `CharacterIdentifier` will be completely
-- ignored__.  This means you /cannot/ use this traversal to change the order of
-- characters, switch characters between players, or anything like that.
enumerateUnits :: Traversal' BoardState (CharacterIdentifier, Character)
enumerateUnits = enumerateUnits'
  where
    enumerateUnits' :: forall f. Applicative f
                   => ((CharacterIdentifier, Character) -> f (CharacterIdentifier, Character))
                   -> BoardState -> f BoardState
    enumerateUnits' f = characters fCharacters
      where
        fUnit :: Player -> Int -> Character -> f Character
        fUnit player indx c = snd <$> f ((player, indx), c)
        fRoster :: Player -> [Character] -> f [Character]
        fRoster player roster = zipWithM (fUnit player) [0..] roster
        fCharacters :: PPair [Character] -> f (PPair [Character])
        fCharacters (PPair p1 p2) = PPair <$> fRoster Min p1 <*> fRoster Max p2

untappedUnits :: SimpleFold BoardState CharacterIdentifier
untappedUnits = enumerateUnits . filtered (untapped . snd) . _1

isAlive :: BoardState -> CharacterIdentifier -> Bool
isAlive board cid = has (eachCID . filtered (== cid)) board

pushEffects :: [Effect] -> BoardState -> BoardState
pushEffects newEffects = effectStack %~ (newEffects ++)

unitPosition :: BoardState -> CharacterIdentifier -> Maybe Point
unitPosition (BoardState {_movingUnit=Just (movingCid, movingPoint)}) cid
  | movingCid == cid = Just movingPoint
unitPosition (BoardState {_tiles}) cid = headMay $ catMaybes $ zipWith aux [0..] _tiles
  where
    aux :: Natural -> (Maybe CharacterIdentifier, [EnvTile]) -> Maybe Point
    aux p (potentialCid, _)
      | potentialCid == Just cid = Just $ Point p
      | otherwise = Nothing

atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile])
atPoint p = tiles . ixp p
  where
    ixp :: Point -> Traversal' [a] a
    ixp (Point n) = ix $ fromIntegral n

characterAt :: Point -> Traversal' BoardState (Maybe CharacterIdentifier)
characterAt p f board = inner f board
  where
    inner :: Traversal' BoardState (Maybe CharacterIdentifier)
    inner = atPoint p . _1 . filtered (/= board ^? movingUnit . _Just . _1)

adjacentUnits :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier]
adjacentUnits board cid = do
  originalLocation <- unitPosition board cid
  let adjacentTiles = usingBoardDimensions board adjacentPoints originalLocation
  let characterAt' p = characterAt p . _Just :: SimpleFold BoardState CharacterIdentifier
  let unitsAdjacent = mapMaybe (flip preview board . characterAt') adjacentTiles
  return unitsAdjacent

adjacentAllies :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier]
adjacentAllies board cid = filter (owner >>> (owner cid ==)) <$> adjacentUnits board cid

isElevated :: BoardState -> CharacterIdentifier -> Bool
isElevated board cid = maybe False (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid

removeUnit :: CharacterIdentifier -> BoardState -> BoardState
removeUnit cid = tiles . each . _1 %~ mfilter (/= cid)

setUnit :: CharacterIdentifier -> Point -> BoardState -> BoardState
setUnit character point = atPoint point . _1 ?~ character

terrainAt :: Point -> Traversal' BoardState [EnvTile]
terrainAt p = atPoint p . _2

-- | Untap all units, dish out SOUL, and increment the round number
nextRound :: BoardState -> BoardState
nextRound = (soul . everybody +~ 1) . (roundNumber +~ 1) . (eachCharacter %~ untap) . (<++ [StartTurn])

changeMovingUnit :: BoardState -> CharacterIdentifier -> BoardState
changeMovingUnit board unit = board & movingUnit .~ ((unit,) <$> unitPosition board unit)

moveUnit :: Point -> BoardState -> BoardState
moveUnit point = movingUnit . _Just . _2 .~ point

finalizeMove :: BoardState -> BoardState
finalizeMove board@(BoardState {_movingUnit = Just (unit, newLocation)}) =
  removeUnit unit board & setUnit unit newLocation & movingUnit .~ Nothing
finalizeMove board = board

(<++) :: BoardState -> [Effect] -> BoardState
(<++) = flip pushEffects

mkChoice :: String -> [Effect] -> Choice
mkChoice = Choice . NonEmpty.singleton

prependDecision :: String -> Choice -> Choice
prependDecision decision = decisionSequenceL %~ NonEmpty.cons decision

characterHandle :: CharacterIdentifier -> Character -> String
characterHandle cid  c = '[' : showCID cid : "] " ++ (c ^. baseStats . nameL)