374 lines
17 KiB
Haskell
374 lines
17 KiB
Haskell
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 Mechanics (universalModifiers, globalHooks)
|
|
import Data.Monoid (Any(getAny), getSum)
|
|
import Data.Coerce
|
|
|
|
-- | A version of `computeStat_` using `universalModifiers` as global modifiers
|
|
computeStat :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Stat a -> a
|
|
computeStat = computeStat_ universalModifiers
|
|
|
|
-- | A version of `runHooks_` using `globalHooks` as the global hooks
|
|
runHooks :: Broadcast -> 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 :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> [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 . ActingUnit)
|
|
activateUnit :: ActingUnit -> 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
|
|
|
|
{-# ANN computePossibleSteps "HLint: ignore Apply De Morgan law" #-}
|
|
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 (TargettedUnit cid) | movSpendTokens ]
|
|
++ [Event $ Broadcast EndMove (ActingUnit 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 $ Broadcast EndMove (ActingUnit 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 = TargettedUnit <$> (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 originalTarget ultimateEffect) board = if canBB then allChoices else cantBBResult
|
|
where
|
|
potentialBBers = fromMaybe [] $ adjacentAllies board originalTarget
|
|
canBB = isNecromancer originalTarget && not (null potentialBBers)
|
|
buildChoice bber = mkChoice ("Bodyblock with " ++ renderCharacterHandle board bber) (ultimateEffect bber)
|
|
dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect originalTarget)
|
|
bbChoices = buildChoice . TargettedUnit <$> potentialBBers
|
|
allChoices = unitChoice originalTarget $ dontBodyblock : bbChoices
|
|
cantBBResult = continue $ board <++ ultimateEffect originalTarget
|
|
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 = sum $ 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 . sum $ (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' = 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 $ Broadcast TookDamage recipient, if dead then Kill recipient else NoOp]
|
|
applyEffect (InflictStatusEffect se target) board = continue $ board & ixCharacter target . statusEffects %~ (se :)
|
|
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 . Broadcast 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 n ++ ") " ++ c) ([1..] :: [Int]) 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) |