Implement a new status effect system

src/GameModel.hs

@@ -65,6 +65,7 @@ module GameModel
     , clearUpToNTokens
     , getSpeed
     , getDefense
+    , statusEffects
     , CharacterIdentifier
     , owner
     , ownerL
@@ -128,6 +129,8 @@ module GameModel
     , Hook(..)
     , hookTriggerL
     , hookEffectL
+    , hookToFunc
+    , hooksToFunc
     , Modifier(..)
     , Trait(..)
     , traitNameL
@@ -135,6 +138,7 @@ module GameModel
     , traitModifiersL
     , computeStat_
     , runHooks_
+    , StatusEffect(..)
     ) where
 
 import Util (toMaybe, dup, secondClassLensNames, (??))
@@ -561,6 +565,18 @@ data Hook h = Hook
   , hookEffect  :: BoardState -> h
   }
 
+-- | 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
+
+-- | A version of `hookToFunc` which evaluates several hooks at once
+hooksToFunc :: Monoid h => [Hook h] -> Trigger -> 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
@@ -582,6 +598,32 @@ 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
+  }
+
 instance Show BaseStats where
   show stats = "===== " ++ name stats ++ " =====\nMV: " ++ show (mov stats) ++  "      DF: " ++ show (df stats) ++ "+      ARM: " ++ show (arm stats)
 
@@ -650,6 +692,7 @@ data Character = Character
   { _baseStats        :: BaseStats
   , _movedThisRound   :: Bool
   , _tokenCount       :: TokenCount
+  , _statusEffects    :: [StatusEffect]
   }
 
 instance Show Character where
@@ -697,8 +740,26 @@ makeLensesWith secondClassLensNames ''Hook
 
 makeLensesWith secondClassLensNames ''Trait
 
+instance Functor Hook where
+  fmap f hook = hook & hookEffectL . mapped %~ f
+  v <$ Hook {..} = Hook {hookEffect = 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
+  [] -> Just $ StatusEffect {..}
+  Nothing : _ -> Nothing
+  Just newState : _ -> Just $ StatusEffect {seState = newState, ..}
+  where
+    seUpdate' = seUpdate & each . mapped %~ (($ cid) . ($ seState))
+    relevantHooks = seUpdate' ^.. each . filtered ((trigger==) . hookTrigger) . hookEffectL
+    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
@@ -749,24 +810,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,
+-- Searches through all hooks in traits, statuse effects and global hooks, accumulates all
--- then adds all the resulting effects to the effect stack.  Similar to `computeStat_`,
+-- their effects, then adds all the resulting effects to the effect stack.  Then, all
--- this is additionall searches so called global hooks, but only recognizes global hooks
+-- necessary status effect updates are applied.  Similar to `computeStat_`, this is
--- passed as an argument.
+-- 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
+runHooks_ globalHooks trigger board = boardWithUpdates <++ allEffects
   where
-    filterActivatedL :: Traversal' (Hook a) (Hook a)
+    unitAllEffectHooks :: (CharacterIdentifier, Character) -> [Hook [Effect]]
-    filterActivatedL = filtered ((==trigger) . hookTrigger)
+    unitAllEffectHooks (cid, c) = allHooks <&> (?? cid)
-    unitHooksL :: SimpleFold Character (BoardState -> CharacterIdentifier -> [Effect])
+      where
-    unitHooksL = baseStats . traitsL . each . traitHooksL . each . filterActivatedL . hookEffectL
+        statusHooks :: [Hook (CharacterIdentifier -> [Effect])]
-    charRunHooks :: (CharacterIdentifier, Character) -> [Effect]
+        statusHooks = c ^.. statusEffects . each . to seGetHooks . each
-    charRunHooks (cid, c) =
+        classHooks :: [Hook (CharacterIdentifier -> [Effect])]
-      (c ^. unitHooksL) board cid
+        classHooks = c ^.. baseStats . traitsL . each . traitHooksL . each
-    characterEffects :: [Effect]
+        allHooks = statusHooks ++ classHooks
-    characterEffects = board ^. enumerateUnits . to charRunHooks
+    unitUpdateStatuses :: (CharacterIdentifier, Character) -> (CharacterIdentifier, Character)
-    globalEffects :: [Effect]
+    unitUpdateStatuses i@(cid, _) = i & _2 . statusEffects %~ mapMaybe (seDoUpdate trigger board cid)
-    globalEffects = (globalHooks ^. each . filterActivatedL . hookEffectL) board
+    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