Change the representation of stats

2023-12-06 14:57:24 -05:00 · 2023-12-06 14:57:24 -05:00 · 70d8b0d1b0
parent 69da0f1dfd
commit 70d8b0d1b0
6 changed files with 166 additions and 97 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -3,7 +3,8 @@ module Main (main) where
 import System.IO (hFlush, stdout)
 import Util (note)
 import GameModel (Point(..), Player(..), newBoard, BaseStats, BoardState, EnvTile (..), DieFace, bestOrWorst)
-import Units.Debug (basic, freeMoveTester)
+import Units.Debug (basic)
+import Units.Carcass (gunwight)
 import GameLogic (buildChoiceTree, ChoiceTree(..), ChoiceTree'(..), makeChoice, ctTree)

 import Text.Read (readMaybe)
@ -12,7 +13,7 @@ import Control.Monad (replicateM, void)
 import System.Random (randomIO)

 initialPlacement :: Point -> Maybe (Player, BaseStats)
-initialPlacement = flip lookup [(Point 5, (Max, basic)), (Point 0, (Max, freeMoveTester)), (Point 23, (Min, basic)), (Point 22, (Min, freeMoveTester))]
+initialPlacement = flip lookup [(Point 5, (Max, basic)), (Point 0, (Max, gunwight)), (Point 23, (Min, basic)), (Point 22, (Min, gunwight))]

 initialTerrain :: Point -> [EnvTile]
 initialTerrain (Point  4) = [Rough]
--- a/src/GameLogic.hs
+++ b/src/GameLogic.hs
@ -28,6 +28,16 @@ import Lens.Micro
 import Safe (atMay)

 import Debug.Trace
+import Mechanics (universalModifiers, globalHooks)
+import Data.Monoid (Any(getAny), getSum)
+
+-- | A version of `computeStat_` using `universalModifiers` as global modifiers
+computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
+computeStat = computeStat_ universalModifiers
+
+-- | A version of `runHooks_` using `globalHooks` as the global hooks
+runHooks :: Trigger -> BoardState -> BoardState
+runHooks = runHooks_ globalHooks

 data EngineState
  = PlayerChoice Player [Choice]
@ -131,7 +141,7 @@ applyEffect StartTurn board = case (chooseCharacter board, chooseCharacter oppon
      if board ^. roundNumber == 6
        then board
        else nextRound board
-applyEffect (Event trigger) board = continue $ pushEffects (listHooks board trigger) board
+applyEffect (Event trigger) board = continue $ runHooks trigger board
 applyEffect (ChooseActMove cid) _ = unitChoice cid [moveFirst, actFirst]
  where
    moveFirst = mkChoice "Move first" [basicMove cid, ActOrMove cid, EndTurn cid]
@ -144,7 +154,7 @@ applyEffect (InitMove (ProtoMovementSpecs {..}) cid) board = continue $ case adj
  Just movForced -> changeMovingUnit board cid <++ [Move (MovementSpecs {..}) cid]
  Nothing -> board
  where
-    movFree = fromMaybe (computeStat board cid FreeMove) movFree'
+    movFree = getAny $ computeStat board cid FreeMove
    adjustedFm = case movForced' of
      Nothing -> Just Nothing
      Just (Right p, fmType, forcer) -> Just $ Just (p, fmType, forcer)
@ -238,7 +248,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
    validCover = if defenderElevated then [Wall] else [Wall, Elevation]
    hasCover = or $ (==) <$> validCover <*> coveringTerrain
    coverBonus = if not (melee attack) && hasCover then 1 else 0
-    netDice = attackerDieBonus - (defenderDieBonus + coverBonus)
+    netDice = getSum $ attackerDieBonus - (defenderDieBonus + coverBonus)
    actualDiceRolled = fromIntegral $ if netDice <= 0 then 2 else netDice
    keepHighest = netDice > 0
    toHit = maybe 1 getDefense defender'
--- a/src/GameModel.hs
+++ b/src/GameModel.hs
@ -56,9 +56,8 @@ module GameModel
    , movL
    , dfL
    , armL
-    , hooksL
+    , traitsL
    , actionsL
-    , statBonusL
    , instantiate
    , Character(..)
    , baseStats
@ -94,7 +93,6 @@ module GameModel
    , isAlive
    , pushEffects
    , unitPosition
-    , listHooks
    , terrainAt
    , characterAt
    , adjacentUnits
@ -127,22 +125,33 @@ module GameModel
    , ProtoMovementSpecs(..)
    , basicMove
    , forcedMove
-    , computeStat
+    , allStatsAreMonoids
+    , HasMonoidInstance
+    , Hook(..)
+    , hookTriggerL
+    , hookEffectL
+    , Modifier(..)
+    , Trait(..)
+    , traitNameL
+    , traitHooksL
+    , traitModifiersL
+    , computeStat_
+    , runHooks_
    ) where

 import Util (toMaybe, dup, secondClassLensNames, (??))

-import Control.Applicative (liftA2, Alternative (..))
+import Control.Applicative (Alternative (..))
 import Control.Arrow ((>>>), Arrow (second))
-import Control.Monad (join, mfilter)
+import Control.Monad (join, mfilter, zipWithM)
 import Data.Ix (inRange)
 import Data.List (intersperse, elemIndex)
 import Data.List.NonEmpty as NonEmpty (cons, NonEmpty, singleton)
-import Data.Maybe (mapMaybe, catMaybes, fromMaybe)
+import Data.Maybe (mapMaybe, catMaybes)
 import Numeric.Natural (Natural)
 import Safe (headMay)
 import Lens.Micro
-import Data.Monoid (First)
+import Data.Monoid (Sum, Any)
 import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics)
 import Lens.Micro.Extras (preview)
 import Data.Data ((:~:)(..))
@ -292,6 +301,7 @@ data Trigger
  | TookDamage CharacterIdentifier
  | Died CharacterIdentifier Point
  | EndMove CharacterIdentifier
+  deriving (Eq, Show)

 data OrthagonalDirection
  = North
@ -519,9 +529,22 @@ otherPlayer Max = Min
 otherPlayer Min = Max

 data Stat a where
-  AttackDice  :: Stat Int
-  DefenseDice :: Stat Int
-  FreeMove    :: Stat Bool
+  AttackDice  :: Stat (Sum Int)
+  DefenseDice :: Stat (Sum Int)
+  FreeMove    :: Stat Any
+
+statEq :: Stat a -> Stat b -> Maybe (a :~: b)
+statEq AttackDice  AttackDice  = Just Refl
+statEq DefenseDice DefenseDice = Just Refl
+statEq FreeMove    FreeMove    = Just Refl
+statEq _           _           = Nothing
+
+data HasMonoidInstance a = forall m. Monoid m => HasMonoidInstance (a :~: m)
+
+allStatsAreMonoids :: Stat a -> HasMonoidInstance a
+allStatsAreMonoids AttackDice  = HasMonoidInstance Refl
+allStatsAreMonoids DefenseDice = HasMonoidInstance Refl
+allStatsAreMonoids FreeMove    = HasMonoidInstance Refl

 data BaseStats = BaseStats
  { name        :: String
@ -529,9 +552,36 @@ data BaseStats = BaseStats
  , mov         :: Natural
  , df          :: DieFace
  , arm         :: Armor
-  , hooks       :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
+  , traits      :: [Trait]
  , actions     :: [CharacterIdentifier -> Choice]
-  , statBonus   :: forall a. BoardState -> CharacterIdentifier -> Stat a -> a
+  }
+
+-- | Some effect which is activated by some trigger event
+data Hook h = Hook
+  { hookTrigger :: Trigger -- ^ The trigger which should activate this effect
+  -- | What this effect does.  Recieves board & this character's CID
+  , hookEffect  :: BoardState -> h
+  }
+
+-- | 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
+  -- | What the effects of this modifier are
+  , modifierEffect :: BoardState -> CharacterIdentifier -> a
+  }
+
+queryModifier :: BoardState -> CharacterIdentifier -> Stat a -> Modifier -> a
+queryModifier board cid queryStat (Modifier {..}) = case queryStat `statEq` modifierStat of
+  Just Refl -> modifierEffect board cid
+  Nothing -> case allStatsAreMonoids queryStat of HasMonoidInstance Refl -> mempty
+
+-- | A passive trait on a unit
+-- Can affect a unit or surrounding units by directly and conditionally modifying that
+-- units stats, or by running certain 'Effect's on a given trigger
+data Trait = Trait
+  { traitName      :: String -- ^ The name of this trait, e.g. "Formation"
+  , traitHooks     :: [Hook (CharacterIdentifier -> [Effect])] -- ^ Any hooks which this trait needs
+  , traitModifiers :: [Modifier] -- ^ Any modifiers this trait imposes
  }

 instance Show BaseStats where
@ -645,6 +695,10 @@ makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''Base

 makeLensesWith secondClassLensNames ''MovementSpecs

+makeLensesWith secondClassLensNames ''Hook
+
+makeLensesWith secondClassLensNames ''Trait
+
 instantiate :: BaseStats -> Character
 instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats

@ -682,18 +736,39 @@ untapped = not . _movedThisRound
 untap :: Character -> Character
 untap = movedThisRound .~ False

-computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
-computeStat board cid stat = case stat of
-  AttackDice  -> 1 + elevationBonus + fromMaybe 0 specialtyBonus
-  DefenseDice -> 0 + elevationBonus + fromMaybe 0 specialtyBonus
-  FreeMove ->  fromMaybe False specialtyBonus
+-- | Compute a stat for a unit by accumulating the modifiers for the stat in all places
+--
+-- 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
+  HasMonoidInstance Refl ->
+    let
+      queryStatsL = each . to (queryModifier board cid stat)
+      globalBonus = globalModifiers ^. queryStatsL
+      traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL
+    in globalBonus <> traitBonus
+
+-- | 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
  where
-    statBonuses = ixCharacter cid . baseStats . statBonusL
-    specialtyBonus = case board ^? statBonuses of
-      Just statB -> Just $ statB board cid stat
-      Nothing -> Nothing
-    elevationBonus :: Int
-    elevationBonus = if isElevated board cid then 1 else 0
+    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

 instance Show BoardState where
  show board = join (intersperse "\n" showTiles) ++ '\n':showRound  ++ "\n" ++ showCharacters
@ -893,12 +968,6 @@ unitPosition (BoardState {_tiles}) cid = headMay $ catMaybes $ zipWith aux [0..]
      | potentialCid == Just cid = Just $ Point p
      | otherwise = Nothing

-listHooks :: BoardState -> Trigger -> [Effect]
-listHooks boardState = mconcat <$> traverse characterHooks (boardState ^.. enumerateUnits)
-  where
-    characterHooks :: (CharacterIdentifier, Character) -> Trigger -> [Effect]
-    characterHooks (cid, c) = hooks (_baseStats c) boardState cid
-
 atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile])
 atPoint p = tiles . ixp p
  where
--- a/src/Mechanics.hs
+++ b/src/Mechanics.hs
@ -0,0 +1,32 @@
+module Mechanics
+  ( universalModifiers
+  , globalHooks
+  )
+  where
+
+import GameModel
+  (BoardState, CharacterIdentifier, Modifier (..), Stat (..), isElevated, Hook, Effect)
+
+import Data.Monoid (Sum)
+
+universalModifiers :: [Modifier]
+universalModifiers =
+  [ elevationBonus AttackDice
+  , elevationBonus DefenseDice
+  , attackDiceBase
+  ]
+
+elevationBonus :: Stat (Sum Int) -> Modifier
+elevationBonus modifierStat = Modifier {..}
+  where
+    modifierEffect :: BoardState -> CharacterIdentifier -> Sum Int
+    modifierEffect board cid = if isElevated board cid then 1 else 0
+
+attackDiceBase :: Modifier
+attackDiceBase = Modifier {..}
+  where
+    modifierStat = AttackDice
+    modifierEffect = const $ const 1
+
+globalHooks :: [Hook [Effect]]
+globalHooks = []
--- a/src/Units/Carcass.hs
+++ b/src/Units/Carcass.hs
@ -15,6 +15,8 @@ import GameModel
  , Stat(..)
  , Token(..)
  , Trigger(..)
+  , Trait(..)
+  , Modifier(..)
  )
 import Units.Components
  ( AttackT(..)
@ -29,17 +31,10 @@ gunwight = BaseStats
  , mov       = 2
  , df        = 4
  , arm       = NoArmor
-  , hooks     = gunwightHooks
  , actions   = gunwightActions
-  , statBonus = gunwightStatBonuses
+  , traits    = [formation]
  }

-gunwightHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
-gunwightHooks board cid TurnStart = []
-gunwightHooks board cid (TookDamage _) = []
-gunwightHooks board cid (Died _ _) = []
-gunwightHooks board cid (EndMove _) = []
-
 gunwightActions :: [CharacterIdentifier -> Choice]
 gunwightActions =
  [ buildAttack $ AttackT
@ -64,7 +59,15 @@ gunwightActions =
    }
  ]

-gunwightStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
-gunwightStatBonuses board cid AttackDice  = if adjacentAllies board cid /= Just [] then 1 else 0
-gunwightStatBonuses _     _   DefenseDice = 0
-gunwightStatBonuses _     _   FreeMove    = False
+formation :: Trait
+formation = Trait
+  { traitName = "Formation"
+  , traitHooks = []
+  , traitModifiers = [formationModifier]
+  }
+  where
+    formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0
+    formationModifier = Modifier
+      { modifierStat = AttackDice
+      , modifierEffect = formationF
+      }
--- a/src/Units/Debug.hs
+++ b/src/Units/Debug.hs
@ -1,21 +1,17 @@
 module Units.Debug
  ( basic
-  , freeMoveTester)
+  )
  where

 import GameModel
  ( Armor(..)
  , BaseStats(..)
-  , BoardState
  , CharacterIdentifier
  , Choice
  , DamageType(..)
-  , Effect(..)
-  , Stat(..)
  , Token(..)
-  , Trigger(..), ixCharacter, tokenCount, ofToken
-  , forcedMove, ForcedMoveType (Pull), Player (..)
  )
+
 import Units.Components
  ( AttackT(..)
  , anyTarget
@ -23,7 +19,6 @@ import Units.Components
  , SelfAbilityT(..)
  , mkSelfAbility, inflictTokens, pull, push
  )
-import Lens.Micro

 basic :: BaseStats
 basic = BaseStats
@ -32,17 +27,10 @@ basic = BaseStats
  , mov       = 4
  , df        = 4
  , arm       = NoArmor
-  , hooks     = basicHooks
  , actions   = basicActions
-  , statBonus = basicStatBonuses
+  , traits    = []
  }

-basicHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
-basicHooks _     _   TurnStart = []
-basicHooks _     _   (TookDamage _) = []
-basicHooks _     _   (Died _ _) = []
-basicHooks _     _   (EndMove _) = []
-
 basicActions :: [CharacterIdentifier -> Choice]
 basicActions =
  [ buildAttack $ AttackT
@ -117,38 +105,4 @@ basicActions =
    { tName            = "Get String"
    , tEffects         = [inflictTokens StrWeak 1]
    }
-  ]
-
-basicStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
-basicStatBonuses _     _   AttackDice  = 0
-basicStatBonuses _     _   DefenseDice = 0
-basicStatBonuses _     _   FreeMove    = False
-
-freeMoveTester :: BaseStats
-freeMoveTester = BaseStats
-  { name      = "Free Move Debug Unit"
-  , hp        = 4
-  , mov       = 4
-  , df        = 1
-  , arm       = NoArmor
-  , hooks     = freeMoveHooks
-  , actions   = freeMoveActions
-  , statBonus = freeMoveStatBonuses
-  }
-
-freeMoveHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
-freeMoveHooks _     _   TurnStart = []
-freeMoveHooks _     _   (TookDamage _) = []
-freeMoveHooks _     _   (Died _ _) = []
-freeMoveHooks _     _   (EndMove _) = []
-
-freeMoveActions :: [CharacterIdentifier -> Choice]
-freeMoveActions =
-  [
-  ]
-
-freeMoveStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
-freeMoveStatBonuses _     _   AttackDice  = 0
-freeMoveStatBonuses _     _   DefenseDice = 0
-freeMoveStatBonuses board cid FreeMove    = -- Has free movement when below max health
-  maybe True (<4) $ board ^? ixCharacter cid . tokenCount . ofToken Health
+  ]