diff --git a/package.yaml b/package.yaml index 008a66e..f87938b 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,7 @@ library: - ScopedTypeVariables - EmptyCase - DuplicateRecordFields + - StandaloneDeriving executables: maleghast-exe: diff --git a/src/GameLogic.hs b/src/GameLogic.hs index 2b390b9..09afae8 100644 --- a/src/GameLogic.hs +++ b/src/GameLogic.hs @@ -34,7 +34,7 @@ computeStat :: BoardState -> CharacterIdentifier -> 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 @@ -109,8 +109,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 cid | movSpendTokens ] + ++ [Event $ Broadcast EndMove cid | movEndMoveTrigger] generateMovementChoice :: BoardState -> MovementSpecs -> CharacterIdentifier -> Point -> (Point, Natural) -> Choice generateMovementChoice board specs@(MovementSpecs {..}) cid originalLocation (dest, remainingMov) = @@ -201,7 +201,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 cid choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3 applyEffect (MoveTo dest) board = continue $ moveUnit dest board applyEffect (DropToken token unit) board = continue $ @@ -284,7 +284,8 @@ applyEffect (InflictDamage damageType incomingAmount recipient) board = continue 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 @@ -293,7 +294,7 @@ applyEffect (Kill unit) board = if isNecromancer unit 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 diff --git a/src/GameModel.hs b/src/GameModel.hs index a0e9158..3add604 100644 --- a/src/GameModel.hs +++ b/src/GameModel.hs @@ -47,6 +47,8 @@ module GameModel , otherPlayer , Token(..) , ofToken + , tokenEq + , Broadcast(..) , Stat(..) , BaseStats(..) , nameL @@ -127,8 +129,6 @@ module GameModel , allStatsAreMonoids , HasMonoidInstance , Hook(..) - , hookTriggerL - , hookEffectL , hookToFunc , hooksToFunc , Modifier(..) @@ -298,12 +298,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 CharacterIdentifier + Died :: Trigger (CharacterIdentifier, Point) + EndMove :: Trigger CharacterIdentifier + +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 @@ -438,7 +455,7 @@ 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 @@ -497,6 +514,11 @@ data Effect Natural -- ^ Damage amount CharacterIdentifier -- ^ Target + -- | Add a status effect to a character + | InflictStatusEffect + StatusEffect -- ^ Effect to inflict + CharacterIdentifier -- ^ Target + | forall n. Num n => InflictTokens (Token n) -- ^ Token kind n -- ^ Token amount @@ -559,22 +581,22 @@ data BaseStats = BaseStats } -- | 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 -> Trigger -> BoardState -> h -hookToFunc (Hook {..}) trigger - | hookTrigger == trigger = hookEffect - | otherwise = mempty +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] -> Trigger -> BoardState -> h +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 @@ -622,8 +644,16 @@ data StatusEffect = forall a. StatusEffect -- | 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) @@ -696,7 +726,12 @@ data Character = Character } 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' @@ -741,21 +776,25 @@ makeLensesWith secondClassLensNames ''Hook makeLensesWith secondClassLensNames ''Trait instance Functor Hook where - fmap f hook = hook & hookEffectL . mapped %~ f - v <$ Hook {..} = Hook {hookEffect = const v, ..} + 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 :: Trigger -> BoardState -> CharacterIdentifier -> StatusEffect -> Maybe StatusEffect -seDoUpdate trigger board cid (StatusEffect {..}) = case relevantUpdates of +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)) - relevantHooks = seUpdate' ^.. each . filtered ((trigger==) . hookTrigger) . hookEffectL + 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 @@ -815,7 +854,7 @@ computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of -- 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]] -> Trigger -> BoardState -> BoardState +runHooks_ :: [Hook [Effect]] -> Broadcast -> BoardState -> BoardState runHooks_ globalHooks trigger board = boardWithUpdates <++ allEffects where unitAllEffectHooks :: (CharacterIdentifier, Character) -> [Hook [Effect]] diff --git a/src/Units/Components.hs b/src/Units/Components.hs index 4df0888..8b0d25c 100644 --- a/src/Units/Components.hs +++ b/src/Units/Components.hs @@ -8,6 +8,7 @@ module Units.Components , inflictTokens , push , pull + , inflictStatusEffect ) where @@ -18,7 +19,7 @@ import GameModel , Choice , DamageType , Effect(..) - , mkChoice, Token, forcedMove, ForcedMoveType (..), owner + , mkChoice, Token, forcedMove, ForcedMoveType (..), owner, StatusEffect ) import Numeric.Natural (Natural) @@ -67,6 +68,9 @@ mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (sequence (sequence tEffe type ProtoEffect = CharacterIdentifier -> CharacterIdentifier -> Effect +inflictStatusEffect :: StatusEffect -> ProtoEffect +inflictStatusEffect se _ = InflictStatusEffect se + inflictTokens :: Num n => Token n -> n -> ProtoEffect inflictTokens tokenType tokenCount _ = InflictTokens tokenType tokenCount diff --git a/src/Units/Debug.hs b/src/Units/Debug.hs index d02b27a..c943bbf 100644 --- a/src/Units/Debug.hs +++ b/src/Units/Debug.hs @@ -9,7 +9,9 @@ import GameModel , CharacterIdentifier , Choice , DamageType(..) - , Token(..) + , Token(..), StatusEffect (..) + , Hook(..), Effect(..) + , Trigger(..), BoardState ) import Units.Components @@ -18,6 +20,7 @@ import Units.Components , buildAttack , SelfAbilityT(..) , mkSelfAbility, inflictTokens, pull, push + , inflictStatusEffect ) basic :: BaseStats @@ -102,7 +105,35 @@ basicActions = , tEffects = [inflictTokens SpeedSlow 1] } , mkSelfAbility $ SelfAbilityT - { tName = "Get String" - , tEffects = [inflictTokens StrWeak 1] + { tName = "Blood Shield" + , tEffects = [inflictStatusEffect bloodShield] } - ] \ No newline at end of file + ] + +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 :: CharacterIdentifier -> BoardState -> Int -> CharacterIdentifier -> [Effect] + damageHookEffect damagedUnit _ _ us = if damagedUnit == us then [InflictTokens VitalVulnr 1 us] else [] + damageHookDecrement :: CharacterIdentifier -> BoardState -> Int -> CharacterIdentifier -> Maybe Int + damageHookDecrement damagedUnit _ n us + | damagedUnit == us && n > 1 = Just $ pred n + | damagedUnit == us = Nothing + | otherwise = Just n \ No newline at end of file