Emi
/
maleghast-engine
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rework the protoeffect system 

& Add ActingUnit/TargettedUnit newtypes
This commit is contained in:
Emi Simpson 2023-12-09 22:45:39 -05:00
parent 7a501ac927
commit 4e408135d8
Signed by: Emi
GPG Key ID: A12F2C2FFDC3D847
5 changed files with 169 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/GameLogic.hs
View File

@ -28,9 +28,10 @@ import Safe (atMay)
import Mechanics (universalModifiers, globalHooks) import Mechanics (universalModifiers, globalHooks)
import Data.Monoid (Any(getAny), getSum) import Data.Monoid (Any(getAny), getSum)
import Data.Coerce
-- | A version of `computeStat_` using `universalModifiers` as global modifiers -- | 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 computeStat = computeStat_ universalModifiers
-- | A version of `runHooks_` using `globalHooks` as the global hooks -- | A version of `runHooks_` using `globalHooks` as the global hooks
@ -49,7 +50,7 @@ data EngineState
playerChoice :: Player -> [Choice] -> EngineState playerChoice :: Player -> [Choice] -> EngineState
playerChoice = PlayerChoice playerChoice = PlayerChoice
unitChoice :: CharacterIdentifier -> [Choice] -> EngineState unitChoice :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> [Choice] -> EngineState
unitChoice = playerChoice . owner unitChoice = playerChoice . owner
activePlayerChoice :: BoardState -> [Choice] -> EngineState activePlayerChoice :: BoardState -> [Choice] -> EngineState
@ -64,8 +65,8 @@ chooseCharacter board = playerChoice player <$> fmap toList (nonEmpty $ board ^.
player :: Player player :: Player
player = board ^. activePlayer player = board ^. activePlayer
possibleActivations :: SimpleFold BoardState Choice possibleActivations :: SimpleFold BoardState Choice
possibleActivations = untappedUnits . filtered ((== player) . owner) . to activateUnit possibleActivations = untappedUnits . filtered ((== player) . owner) . to (activateUnit . ActingUnit)
activateUnit :: CharacterIdentifier -> Choice activateUnit :: ActingUnit -> Choice
activateUnit cid = mkChoice ("Activate unit " ++ c) [ChooseActMove cid] activateUnit cid = mkChoice ("Activate unit " ++ c) [ChooseActMove cid]
where where
c = renderCharacterHandle board cid c = renderCharacterHandle board cid
@ -109,8 +110,8 @@ computePossibleSteps board (MovementSpecs {..}) currentLocation = mapMaybe getRe
endOfMovementEffects :: MovementSpecs -> CharacterIdentifier -> [Effect] endOfMovementEffects :: MovementSpecs -> CharacterIdentifier -> [Effect]
endOfMovementEffects (MovementSpecs {..}) cid = endOfMovementEffects (MovementSpecs {..}) cid =
[ConfirmMove] [ConfirmMove]
++ [DropToken SpeedSlow cid | movSpendTokens ] ++ [DropToken SpeedSlow (TargettedUnit cid) | movSpendTokens ]
++ [Event $ Broadcast EndMove cid | movEndMoveTrigger] ++ [Event $ Broadcast EndMove (ActingUnit cid) | movEndMoveTrigger]
generateMovementChoice :: BoardState -> MovementSpecs -> CharacterIdentifier -> Point -> (Point, Natural) -> Choice generateMovementChoice :: BoardState -> MovementSpecs -> CharacterIdentifier -> Point -> (Point, Natural) -> Choice
generateMovementChoice board specs@(MovementSpecs {..}) cid originalLocation (dest, remainingMov) = generateMovementChoice board specs@(MovementSpecs {..}) cid originalLocation (dest, remainingMov) =
@ -201,7 +202,7 @@ applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board
dontMoveChoice = mkChoice "Don't move" dontMoveEffects dontMoveChoice = mkChoice "Don't move" dontMoveEffects
finishMoveEffects = endOfMovementEffects specs cid finishMoveEffects = endOfMovementEffects specs cid
finishMoveChoice = mkChoice "Finish moving" finishMoveEffects finishMoveChoice = mkChoice "Finish moving" finishMoveEffects
endMoveTrigger = Event $ Broadcast EndMove cid endMoveTrigger = Event $ Broadcast EndMove (ActingUnit cid)
choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3 choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3
applyEffect (MoveTo dest) board = continue $ moveUnit dest board applyEffect (MoveTo dest) board = continue $ moveUnit dest board
applyEffect (DropToken token unit) board = continue $ applyEffect (DropToken token unit) board = continue $
@ -213,22 +214,22 @@ applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actio
applyEffect (Target fromPerspective range eligability ultimateEffect) board = unitChoice fromPerspective choices applyEffect (Target fromPerspective range eligability ultimateEffect) board = unitChoice fromPerspective choices
where where
locus = unitPosition board fromPerspective locus = unitPosition board fromPerspective
potentialUnits = maybe [] (cidsInRange board range) locus potentialUnits = TargettedUnit <$> (maybe [] (cidsInRange board range) locus)
eligableUnits = filter (eligability board) potentialUnits eligableUnits = filter (eligability board) potentialUnits
buildChoice targetCid = buildChoice targetCid =
mkChoice mkChoice
("Target " ++ renderCharacterHandle board targetCid) ("Target " ++ renderCharacterHandle board targetCid)
[BodyBlock targetCid ultimateEffect] [BodyBlock targetCid ultimateEffect]
choices = buildChoice <$> eligableUnits 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 where
potentialBBers = fromMaybe [] $ adjacentAllies board targettedUnit potentialBBers = fromMaybe [] $ adjacentAllies board originalTarget
canBB = isNecromancer targettedUnit && not (null potentialBBers) canBB = isNecromancer originalTarget && not (null potentialBBers)
buildChoice bber = mkChoice ("Bodyblock with " ++ renderCharacterHandle board bber) (ultimateEffect bber) buildChoice bber = mkChoice ("Bodyblock with " ++ renderCharacterHandle board bber) (ultimateEffect bber)
dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect targettedUnit) dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect originalTarget)
bbChoices = buildChoice <$> potentialBBers bbChoices = buildChoice . TargettedUnit <$> potentialBBers
allChoices = unitChoice targettedUnit $ dontBodyblock : bbChoices allChoices = unitChoice originalTarget $ dontBodyblock : bbChoices
cantBBResult = continue $ board <++ ultimateEffect targettedUnit cantBBResult = continue $ board <++ ultimateEffect originalTarget
applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRolled keepHighest consequence applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRolled keepHighest consequence
where where
attacker' = board ^? ixCharacter attacker attacker' = board ^? ixCharacter attacker

124
src/GameModel.hs
View File

@ -6,6 +6,10 @@ module GameModel
, Armor(..) , Armor(..)
, DamageType(..) , DamageType(..)
, Attack(Attack) , Attack(Attack)
, ActingUnit(..)
, actingUnit
, TargettedUnit(..)
, targettedUnit
, headshotEffectsL , headshotEffectsL
, meleeL , meleeL
, otherEffectsL , otherEffectsL
@ -69,6 +73,7 @@ module GameModel
, getDefense , getDefense
, statusEffects , statusEffects
, CharacterIdentifier , CharacterIdentifier
, cidEq
, owner , owner
, ownerL , ownerL
, isNecromancer , isNecromancer
@ -158,6 +163,7 @@ import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics)
import Lens.Micro.Extras (preview) import Lens.Micro.Extras (preview)
import Data.Data ((:~:)(..)) import Data.Data ((:~:)(..))
import System.Random (Random(..)) import System.Random (Random(..))
import Data.Coerce
data DieFace = One | Two | Three | Four | Five | Six data DieFace = One | Two | Three | Four | Five | Six
deriving (Eq, Ord, Enum, Read) deriving (Eq, Ord, Enum, Read)
@ -224,14 +230,23 @@ instance Num DieFace where
type CharacterIdentifier = (Player, Int) type CharacterIdentifier = (Player, Int)
owner :: CharacterIdentifier -> Player cidEq :: (Coercible a b, Eq b) => a -> b -> Bool
owner = fst 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 :: Lens' CharacterIdentifier Player
ownerL = _1 ownerL = _1
isNecromancer :: CharacterIdentifier -> Bool isNecromancer :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Bool
isNecromancer = snd >>> (== 0) isNecromancer cid' = (==0) $ snd cid
where
cid :: CharacterIdentifier
cid = coerce cid'
showCID :: CharacterIdentifier -> Char showCID :: CharacterIdentifier -> Char
showCID (cidOwner, idx) = (if cidOwner == Max then upperLetters else lowerLetters) !! idx showCID (cidOwner, idx) = (if cidOwner == Max then upperLetters else lowerLetters) !! idx
@ -300,9 +315,9 @@ enumeratePoints w h = Point <$> [0..w * h - 1]
data Trigger a where data Trigger a where
TurnStart :: Trigger () TurnStart :: Trigger ()
TookDamage :: Trigger CharacterIdentifier TookDamage :: Trigger TargettedUnit
Died :: Trigger (CharacterIdentifier, Point) Died :: Trigger (TargettedUnit, Point)
EndMove :: Trigger CharacterIdentifier EndMove :: Trigger ActingUnit
deriving instance Eq (Trigger a) deriving instance Eq (Trigger a)
deriving instance Show (Trigger a) deriving instance Show (Trigger a)
@ -423,8 +438,8 @@ data ProtoMovementSpecs = ProtoMovementSpecs
, movCompelled :: Bool -- ^ If movement can be stopped prematurely , movCompelled :: Bool -- ^ If movement can be stopped prematurely
} }
basicMove :: CharacterIdentifier -> Effect basicMove :: ActingUnit -> Effect
basicMove = InitMove $ ProtoMovementSpecs basicMove = (InitMove $ ProtoMovementSpecs
{ movVerb = "Move" { movVerb = "Move"
, movFree' = Nothing , movFree' = Nothing
, movMinimum = True , movMinimum = True
@ -433,10 +448,10 @@ basicMove = InitMove $ ProtoMovementSpecs
, movSpendTokens = True , movSpendTokens = True
, movEndMoveTrigger = True , movEndMoveTrigger = True
, movCompelled = False , movCompelled = False
} }) . (^. actingUnit)
forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> CharacterIdentifier -> Effect forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> TargettedUnit -> Effect
forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs forcedMove fmType amt compeller locus = (InitMove $ ProtoMovementSpecs
{ movVerb = show fmType { movVerb = show fmType
, movFree' = Just True , movFree' = Just True
, movMinimum = False , movMinimum = False
@ -445,7 +460,25 @@ forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs
, movSpendTokens = False , movSpendTokens = False
, movEndMoveTrigger = False , movEndMoveTrigger = False
, movCompelled = True , 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 data Effect
@ -458,10 +491,10 @@ data Effect
| Event Broadcast | Event Broadcast
-- | Active player chooses whether they want to move or act first -- | 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 -- | Active player may choose whether they want to act or move
| ActOrMove CharacterIdentifier | ActOrMove ActingUnit
-- | Mark the start of movement -- | Mark the start of movement
-- Can be finalized later with FinalizeMove -- Can be finalized later with FinalizeMove
@ -483,51 +516,51 @@ data Effect
-- | Remove up to one token from the given category from a unit -- | Remove up to one token from the given category from a unit
| forall n. Num n => DropToken | forall n. Num n => DropToken
(Token n) -- ^ The token category to drop from (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 -- | Confirms a Move, placing the unit in the target space
| ConfirmMove | ConfirmMove
-- | Allow a character to Act -- | Allow a character to Act
| Act CharacterIdentifier | Act ActingUnit
-- | Target a unit in a given range, then run a different event -- | Target a unit in a given range, then run a different event
| Target | Target
CharacterIdentifier -- ^ ACTing unit ActingUnit -- ^ ACTing unit
(Natural, Natural) -- ^ Range (Natural, Natural) -- ^ Range
(BoardState -> CharacterIdentifier -> Bool) -- ^ Target filter (BoardState -> TargettedUnit -> Bool) -- ^ Target filter
(CharacterIdentifier -> [Effect]) -- ^ Ultimate effect (TargettedUnit -> [Effect]) -- ^ Ultimate effect
-- | Check if a character can body block -- | Check if a character can body block
-- If they can, offer a choice of target to the targetted player. Pass result on to -- If they can, offer a choice of target to the targetted player. Pass result on to
-- the effect. -- the effect.
| BodyBlock CharacterIdentifier (CharacterIdentifier -> [Effect]) | BodyBlock TargettedUnit (TargettedUnit -> [Effect])
-- | Resolve an attack -- | Resolve an attack
| ResolveAttack | ResolveAttack
CharacterIdentifier -- ^ Attacker ActingUnit -- ^ Attacker
Attack -- ^ Attack information Attack -- ^ Attack information
CharacterIdentifier -- ^ Target TargettedUnit -- ^ Target
| InflictDamage | InflictDamage
DamageType DamageType
Natural -- ^ Damage amount Natural -- ^ Damage amount
CharacterIdentifier -- ^ Target TargettedUnit -- ^ Target
-- | Add a status effect to a character -- | Add a status effect to a character
| InflictStatusEffect | InflictStatusEffect
StatusEffect -- ^ Effect to inflict StatusEffect -- ^ Effect to inflict
CharacterIdentifier -- ^ Target TargettedUnit -- ^ Target
| forall n. Num n => InflictTokens | forall n. Num n => InflictTokens
(Token n) -- ^ Token kind (Token n) -- ^ Token kind
n -- ^ Token amount n -- ^ Token amount
CharacterIdentifier -- ^ Target TargettedUnit -- ^ Target
| Kill CharacterIdentifier | Kill TargettedUnit
-- | Tap the active unit, change the active player -- | Tap the active unit, change the active player
| EndTurn CharacterIdentifier | EndTurn ActingUnit
data Attack = Attack data Attack = Attack
{ headshotEffects :: [Effect] { headshotEffects :: [Effect]
@ -577,7 +610,7 @@ data BaseStats = BaseStats
, df :: DieFace , df :: DieFace
, arm :: Armor , arm :: Armor
, traits :: [Trait] , traits :: [Trait]
, actions :: [CharacterIdentifier -> Choice] , actions :: [ActingUnit -> Choice]
} }
-- | Some effect which is activated by some trigger event -- | Some effect which is activated by some trigger event
@ -838,10 +871,11 @@ untap = movedThisRound .~ False
-- --
-- This includes so called global modifiers, but in order to keep game rules seperate from -- 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. -- the model, global modifiers must be provided as the first argument.
computeStat_ :: [Modifier] -> BoardState -> CharacterIdentifier -> Stat a -> a computeStat_ :: (Coercible cid c, c ~ CharacterIdentifier) => [Modifier] -> BoardState -> cid -> Stat a -> a
computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of computeStat_ globalModifiers board cid' stat = case allStatsAreMonoids stat of
HasMonoidInstance Refl -> HasMonoidInstance Refl ->
let let
cid = coerce cid'
queryStatsL = each . to (queryModifier board cid stat) queryStatsL = each . to (queryModifier board cid stat)
globalBonus = globalModifiers ^. queryStatsL globalBonus = globalModifiers ^. queryStatsL
traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL
@ -1016,11 +1050,13 @@ offsetB b = usingBoardDimensions b offset
eachCID :: Monoid m => Getting m BoardState CharacterIdentifier eachCID :: Monoid m => Getting m BoardState CharacterIdentifier
eachCID = tiles . each . _1 . _Just eachCID = tiles . each . _1 . _Just
ixCharacter :: CharacterIdentifier -> Traversal' BoardState Character ixCharacter :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Traversal' BoardState Character
ixCharacter (player, indx) = characters . forPlayer player . ix indx ixCharacter cid = case coerce cid of (player, indx) -> characters . forPlayer player . ix indx
renderCharacterHandle :: BoardState -> CharacterIdentifier -> String renderCharacterHandle :: (Coercible a b, b ~ CharacterIdentifier) => BoardState -> a -> String
renderCharacterHandle board cid = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid renderCharacterHandle board cid' = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid
where
cid = coerce cid'
eachCharacter :: Traversal' BoardState Character eachCharacter :: Traversal' BoardState Character
eachCharacter = characters . everybody . traverse eachCharacter = characters . everybody . traverse
@ -1070,14 +1106,14 @@ isAlive board cid = has (eachCID . filtered (== cid)) board
pushEffects :: [Effect] -> BoardState -> BoardState pushEffects :: [Effect] -> BoardState -> BoardState
pushEffects newEffects = effectStack %~ (newEffects ++) 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 unitPosition (BoardState {_movingUnit=Just (movingCid, movingPoint)}) cid
| movingCid == cid = Just movingPoint | movingCid == coerce cid = Just movingPoint
unitPosition (BoardState {_tiles}) cid = headMay . catMaybes $ zipWith aux [0..] _tiles unitPosition (BoardState {_tiles}) cid = headMay . catMaybes $ zipWith aux [0..] _tiles
where where
aux :: Natural -> (Maybe CharacterIdentifier, [EnvTile]) -> Maybe Point aux :: Natural -> (Maybe CharacterIdentifier, [EnvTile]) -> Maybe Point
aux p (potentialCid, _) aux p (potentialCid, _)
| potentialCid == Just cid = Just $ Point p | potentialCid == Just (coerce cid) = Just $ Point p
| otherwise = Nothing | otherwise = Nothing
atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile]) atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile])
@ -1092,7 +1128,7 @@ characterAt p f board = inner f board
inner :: Traversal' BoardState (Maybe CharacterIdentifier) inner :: Traversal' BoardState (Maybe CharacterIdentifier)
inner = atPoint p . _1 . filtered (/= board ^? movingUnit . _Just . _1) 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 adjacentUnits board cid = do
originalLocation <- unitPosition board cid originalLocation <- unitPosition board cid
let adjacentTiles = usingBoardDimensions board adjacentPoints originalLocation let adjacentTiles = usingBoardDimensions board adjacentPoints originalLocation
@ -1100,14 +1136,14 @@ adjacentUnits board cid = do
let unitsAdjacent = mapMaybe (flip preview board . characterAt') adjacentTiles let unitsAdjacent = mapMaybe (flip preview board . characterAt') adjacentTiles
return unitsAdjacent 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 adjacentAllies board cid = filter (owner >>> (owner cid ==)) <$> adjacentUnits board cid
isElevated :: BoardState -> CharacterIdentifier -> Bool isElevated :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Bool
isElevated board cid = any (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid isElevated board cid = any (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid
removeUnit :: CharacterIdentifier -> BoardState -> BoardState removeUnit :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> BoardState -> BoardState
removeUnit cid = tiles . each . _1 %~ mfilter (/= cid) removeUnit cid = tiles . each . _1 %~ mfilter (/= coerce cid)
setUnit :: CharacterIdentifier -> Point -> BoardState -> BoardState setUnit :: CharacterIdentifier -> Point -> BoardState -> BoardState
setUnit character point = atPoint point . _1 ?~ character setUnit character point = atPoint point . _1 ?~ character

6
src/Units/Carcass.hs
View File

@ -5,8 +5,10 @@ module Units.Carcass
import GameModel import GameModel
( adjacentAllies ( adjacentAllies
, ActingUnit
, Armor(..) , Armor(..)
, BaseStats(..) , BaseStats(..)
, BoardState
, CharacterIdentifier , CharacterIdentifier
, Choice , Choice
, DamageType(..) , DamageType(..)
@ -20,6 +22,7 @@ import Units.Components
, anyTarget , anyTarget
, buildAttack, inflictTokens, push , buildAttack, inflictTokens, push
) )
import Data.Monoid (Sum)
gunwight :: BaseStats gunwight :: BaseStats
gunwight = BaseStats gunwight = BaseStats
@ -32,7 +35,7 @@ gunwight = BaseStats
, traits = [formation] , traits = [formation]
} }
gunwightActions :: [CharacterIdentifier -> Choice] gunwightActions :: [ActingUnit -> Choice]
gunwightActions = gunwightActions =
[ buildAttack $ AttackT [ buildAttack $ AttackT
{ tName = "OL45" { tName = "OL45"
@ -63,6 +66,7 @@ formation = Trait
, traitModifiers = [formationModifier] , traitModifiers = [formationModifier]
} }
where where
formationF :: BoardState -> CharacterIdentifier -> Sum Int
formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0 formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0
formationModifier = Modifier formationModifier = Modifier
{ modifierStat = AttackDice { modifierStat = AttackDice

68
src/Units/Components.hs
View File

@ -19,10 +19,13 @@ import GameModel
, Choice , Choice
, DamageType , DamageType
, Effect(..) , Effect(..)
, mkChoice, Token, forcedMove, ForcedMoveType (..), owner, StatusEffect , ActingUnit(..), TargettedUnit(..)
, actingUnit
, mkChoice, Token, forcedMove, ForcedMoveType (..), owner, StatusEffect, DieFace
) )
import Numeric.Natural (Natural) import Numeric.Natural (Natural)
import Lens.Micro
------------------------- -------------------------
-- Attacks & Abilities -- -- Attacks & Abilities --
@ -31,7 +34,7 @@ import Numeric.Natural (Natural)
data AttackT = AttackT data AttackT = AttackT
{ tName :: String { tName :: String
, tRange :: (Natural, Natural) , tRange :: (Natural, Natural)
, tValidTargets :: BoardState -> CharacterIdentifier -> Bool , tValidTargets :: BoardState -> TargettedUnit -> Bool
, tMelee :: Bool , tMelee :: Bool
, tDamageType :: DamageType , tDamageType :: DamageType
, tDamageAmount :: Natural , tDamageAmount :: Natural
@ -39,16 +42,16 @@ data AttackT = AttackT
, tStandardEffects :: [ProtoEffect] , tStandardEffects :: [ProtoEffect]
} }
anyTarget :: BoardState -> CharacterIdentifier -> Bool anyTarget :: BoardState -> TargettedUnit -> Bool
anyTarget = const $ const True anyTarget = const $ const True
buildAttack :: AttackT -> CharacterIdentifier -> Choice buildAttack :: AttackT -> ActingUnit -> Choice
buildAttack (AttackT {..}) attacker = mkChoice tName [targetEffect] buildAttack (AttackT {..}) attacker = mkChoice tName [targetEffect]
where where
attackDetails target = Attack attackDetails target = Attack
((sequence $ sequence tHeadshotEffects attacker) target) (mkEffect attacker target tHeadshotEffects)
tMelee tMelee
((sequence $ sequence tStandardEffects attacker) target) (mkEffect attacker target tStandardEffects)
tDamageType tDamageType
tDamageAmount tDamageAmount
attackEffect target = [ResolveAttack attacker (attackDetails target) target] attackEffect target = [ResolveAttack attacker (attackDetails target) target]
@ -59,23 +62,64 @@ data SelfAbilityT = SelfAbilityT
, tEffects :: [ProtoEffect] , tEffects :: [ProtoEffect]
} }
mkSelfAbility :: SelfAbilityT -> CharacterIdentifier -> Choice mkSelfAbility :: SelfAbilityT -> ActingUnit -> Choice
mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (sequence (sequence tEffects cid) cid) mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (mkEffect cid (TargettedUnit $ cid ^. actingUnit) tEffects)
----------------------------- -----------------------------
--------- Effects ----------- --------- 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 :: StatusEffect -> ProtoEffect
inflictStatusEffect se _ = InflictStatusEffect se inflictStatusEffect se = MkProtoEffect $ InflictStatusEffect se
inflictTokens :: Num n => Token n -> n -> ProtoEffect 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 :: 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 :: Natural -> ProtoEffect
push = genericShift Push push = genericShift Push

19
src/Units/Debug.hs
View File

@ -4,7 +4,7 @@ module Units.Debug
where where
import GameModel import GameModel
( Armor(..) ( Armor(..), ActingUnit
, BaseStats(..) , BaseStats(..)
, CharacterIdentifier , CharacterIdentifier
, Choice , Choice
@ -12,6 +12,8 @@ import GameModel
, Token(..), StatusEffect (..) , Token(..), StatusEffect (..)
, Hook(..), Effect(..) , Hook(..), Effect(..)
, Trigger(..), BoardState , Trigger(..), BoardState
, TargettedUnit(..)
, targettedUnit
) )
import Units.Components import Units.Components
@ -23,6 +25,8 @@ import Units.Components
, inflictStatusEffect , inflictStatusEffect
) )
import Lens.Micro
basic :: BaseStats basic :: BaseStats
basic = BaseStats basic = BaseStats
{ name = "Basic Debug Unit" { name = "Basic Debug Unit"
@ -34,7 +38,7 @@ basic = BaseStats
, traits = [] , traits = []
} }
basicActions :: [CharacterIdentifier -> Choice] basicActions :: [ActingUnit -> Choice]
basicActions = basicActions =
[ buildAttack $ AttackT [ buildAttack $ AttackT
{ tName = "Peashooter" { tName = "Peashooter"
@ -130,10 +134,11 @@ bloodShield = StatusEffect
, seShowState = \n -> '(' : replicate n '*' ++ ")" , seShowState = \n -> '(' : replicate n '*' ++ ")"
} }
where where
damageHookEffect :: CharacterIdentifier -> BoardState -> Int -> CharacterIdentifier -> [Effect] damageHookEffect :: TargettedUnit -> BoardState -> Int -> CharacterIdentifier -> [Effect]
damageHookEffect damagedUnit _ _ us = if damagedUnit == us then [InflictTokens VitalVulnr 1 us] else [] damageHookEffect (TargettedUnit injuredUnit) _ _ us =
damageHookDecrement :: CharacterIdentifier -> BoardState -> Int -> CharacterIdentifier -> Maybe Int [InflictTokens VitalVulnr 1 (TargettedUnit us) | injuredUnit == us ]
damageHookDecrement :: TargettedUnit -> BoardState -> Int -> CharacterIdentifier -> Maybe Int
damageHookDecrement damagedUnit _ n us damageHookDecrement damagedUnit _ n us
| damagedUnit == us && n > 1 = Just $ pred n | damagedUnit ^. targettedUnit == us && n > 1 = Just $ pred n
| damagedUnit == us = Nothing | damagedUnit ^. targettedUnit == us = Nothing
| otherwise = Just n | otherwise = Just n