Compare commits
5 Commits
1f65275d5b
...
4e408135d8
Author | SHA1 | Date |
---|---|---|
Emi Simpson | 4e408135d8 | |
Emi Simpson | 7a501ac927 | |
Emi Simpson | a555ed4ea0 | |
Emi Simpson | a6a7473f05 | |
Emi Simpson | fd88082d77 |
|
@ -0,0 +1,70 @@
|
|||
# HLint configuration file
|
||||
# https://github.com/ndmitchell/hlint
|
||||
##########################
|
||||
|
||||
# This file contains a template configuration file, which is typically
|
||||
# placed as .hlint.yaml in the root of your project
|
||||
|
||||
|
||||
# Specify additional command line arguments
|
||||
#
|
||||
# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
|
||||
|
||||
|
||||
# Control which extensions/flags/modules/functions can be used
|
||||
#
|
||||
# - extensions:
|
||||
# - default: false # all extension are banned by default
|
||||
# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
|
||||
# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
|
||||
#
|
||||
# - flags:
|
||||
# - {name: -w, within: []} # -w is allowed nowhere
|
||||
#
|
||||
# - modules:
|
||||
# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
|
||||
# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
|
||||
#
|
||||
# - functions:
|
||||
# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
|
||||
|
||||
|
||||
# Add custom hints for this project
|
||||
#
|
||||
# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
|
||||
# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
|
||||
|
||||
# The hints are named by the string they display in warning messages.
|
||||
# For example, if you see a warning starting like
|
||||
#
|
||||
# Main.hs:116:51: Warning: Redundant ==
|
||||
#
|
||||
# You can refer to that hint with `{name: Redundant ==}` (see below).
|
||||
|
||||
# Turn on hints that are off by default
|
||||
#
|
||||
# Ban "module X(module X) where", to require a real export list
|
||||
# - warn: {name: Use explicit module export list}
|
||||
#
|
||||
# Replace a $ b $ c with a . b $ c
|
||||
# - group: {name: dollar, enabled: true}
|
||||
#
|
||||
# Generalise map to fmap, ++ to <>
|
||||
# - group: {name: generalise, enabled: true}
|
||||
|
||||
- group: {name: use-lens, enabled: true}
|
||||
- group: {name: generalise-for-conciseness, enabled: true}
|
||||
- group: {name: teaching, enabled: true}
|
||||
|
||||
|
||||
# Ignore some builtin hints
|
||||
# - ignore: {name: Use let}
|
||||
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
|
||||
|
||||
|
||||
# Define some custom infix operators
|
||||
# - fixity: infixr 3 ~^#^~
|
||||
|
||||
|
||||
# To generate a suitable file for HLint do:
|
||||
# $ hlint --default > .hlint.yaml
|
|
@ -51,6 +51,7 @@ library:
|
|||
- ScopedTypeVariables
|
||||
- EmptyCase
|
||||
- DuplicateRecordFields
|
||||
- StandaloneDeriving
|
||||
|
||||
executables:
|
||||
maleghast-exe:
|
||||
|
|
|
@ -1,4 +1,3 @@
|
|||
{-# OPTIONS_GHC -Wno-type-defaults #-}
|
||||
module GameLogic
|
||||
( chooseCharacter
|
||||
, applyEffect
|
||||
|
@ -27,16 +26,16 @@ import Numeric.Natural (Natural)
|
|||
import Lens.Micro
|
||||
import Safe (atMay)
|
||||
|
||||
import Debug.Trace
|
||||
import Mechanics (universalModifiers, globalHooks)
|
||||
import Data.Monoid (Any(getAny), getSum)
|
||||
import Data.Coerce
|
||||
|
||||
-- | A version of `computeStat_` using `universalModifiers` as global modifiers
|
||||
computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
|
||||
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 :: Trigger -> BoardState -> BoardState
|
||||
runHooks :: Broadcast -> BoardState -> BoardState
|
||||
runHooks = runHooks_ globalHooks
|
||||
|
||||
data EngineState
|
||||
|
@ -51,7 +50,7 @@ data EngineState
|
|||
playerChoice :: Player -> [Choice] -> EngineState
|
||||
playerChoice = PlayerChoice
|
||||
|
||||
unitChoice :: CharacterIdentifier -> [Choice] -> EngineState
|
||||
unitChoice :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> [Choice] -> EngineState
|
||||
unitChoice = playerChoice . owner
|
||||
|
||||
activePlayerChoice :: BoardState -> [Choice] -> EngineState
|
||||
|
@ -66,8 +65,8 @@ chooseCharacter board = playerChoice player <$> fmap toList (nonEmpty $ board ^.
|
|||
player :: Player
|
||||
player = board ^. activePlayer
|
||||
possibleActivations :: SimpleFold BoardState Choice
|
||||
possibleActivations = untappedUnits . filtered ((== player) . owner) . to activateUnit
|
||||
activateUnit :: CharacterIdentifier -> 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
|
||||
|
@ -81,6 +80,7 @@ forcedMovementValidDirections w h currentLocation (locus, moveType, _) =
|
|||
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
|
||||
|
@ -110,8 +110,8 @@ computePossibleSteps board (MovementSpecs {..}) currentLocation = mapMaybe getRe
|
|||
endOfMovementEffects :: MovementSpecs -> CharacterIdentifier -> [Effect]
|
||||
endOfMovementEffects (MovementSpecs {..}) cid =
|
||||
[ConfirmMove]
|
||||
++ [DropToken SpeedSlow cid | movSpendTokens ]
|
||||
++ [Event $ EndMove cid | movEndMoveTrigger]
|
||||
++ [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) =
|
||||
|
@ -192,7 +192,7 @@ applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board
|
|||
then continue $ board <++ if movMinimum
|
||||
then dontMoveEffects
|
||||
else finishMoveEffects
|
||||
else choiceBuilder $ (++ movementChoices) $ if movCompelled
|
||||
else choiceBuilder . (++ movementChoices) $ if movCompelled
|
||||
then []
|
||||
else if movMinimum
|
||||
then [dontMoveChoice]
|
||||
|
@ -202,7 +202,7 @@ applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board
|
|||
dontMoveChoice = mkChoice "Don't move" dontMoveEffects
|
||||
finishMoveEffects = endOfMovementEffects specs cid
|
||||
finishMoveChoice = mkChoice "Finish moving" finishMoveEffects
|
||||
endMoveTrigger = Event $ EndMove cid
|
||||
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 $
|
||||
|
@ -214,22 +214,22 @@ applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actio
|
|||
applyEffect (Target fromPerspective range eligability ultimateEffect) board = unitChoice fromPerspective choices
|
||||
where
|
||||
locus = unitPosition board fromPerspective
|
||||
potentialUnits = maybe [] (cidsInRange board range) locus
|
||||
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 targettedUnit ultimateEffect) board = if canBB then allChoices else cantBBResult
|
||||
applyEffect (BodyBlock originalTarget ultimateEffect) board = if canBB then allChoices else cantBBResult
|
||||
where
|
||||
potentialBBers = fromMaybe [] $ adjacentAllies board targettedUnit
|
||||
canBB = isNecromancer targettedUnit && potentialBBers /= []
|
||||
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 targettedUnit)
|
||||
bbChoices = buildChoice <$> potentialBBers
|
||||
allChoices = unitChoice targettedUnit $ dontBodyblock : bbChoices
|
||||
cantBBResult = continue $ board <++ ultimateEffect targettedUnit
|
||||
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
|
||||
|
@ -252,7 +252,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
|
|||
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
|
||||
attackerStrWeak = sum $ attacker' ^? _Just . tokenCount . ofToken StrWeak
|
||||
tokenDamageModifier
|
||||
| attackerStrWeak < 0 = \x -> x-1
|
||||
| attackerStrWeak > 0 = (+1)
|
||||
|
@ -263,7 +263,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
|
|||
onHit = hitDamage : otherEffects attack
|
||||
onHeadshot = onHit ++ headshotEffects attack
|
||||
consequence Six
|
||||
| not $ null $ headshotEffects attack = mkChoice "Headshot!" onHeadshot
|
||||
| not . null $ headshotEffects attack = mkChoice "Headshot!" onHeadshot
|
||||
consequence r
|
||||
| r >= toHit = mkChoice "Hit!" onHit
|
||||
| otherwise = mkChoice "Graze" onMiss
|
||||
|
@ -273,28 +273,29 @@ applyEffect (InflictDamage damageType incomingAmount recipient) board = continue
|
|||
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
|
||||
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' = trace ("iA': " ++ show incomingAmount' ++ " | aR: " ++ show armorReduction ++ " | r: " ++ show recipient) $ board
|
||||
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 $ TookDamage recipient, if dead then Kill recipient else NoOp]
|
||||
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
|
||||
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
|
||||
deathAlert = maybe NoOp (Event . Broadcast Died . (unit,)) deathLocation
|
||||
applyEffect (EndTurn cid) board = continue $ afterPlayerSwitched <++ [StartTurn]
|
||||
where
|
||||
afterUnitTapped = board & ixCharacter cid %~ tap
|
||||
|
@ -319,7 +320,7 @@ instance Show (ChoiceTree' a) where
|
|||
choicesText :: [String]
|
||||
choicesText = firstDecisions choices
|
||||
numberedChoices :: [String]
|
||||
numberedChoices = zipWith (\n c -> show (1+n) ++ ") " ++ c) [0..] choicesText
|
||||
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")
|
||||
|
@ -353,11 +354,11 @@ buildChoiceTree board = case popEffect 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
|
||||
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 die (Random _ _ outcomes) = Just . ctTree $ outcomes die
|
||||
makeChoice indx (Node b p options) = trimmedChoices <$> providedDecision
|
||||
where
|
||||
providedDecision :: Maybe String
|
||||
|
|
294
src/GameModel.hs
294
src/GameModel.hs
|
@ -1,5 +1,3 @@
|
|||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Eta reduce" #-}
|
||||
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
||||
module GameModel
|
||||
( DieFace(..)
|
||||
|
@ -8,6 +6,10 @@ module GameModel
|
|||
, Armor(..)
|
||||
, DamageType(..)
|
||||
, Attack(Attack)
|
||||
, ActingUnit(..)
|
||||
, actingUnit
|
||||
, TargettedUnit(..)
|
||||
, targettedUnit
|
||||
, headshotEffectsL
|
||||
, meleeL
|
||||
, otherEffectsL
|
||||
|
@ -49,6 +51,8 @@ module GameModel
|
|||
, otherPlayer
|
||||
, Token(..)
|
||||
, ofToken
|
||||
, tokenEq
|
||||
, Broadcast(..)
|
||||
, Stat(..)
|
||||
, BaseStats(..)
|
||||
, nameL
|
||||
|
@ -67,7 +71,9 @@ module GameModel
|
|||
, clearUpToNTokens
|
||||
, getSpeed
|
||||
, getDefense
|
||||
, statusEffects
|
||||
, CharacterIdentifier
|
||||
, cidEq
|
||||
, owner
|
||||
, ownerL
|
||||
, isNecromancer
|
||||
|
@ -128,8 +134,8 @@ module GameModel
|
|||
, allStatsAreMonoids
|
||||
, HasMonoidInstance
|
||||
, Hook(..)
|
||||
, hookTriggerL
|
||||
, hookEffectL
|
||||
, hookToFunc
|
||||
, hooksToFunc
|
||||
, Modifier(..)
|
||||
, Trait(..)
|
||||
, traitNameL
|
||||
|
@ -137,6 +143,7 @@ module GameModel
|
|||
, traitModifiersL
|
||||
, computeStat_
|
||||
, runHooks_
|
||||
, StatusEffect(..)
|
||||
) where
|
||||
|
||||
import Util (toMaybe, dup, secondClassLensNames, (??))
|
||||
|
@ -156,6 +163,7 @@ import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics)
|
|||
import Lens.Micro.Extras (preview)
|
||||
import Data.Data ((:~:)(..))
|
||||
import System.Random (Random(..))
|
||||
import Data.Coerce
|
||||
|
||||
data DieFace = One | Two | Three | Four | Five | Six
|
||||
deriving (Eq, Ord, Enum, Read)
|
||||
|
@ -166,7 +174,7 @@ instance Random DieFace where
|
|||
lowN = fromEnum low
|
||||
hiN = fromEnum hi
|
||||
(r, g') = randomR (lowN, hiN) g
|
||||
random g = randomR (One, Six) g
|
||||
random = randomR (One, Six)
|
||||
|
||||
bestOrWorst :: Bool -> [DieFace] -> DieFace
|
||||
bestOrWorst True = maximum
|
||||
|
@ -222,14 +230,23 @@ instance Num DieFace where
|
|||
|
||||
type CharacterIdentifier = (Player, Int)
|
||||
|
||||
owner :: CharacterIdentifier -> Player
|
||||
owner = fst
|
||||
cidEq :: (Coercible a b, Eq b) => a -> b -> Bool
|
||||
cidEq = (==) . coerce
|
||||
|
||||
owner :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Player
|
||||
owner cid' = fst cid
|
||||
where
|
||||
cid :: CharacterIdentifier
|
||||
cid = coerce cid'
|
||||
|
||||
ownerL :: Lens' CharacterIdentifier Player
|
||||
ownerL = _1
|
||||
|
||||
isNecromancer :: CharacterIdentifier -> Bool
|
||||
isNecromancer = snd >>> (== 0)
|
||||
isNecromancer :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Bool
|
||||
isNecromancer cid' = (==0) $ snd cid
|
||||
where
|
||||
cid :: CharacterIdentifier
|
||||
cid = coerce cid'
|
||||
|
||||
showCID :: CharacterIdentifier -> Char
|
||||
showCID (cidOwner, idx) = (if cidOwner == Max then upperLetters else lowerLetters) !! idx
|
||||
|
@ -296,12 +313,29 @@ newtype Point = Point Natural
|
|||
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 Trigger a where
|
||||
TurnStart :: Trigger ()
|
||||
TookDamage :: Trigger TargettedUnit
|
||||
Died :: Trigger (TargettedUnit, Point)
|
||||
EndMove :: Trigger ActingUnit
|
||||
|
||||
deriving instance Eq (Trigger a)
|
||||
deriving instance Show (Trigger a)
|
||||
|
||||
-- | Compare to triggers to check if they're equal
|
||||
--
|
||||
-- If they are, you get a proof of the equality of their associated data types.
|
||||
triggerEq :: Trigger a -> Trigger b -> Maybe (a :~: b)
|
||||
triggerEq TurnStart TurnStart = Just Refl
|
||||
triggerEq TookDamage TookDamage = Just Refl
|
||||
triggerEq Died Died = Just Refl
|
||||
triggerEq EndMove EndMove = Just Refl
|
||||
triggerEq _ _ = Nothing
|
||||
|
||||
-- | A pair containing a 'Trigger' and its associated data
|
||||
--
|
||||
-- Effectively an event as a whole
|
||||
data Broadcast = forall d. Broadcast (Trigger d) d
|
||||
|
||||
data OrthagonalDirection
|
||||
= North
|
||||
|
@ -404,8 +438,8 @@ data ProtoMovementSpecs = ProtoMovementSpecs
|
|||
, movCompelled :: Bool -- ^ If movement can be stopped prematurely
|
||||
}
|
||||
|
||||
basicMove :: CharacterIdentifier -> Effect
|
||||
basicMove = InitMove $ ProtoMovementSpecs
|
||||
basicMove :: ActingUnit -> Effect
|
||||
basicMove = (InitMove $ ProtoMovementSpecs
|
||||
{ movVerb = "Move"
|
||||
, movFree' = Nothing
|
||||
, movMinimum = True
|
||||
|
@ -414,10 +448,10 @@ basicMove = InitMove $ ProtoMovementSpecs
|
|||
, movSpendTokens = True
|
||||
, movEndMoveTrigger = True
|
||||
, movCompelled = False
|
||||
}
|
||||
}) . (^. actingUnit)
|
||||
|
||||
forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> CharacterIdentifier -> Effect
|
||||
forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs
|
||||
forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> TargettedUnit -> Effect
|
||||
forcedMove fmType amt compeller locus = (InitMove $ ProtoMovementSpecs
|
||||
{ movVerb = show fmType
|
||||
, movFree' = Just True
|
||||
, movMinimum = False
|
||||
|
@ -426,7 +460,25 @@ forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs
|
|||
, movSpendTokens = False
|
||||
, movEndMoveTrigger = False
|
||||
, movCompelled = True
|
||||
}
|
||||
}) . (^. targettedUnit)
|
||||
|
||||
-- | Designates a character identifier of the unit acting in an effect/event
|
||||
--
|
||||
-- Acting includes moving, attacking, or using an ability
|
||||
newtype ActingUnit = ActingUnit CharacterIdentifier
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A lens reaching into `ActingUnit`
|
||||
actingUnit :: Lens' ActingUnit CharacterIdentifier
|
||||
actingUnit f (ActingUnit au) = ActingUnit <$> f au
|
||||
|
||||
-- | Designates a character identifier of the unit being targetted by an effect/attack
|
||||
newtype TargettedUnit = TargettedUnit CharacterIdentifier
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A lens reaching into `TargettedUnit`
|
||||
targettedUnit :: Lens' TargettedUnit CharacterIdentifier
|
||||
targettedUnit f (TargettedUnit au) = TargettedUnit <$> f au
|
||||
|
||||
data Effect
|
||||
|
||||
|
@ -436,13 +488,13 @@ data Effect
|
|||
| StartTurn
|
||||
|
||||
-- | Send some trigger to every Unit
|
||||
| Event Trigger
|
||||
| Event Broadcast
|
||||
|
||||
-- | Active player chooses whether they want to move or act first
|
||||
| ChooseActMove CharacterIdentifier
|
||||
| ChooseActMove ActingUnit
|
||||
|
||||
-- | Active player may choose whether they want to act or move
|
||||
| ActOrMove CharacterIdentifier
|
||||
| ActOrMove ActingUnit
|
||||
|
||||
-- | Mark the start of movement
|
||||
-- Can be finalized later with FinalizeMove
|
||||
|
@ -464,46 +516,51 @@ data Effect
|
|||
-- | 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
|
||||
TargettedUnit -- ^ Which character drops a token
|
||||
|
||||
-- | Confirms a Move, placing the unit in the target space
|
||||
| ConfirmMove
|
||||
|
||||
-- | Allow a character to Act
|
||||
| Act CharacterIdentifier
|
||||
| Act ActingUnit
|
||||
|
||||
-- | Target a unit in a given range, then run a different event
|
||||
| Target
|
||||
CharacterIdentifier -- ^ ACTing unit
|
||||
ActingUnit -- ^ ACTing unit
|
||||
(Natural, Natural) -- ^ Range
|
||||
(BoardState -> CharacterIdentifier -> Bool) -- ^ Target filter
|
||||
(CharacterIdentifier -> [Effect]) -- ^ Ultimate effect
|
||||
(BoardState -> TargettedUnit -> Bool) -- ^ Target filter
|
||||
(TargettedUnit -> [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])
|
||||
| BodyBlock TargettedUnit (TargettedUnit -> [Effect])
|
||||
|
||||
-- | Resolve an attack
|
||||
| ResolveAttack
|
||||
CharacterIdentifier -- ^ Attacker
|
||||
Attack -- ^ Attack information
|
||||
CharacterIdentifier -- ^ Target
|
||||
ActingUnit -- ^ Attacker
|
||||
Attack -- ^ Attack information
|
||||
TargettedUnit -- ^ Target
|
||||
|
||||
| InflictDamage
|
||||
DamageType
|
||||
Natural -- ^ Damage amount
|
||||
CharacterIdentifier -- ^ Target
|
||||
TargettedUnit -- ^ Target
|
||||
|
||||
-- | Add a status effect to a character
|
||||
| InflictStatusEffect
|
||||
StatusEffect -- ^ Effect to inflict
|
||||
TargettedUnit -- ^ Target
|
||||
|
||||
| forall n. Num n => InflictTokens
|
||||
(Token n) -- ^ Token kind
|
||||
n -- ^ Token amount
|
||||
CharacterIdentifier -- ^ Target
|
||||
TargettedUnit -- ^ Target
|
||||
|
||||
| Kill CharacterIdentifier
|
||||
| Kill TargettedUnit
|
||||
|
||||
-- | Tap the active unit, change the active player
|
||||
| EndTurn CharacterIdentifier
|
||||
| EndTurn ActingUnit
|
||||
|
||||
data Attack = Attack
|
||||
{ headshotEffects :: [Effect]
|
||||
|
@ -553,16 +610,28 @@ data BaseStats = BaseStats
|
|||
, df :: DieFace
|
||||
, arm :: Armor
|
||||
, traits :: [Trait]
|
||||
, actions :: [CharacterIdentifier -> Choice]
|
||||
, actions :: [ActingUnit -> Choice]
|
||||
}
|
||||
|
||||
-- | Some effect which is activated by some trigger event
|
||||
data Hook h = Hook
|
||||
{ hookTrigger :: Trigger -- ^ The trigger which should activate this effect
|
||||
data Hook o = forall d. Hook
|
||||
{ hookTrigger :: Trigger d -- ^ The trigger which should activate this effect
|
||||
-- | What this effect does. Recieves board & this character's CID
|
||||
, hookEffect :: BoardState -> h
|
||||
, hookEffect :: d -> BoardState -> o
|
||||
}
|
||||
|
||||
-- | Evaluate a hook for a given trigger
|
||||
--
|
||||
-- If the trigger does not apply to this hook, then `mempty` is returned.
|
||||
hookToFunc :: Monoid h => Hook h -> Broadcast -> BoardState -> h
|
||||
hookToFunc (Hook {..}) (Broadcast trigger assocData) = case hookTrigger `triggerEq` trigger of
|
||||
Just Refl -> hookEffect assocData
|
||||
Nothing -> mempty
|
||||
|
||||
-- | A version of `hookToFunc` which evaluates several hooks at once
|
||||
hooksToFunc :: Monoid h => [Hook h] -> Broadcast -> BoardState -> h
|
||||
hooksToFunc = mconcat . fmap hookToFunc
|
||||
|
||||
-- | 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
|
||||
|
@ -584,13 +653,47 @@ data Trait = Trait
|
|||
, traitModifiers :: [Modifier] -- ^ Any modifiers this trait imposes
|
||||
}
|
||||
|
||||
-- | Some inflicted/bestowed trait that applies to a character
|
||||
--
|
||||
-- Some status effects track internal state (here, the type variable a), which affect
|
||||
-- either what the effect does or how long it exists.
|
||||
--
|
||||
-- A couple examples of status effects:
|
||||
-- - Gargamox's Leech's "superate", which adds a Deathburst to a unit, and lasts for the
|
||||
-- whole game
|
||||
-- - C.A.R.C.A.S.'s Ammo Goblin's "bone shards" which causes the unit to take damage when
|
||||
-- pushed or pulled, and expires after dealing three damage or the end of the goblin's
|
||||
-- next turn.
|
||||
data StatusEffect = forall a. StatusEffect
|
||||
{ seName :: String -- ^ The name of the effect
|
||||
, seHooks :: [Hook (a -> CharacterIdentifier -> [Effect])] -- ^ Triggers which produce effects
|
||||
, seModifiers :: [Modifier] -- ^ Any stat modifiers inflicted by this effect
|
||||
|
||||
-- | Triggers which update the internal state or remove the effect
|
||||
--
|
||||
-- Returning `Just` updates the internal state, and returning `Nothing` removes the
|
||||
-- effect completely.
|
||||
, seUpdate :: [Hook (a -> CharacterIdentifier -> Maybe a)]
|
||||
|
||||
-- | Whatever internal state is needed by this effect
|
||||
, seState :: a
|
||||
|
||||
-- | Render the internal state
|
||||
--
|
||||
-- Suffixed with the name when `show`ing this status effect
|
||||
, seShowState :: a -> String
|
||||
}
|
||||
|
||||
instance Show StatusEffect where
|
||||
show (StatusEffect {..}) = '+' : seName ++ ' ' : seShowState seState
|
||||
|
||||
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 (/=[])
|
||||
show tc = mconcat . intersperse "\n" $ filter (not . null)
|
||||
[ showHealth
|
||||
, showReload
|
||||
, " "
|
||||
|
@ -652,10 +755,16 @@ data Character = Character
|
|||
{ _baseStats :: BaseStats
|
||||
, _movedThisRound :: Bool
|
||||
, _tokenCount :: TokenCount
|
||||
, _statusEffects :: [StatusEffect]
|
||||
}
|
||||
|
||||
instance Show Character where
|
||||
show c = show (_baseStats c) ++ (if _movedThisRound c then "\n(already moved this round)" else "\n") ++ '\n' : show (_tokenCount c)
|
||||
show c =
|
||||
show (_baseStats c)
|
||||
++ (if _movedThisRound c then "\n(already moved this round)" else "\n")
|
||||
++ '\n' : show (_tokenCount c)
|
||||
++ '\n' : mconcat (intersperse "\n" (show <$> _statusEffects c))
|
||||
++ "\n"
|
||||
|
||||
noTokens :: TokenCount
|
||||
noTokens = TokenCount noTokens'
|
||||
|
@ -699,8 +808,30 @@ makeLensesWith secondClassLensNames ''Hook
|
|||
|
||||
makeLensesWith secondClassLensNames ''Trait
|
||||
|
||||
instance Functor Hook where
|
||||
fmap f (Hook {..}) = Hook {hookEffect = hookEffect <&> (<&> f), ..}
|
||||
v <$ Hook {..} = Hook {hookEffect = const $ const v, ..}
|
||||
|
||||
-- | Extract the hooks from a status effect, hiding internal state
|
||||
seGetHooks :: StatusEffect -> [Hook (CharacterIdentifier -> [Effect])]
|
||||
seGetHooks (StatusEffect {..}) = seHooks <&> (<&> ($ seState))
|
||||
|
||||
seDoUpdate :: Broadcast -> BoardState -> CharacterIdentifier -> StatusEffect -> Maybe StatusEffect
|
||||
seDoUpdate (Broadcast trigger assocData) board cid (StatusEffect {..}) = case relevantUpdates of
|
||||
[] -> Just $ StatusEffect {..}
|
||||
Nothing : _ -> Nothing
|
||||
Just newState : _ -> Just $ StatusEffect {seState = newState, ..}
|
||||
where
|
||||
seUpdate' = seUpdate & each . mapped %~ (($ cid) . ($ seState))
|
||||
getRelevantHookEffects :: Hook t -> Maybe (BoardState -> t)
|
||||
getRelevantHookEffects (Hook {..}) = case hookTrigger `triggerEq` trigger of
|
||||
Just Refl -> Just $ hookEffect assocData
|
||||
Nothing -> Nothing
|
||||
relevantHooks = seUpdate' ^.. each . to getRelevantHookEffects . _Just
|
||||
relevantUpdates = sequence relevantHooks board
|
||||
|
||||
instantiate :: BaseStats -> Character
|
||||
instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats
|
||||
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
|
||||
|
@ -740,10 +871,11 @@ untap = movedThisRound .~ False
|
|||
--
|
||||
-- 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
|
||||
computeStat_ :: (Coercible cid c, c ~ CharacterIdentifier) => [Modifier] -> BoardState -> cid -> Stat a -> a
|
||||
computeStat_ globalModifiers board cid' stat = case allStatsAreMonoids stat of
|
||||
HasMonoidInstance Refl ->
|
||||
let
|
||||
cid = coerce cid'
|
||||
queryStatsL = each . to (queryModifier board cid stat)
|
||||
globalBonus = globalModifiers ^. queryStatsL
|
||||
traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL
|
||||
|
@ -751,24 +883,28 @@ computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of
|
|||
|
||||
-- | 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
|
||||
-- Searches through all hooks in traits, statuse effects and global hooks, accumulates all
|
||||
-- their effects, then adds all the resulting effects to the effect stack. Then, all
|
||||
-- necessary status effect updates are applied. Similar to `computeStat_`, this is
|
||||
-- additionall searches so called global hooks, but only recognizes global hooks passed as
|
||||
-- an argument.
|
||||
runHooks_ :: [Hook [Effect]] -> Broadcast -> BoardState -> BoardState
|
||||
runHooks_ globalHooks trigger board = boardWithUpdates <++ allEffects
|
||||
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
|
||||
unitAllEffectHooks :: (CharacterIdentifier, Character) -> [Hook [Effect]]
|
||||
unitAllEffectHooks (cid, c) = allHooks <&> (?? cid)
|
||||
where
|
||||
statusHooks :: [Hook (CharacterIdentifier -> [Effect])]
|
||||
statusHooks = c ^.. statusEffects . each . to seGetHooks . each
|
||||
classHooks :: [Hook (CharacterIdentifier -> [Effect])]
|
||||
classHooks = c ^.. baseStats . traitsL . each . traitHooksL . each
|
||||
allHooks = statusHooks ++ classHooks
|
||||
unitUpdateStatuses :: (CharacterIdentifier, Character) -> (CharacterIdentifier, Character)
|
||||
unitUpdateStatuses i@(cid, _) = i & _2 . statusEffects %~ mapMaybe (seDoUpdate trigger board cid)
|
||||
unitHooks = board ^.. enumerateUnits . to unitAllEffectHooks . each
|
||||
allHooks = unitHooks ++ globalHooks
|
||||
allEffects = hooksToFunc allHooks trigger board
|
||||
boardWithUpdates = board & enumerateUnits %~ unitUpdateStatuses
|
||||
|
||||
instance Show BoardState where
|
||||
show board = join (intersperse "\n" showTiles) ++ '\n':showRound ++ "\n" ++ showCharacters
|
||||
|
@ -914,11 +1050,13 @@ 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
|
||||
ixCharacter :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Traversal' BoardState Character
|
||||
ixCharacter cid = case coerce cid of (player, indx) -> characters . forPlayer player . ix indx
|
||||
|
||||
renderCharacterHandle :: BoardState -> CharacterIdentifier -> String
|
||||
renderCharacterHandle board cid = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid
|
||||
renderCharacterHandle :: (Coercible a b, b ~ CharacterIdentifier) => BoardState -> a -> String
|
||||
renderCharacterHandle board cid' = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid
|
||||
where
|
||||
cid = coerce cid'
|
||||
|
||||
eachCharacter :: Traversal' BoardState Character
|
||||
eachCharacter = characters . everybody . traverse
|
||||
|
@ -955,9 +1093,9 @@ enumerateUnits = enumerateUnits'
|
|||
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
|
||||
fRoster player = zipWithM (fUnit player) [0..]
|
||||
|
||||
untappedUnits :: SimpleFold BoardState CharacterIdentifier
|
||||
untappedUnits = enumerateUnits . filtered (untapped . snd) . _1
|
||||
|
@ -968,14 +1106,14 @@ isAlive board cid = has (eachCID . filtered (== cid)) board
|
|||
pushEffects :: [Effect] -> BoardState -> BoardState
|
||||
pushEffects newEffects = effectStack %~ (newEffects ++)
|
||||
|
||||
unitPosition :: BoardState -> CharacterIdentifier -> Maybe Point
|
||||
unitPosition :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe Point
|
||||
unitPosition (BoardState {_movingUnit=Just (movingCid, movingPoint)}) cid
|
||||
| movingCid == cid = Just movingPoint
|
||||
unitPosition (BoardState {_tiles}) cid = headMay $ catMaybes $ zipWith aux [0..] _tiles
|
||||
| movingCid == coerce 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
|
||||
| potentialCid == Just (coerce cid) = Just $ Point p
|
||||
| otherwise = Nothing
|
||||
|
||||
atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile])
|
||||
|
@ -990,7 +1128,7 @@ characterAt p f board = inner f board
|
|||
inner :: Traversal' BoardState (Maybe CharacterIdentifier)
|
||||
inner = atPoint p . _1 . filtered (/= board ^? movingUnit . _Just . _1)
|
||||
|
||||
adjacentUnits :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier]
|
||||
adjacentUnits :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe [CharacterIdentifier]
|
||||
adjacentUnits board cid = do
|
||||
originalLocation <- unitPosition board cid
|
||||
let adjacentTiles = usingBoardDimensions board adjacentPoints originalLocation
|
||||
|
@ -998,14 +1136,14 @@ adjacentUnits board cid = do
|
|||
let unitsAdjacent = mapMaybe (flip preview board . characterAt') adjacentTiles
|
||||
return unitsAdjacent
|
||||
|
||||
adjacentAllies :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier]
|
||||
adjacentAllies :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> 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
|
||||
isElevated :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Bool
|
||||
isElevated board cid = any (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid
|
||||
|
||||
removeUnit :: CharacterIdentifier -> BoardState -> BoardState
|
||||
removeUnit cid = tiles . each . _1 %~ mfilter (/= cid)
|
||||
removeUnit :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> BoardState -> BoardState
|
||||
removeUnit cid = tiles . each . _1 %~ mfilter (/= coerce cid)
|
||||
|
||||
setUnit :: CharacterIdentifier -> Point -> BoardState -> BoardState
|
||||
setUnit character point = atPoint point . _1 ?~ character
|
||||
|
|
|
@ -5,16 +5,15 @@ module Units.Carcass
|
|||
|
||||
import GameModel
|
||||
( adjacentAllies
|
||||
, ActingUnit
|
||||
, Armor(..)
|
||||
, BaseStats(..)
|
||||
, BoardState
|
||||
, CharacterIdentifier
|
||||
, Choice
|
||||
, DamageType(..)
|
||||
, Effect(..)
|
||||
, Stat(..)
|
||||
, Token(..)
|
||||
, Trigger(..)
|
||||
, Trait(..)
|
||||
, Modifier(..)
|
||||
)
|
||||
|
@ -23,6 +22,7 @@ import Units.Components
|
|||
, anyTarget
|
||||
, buildAttack, inflictTokens, push
|
||||
)
|
||||
import Data.Monoid (Sum)
|
||||
|
||||
gunwight :: BaseStats
|
||||
gunwight = BaseStats
|
||||
|
@ -35,7 +35,7 @@ gunwight = BaseStats
|
|||
, traits = [formation]
|
||||
}
|
||||
|
||||
gunwightActions :: [CharacterIdentifier -> Choice]
|
||||
gunwightActions :: [ActingUnit -> Choice]
|
||||
gunwightActions =
|
||||
[ buildAttack $ AttackT
|
||||
{ tName = "OL45"
|
||||
|
@ -66,6 +66,7 @@ formation = Trait
|
|||
, traitModifiers = [formationModifier]
|
||||
}
|
||||
where
|
||||
formationF :: BoardState -> CharacterIdentifier -> Sum Int
|
||||
formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0
|
||||
formationModifier = Modifier
|
||||
{ modifierStat = AttackDice
|
||||
|
|
|
@ -8,6 +8,7 @@ module Units.Components
|
|||
, inflictTokens
|
||||
, push
|
||||
, pull
|
||||
, inflictStatusEffect
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -18,10 +19,13 @@ import GameModel
|
|||
, Choice
|
||||
, DamageType
|
||||
, Effect(..)
|
||||
, mkChoice, Token, forcedMove, ForcedMoveType (..), owner
|
||||
, ActingUnit(..), TargettedUnit(..)
|
||||
, actingUnit
|
||||
, mkChoice, Token, forcedMove, ForcedMoveType (..), owner, StatusEffect, DieFace
|
||||
)
|
||||
|
||||
import Numeric.Natural (Natural)
|
||||
import Lens.Micro
|
||||
|
||||
-------------------------
|
||||
-- Attacks & Abilities --
|
||||
|
@ -30,7 +34,7 @@ import Numeric.Natural (Natural)
|
|||
data AttackT = AttackT
|
||||
{ tName :: String
|
||||
, tRange :: (Natural, Natural)
|
||||
, tValidTargets :: BoardState -> CharacterIdentifier -> Bool
|
||||
, tValidTargets :: BoardState -> TargettedUnit -> Bool
|
||||
, tMelee :: Bool
|
||||
, tDamageType :: DamageType
|
||||
, tDamageAmount :: Natural
|
||||
|
@ -38,16 +42,16 @@ data AttackT = AttackT
|
|||
, tStandardEffects :: [ProtoEffect]
|
||||
}
|
||||
|
||||
anyTarget :: BoardState -> CharacterIdentifier -> Bool
|
||||
anyTarget :: BoardState -> TargettedUnit -> Bool
|
||||
anyTarget = const $ const True
|
||||
|
||||
buildAttack :: AttackT -> CharacterIdentifier -> Choice
|
||||
buildAttack :: AttackT -> ActingUnit -> Choice
|
||||
buildAttack (AttackT {..}) attacker = mkChoice tName [targetEffect]
|
||||
where
|
||||
attackDetails target = Attack
|
||||
((sequence $ sequence tHeadshotEffects attacker) target)
|
||||
(mkEffect attacker target tHeadshotEffects)
|
||||
tMelee
|
||||
((sequence $ sequence tStandardEffects attacker) target)
|
||||
(mkEffect attacker target tStandardEffects)
|
||||
tDamageType
|
||||
tDamageAmount
|
||||
attackEffect target = [ResolveAttack attacker (attackDetails target) target]
|
||||
|
@ -58,20 +62,64 @@ data SelfAbilityT = SelfAbilityT
|
|||
, tEffects :: [ProtoEffect]
|
||||
}
|
||||
|
||||
mkSelfAbility :: SelfAbilityT -> CharacterIdentifier -> Choice
|
||||
mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (sequence (sequence tEffects cid) cid)
|
||||
mkSelfAbility :: SelfAbilityT -> ActingUnit -> Choice
|
||||
mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (mkEffect cid (TargettedUnit $ cid ^. actingUnit) tEffects)
|
||||
|
||||
-----------------------------
|
||||
--------- Effects -----------
|
||||
-----------------------------
|
||||
|
||||
type ProtoEffect = CharacterIdentifier -> CharacterIdentifier -> Effect
|
||||
-- | Indicates a possible argument to a protoeffect
|
||||
--
|
||||
-- A valid argument to a protoeffect is any argument with which provide by placing the
|
||||
-- protoeffect in an `Effect`. For example, a `DieFace` is a valid question because there
|
||||
-- exists an `Effect` which accepts a type @`DieFace` -> [`Effect`]@.
|
||||
--
|
||||
-- In additon, the actor and target (respectively) are available in the context, to enable
|
||||
-- asking questions about those things
|
||||
class Question t where
|
||||
askQuestion :: ActingUnit -> TargettedUnit -> (t -> [Effect]) -> [Effect]
|
||||
|
||||
instance Question ActingUnit where
|
||||
askQuestion actor _ f = f actor
|
||||
|
||||
instance Question TargettedUnit where
|
||||
askQuestion _ target f = f target
|
||||
|
||||
-- | A function which can be converted into a sequence of effects
|
||||
--
|
||||
-- Used in `buildProtoEffect` to create a `ProtoEffect`
|
||||
class ProtoEffectF t where
|
||||
mkEffect :: ActingUnit -> TargettedUnit -> t -> [Effect]
|
||||
|
||||
instance ProtoEffectF f => ProtoEffectF [f] where
|
||||
mkEffect a t = (mkEffect a t =<<)
|
||||
|
||||
instance ProtoEffectF Effect where
|
||||
mkEffect _ _ = pure
|
||||
|
||||
instance ProtoEffectF ProtoEffect where
|
||||
mkEffect attacker target pe = mkEffect' attacker target pe
|
||||
|
||||
instance (ProtoEffectF a, Question q) => ProtoEffectF (q -> a) where
|
||||
mkEffect attacker target f = askQuestion attacker target (mkEffect attacker target <$> f)
|
||||
|
||||
data ProtoEffect = forall f. ProtoEffectF f => MkProtoEffect f
|
||||
|
||||
mkEffect' :: ActingUnit -> TargettedUnit -> ProtoEffect -> [Effect]
|
||||
mkEffect' attacker target (MkProtoEffect pe) = mkEffect attacker target pe
|
||||
|
||||
mkEffects' :: ActingUnit -> TargettedUnit -> [ProtoEffect] -> [Effect]
|
||||
mkEffects' a t = (mkEffect a t =<<)
|
||||
|
||||
inflictStatusEffect :: StatusEffect -> ProtoEffect
|
||||
inflictStatusEffect se = MkProtoEffect $ InflictStatusEffect se
|
||||
|
||||
inflictTokens :: Num n => Token n -> n -> ProtoEffect
|
||||
inflictTokens tokenType tokenCount _ = InflictTokens tokenType tokenCount
|
||||
inflictTokens tokenType tokenCount = MkProtoEffect $ InflictTokens tokenType tokenCount
|
||||
|
||||
genericShift :: ForcedMoveType -> Natural -> ProtoEffect
|
||||
genericShift fmType amount puller = forcedMove fmType amount (owner puller) (Left puller)
|
||||
genericShift fmType amount = MkProtoEffect $ (\(ActingUnit puller) -> forcedMove fmType amount (owner puller) (Left puller))
|
||||
|
||||
push :: Natural -> ProtoEffect
|
||||
push = genericShift Push
|
||||
|
|
|
@ -4,12 +4,16 @@ module Units.Debug
|
|||
where
|
||||
|
||||
import GameModel
|
||||
( Armor(..)
|
||||
( Armor(..), ActingUnit
|
||||
, BaseStats(..)
|
||||
, CharacterIdentifier
|
||||
, Choice
|
||||
, DamageType(..)
|
||||
, Token(..)
|
||||
, Token(..), StatusEffect (..)
|
||||
, Hook(..), Effect(..)
|
||||
, Trigger(..), BoardState
|
||||
, TargettedUnit(..)
|
||||
, targettedUnit
|
||||
)
|
||||
|
||||
import Units.Components
|
||||
|
@ -18,8 +22,11 @@ import Units.Components
|
|||
, buildAttack
|
||||
, SelfAbilityT(..)
|
||||
, mkSelfAbility, inflictTokens, pull, push
|
||||
, inflictStatusEffect
|
||||
)
|
||||
|
||||
import Lens.Micro
|
||||
|
||||
basic :: BaseStats
|
||||
basic = BaseStats
|
||||
{ name = "Basic Debug Unit"
|
||||
|
@ -31,7 +38,7 @@ basic = BaseStats
|
|||
, traits = []
|
||||
}
|
||||
|
||||
basicActions :: [CharacterIdentifier -> Choice]
|
||||
basicActions :: [ActingUnit -> Choice]
|
||||
basicActions =
|
||||
[ buildAttack $ AttackT
|
||||
{ tName = "Peashooter"
|
||||
|
@ -102,7 +109,36 @@ basicActions =
|
|||
, tEffects = [inflictTokens SpeedSlow 1]
|
||||
}
|
||||
, mkSelfAbility $ SelfAbilityT
|
||||
{ tName = "Get String"
|
||||
, tEffects = [inflictTokens StrWeak 1]
|
||||
{ tName = "Blood Shield"
|
||||
, tEffects = [inflictStatusEffect bloodShield]
|
||||
}
|
||||
]
|
||||
]
|
||||
|
||||
bloodShield :: StatusEffect
|
||||
bloodShield = StatusEffect
|
||||
{ seName = "Blood Shield"
|
||||
, seHooks =
|
||||
[ Hook
|
||||
{ hookTrigger = TookDamage
|
||||
, hookEffect = damageHookEffect
|
||||
}
|
||||
]
|
||||
, seModifiers = []
|
||||
, seUpdate =
|
||||
[ Hook
|
||||
{ hookTrigger = TookDamage
|
||||
, hookEffect = damageHookDecrement
|
||||
}
|
||||
]
|
||||
, seState = 1
|
||||
, seShowState = \n -> '(' : replicate n '*' ++ ")"
|
||||
}
|
||||
where
|
||||
damageHookEffect :: TargettedUnit -> BoardState -> Int -> CharacterIdentifier -> [Effect]
|
||||
damageHookEffect (TargettedUnit injuredUnit) _ _ us =
|
||||
[InflictTokens VitalVulnr 1 (TargettedUnit us) | injuredUnit == us ]
|
||||
damageHookDecrement :: TargettedUnit -> BoardState -> Int -> CharacterIdentifier -> Maybe Int
|
||||
damageHookDecrement damagedUnit _ n us
|
||||
| damagedUnit ^. targettedUnit == us && n > 1 = Just $ pred n
|
||||
| damagedUnit ^. targettedUnit == us = Nothing
|
||||
| otherwise = Just n
|
|
@ -8,7 +8,6 @@ module Util
|
|||
, note
|
||||
) where
|
||||
|
||||
import Data.Bool (bool)
|
||||
import Lens.Micro.TH (LensRules, lensRules, lensField, DefName (TopName))
|
||||
import Language.Haskell.TH (mkName, nameBase)
|
||||
import Lens.Micro
|
||||
|
@ -24,7 +23,7 @@ infixl 4 ??
|
|||
f ?? a = ($ a) <$> f
|
||||
|
||||
secondClassLensNames :: LensRules
|
||||
secondClassLensNames = lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "L"])
|
||||
secondClassLensNames = lensRules & lensField .~ (\_ _ n -> [TopName . mkName $ nameBase n ++ "L"])
|
||||
|
||||
data Never
|
||||
|
||||
|
|
Loading…
Reference in New Issue