305 lines
14 KiB
Haskell
305 lines
14 KiB
Haskell
{-# 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 Units (computeStat)
|
|
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
|
|
|
|
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
|
|
|
|
computePossibleSteps :: BoardState -> Player -> Bool -> Natural -> Point -> [(Point, Natural)]
|
|
computePossibleSteps board _ firstStep currentMove originalLocation = mapMaybe getRemainingMov validDirections
|
|
where
|
|
validDirections = offsetB board originalLocation `mapMaybe` orthagonalDirections
|
|
currentTerrain = board ^. terrainAt originalLocation
|
|
paysElevationCost = not (elem Stairs currentTerrain || elem Elevation currentTerrain)
|
|
baseMovementCost = if Rough `elem` currentTerrain 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 = (currentMove < totalCost && not firstStep) || hasMovementBlocker || (occupied && totalCost >= currentMove)
|
|
remainingMovement = if unreachable then 0 else currentMove - totalCost
|
|
|
|
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 $ pushEffects (listHooks board trigger) board
|
|
applyEffect (ChooseActMove cid) _ = unitChoice cid [moveFirst, actFirst]
|
|
where
|
|
moveFirst = mkChoice "Move first" [InitMove cid, ActOrMove cid, EndTurn cid]
|
|
actFirst = mkChoice "Act first" [Act cid, InitMove cid, EndTurn cid]
|
|
applyEffect (ActOrMove cid) _ = unitChoice cid [moveAgain, nowAct]
|
|
where
|
|
moveAgain = mkChoice "Move again" [InitMove cid]
|
|
nowAct = mkChoice "Act" [Act cid]
|
|
applyEffect (InitMove cid) board = continue $ changeMovingUnit board cid <++ [Move True characterMovement cid]
|
|
where
|
|
characterMovement = board ^?! ixCharacter cid . to getSpeed
|
|
applyEffect (Move _ 0 _) board = continue $ board <++ [ConfirmMove]
|
|
applyEffect (Move firstMove mov cid) board = case unitPosition board cid of
|
|
Nothing -> continue board
|
|
Just originalLocation ->
|
|
let
|
|
generateChoice :: (Point, Natural) -> Choice
|
|
generateChoice (dest, remainingMov) =
|
|
mkChoice
|
|
("Move " ++ show direction)
|
|
( MoveTo dest
|
|
: if remainingMov > 0 then [Move False remainingMov cid] else [ConfirmMove, Event $ EndMove cid]
|
|
)
|
|
where
|
|
direction = fromMaybe North $ usingBoardDimensions board identifyDirection originalLocation dest
|
|
possibleSteps = computePossibleSteps board (board ^. activePlayer) firstMove mov originalLocation
|
|
movementChoices = generateChoice <$> possibleSteps
|
|
dontMove = mkChoice "Don't move" [ConfirmMove]
|
|
finishMoving = mkChoice "Finish moving" [ConfirmMove, Event $ EndMove cid]
|
|
allowedToEndMovement = not $ has (atPoint originalLocation . _1 . _Just) board
|
|
noMovement
|
|
| firstMove = [dontMove]
|
|
| allowedToEndMovement = [finishMoving]
|
|
| otherwise = []
|
|
in unitChoice cid $ noMovement ++ movementChoices
|
|
applyEffect (MoveTo dest) board = continue $ moveUnit dest board
|
|
applyEffect ConfirmMove board = continue $
|
|
case board ^? movingUnit . _Just . _1 of
|
|
Just cid -> finalizeMove board & ixCharacter cid %~ removeTokenInCategory SpeedSlow
|
|
Nothing -> 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 <$> attackerPosition <*> defenderPosition
|
|
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 = 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) |