Change the representation of stats

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]

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'

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
+  AttackDice  :: Stat (Sum Int)
-  DefenseDice :: Stat Int
+  DefenseDice :: Stat (Sum Int)
-  FreeMove    :: Stat Bool
+  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
+-- | Compute a stat for a unit by accumulating the modifiers for the stat in all places
-computeStat board cid stat = case stat of
+--
-  AttackDice  -> 1 + elevationBonus + fromMaybe 0 specialtyBonus
+-- This includes so called global modifiers, but in order to keep game rules seperate from
-  DefenseDice -> 0 + elevationBonus + fromMaybe 0 specialtyBonus
+-- the model, global modifiers must be provided as the first argument.
-  FreeMove ->  fromMaybe False specialtyBonus
+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
+    filterActivatedL :: Traversal' (Hook a) (Hook a)
-    specialtyBonus = case board ^? statBonuses of
+    filterActivatedL = filtered ((==trigger) . hookTrigger)
-      Just statB -> Just $ statB board cid stat
+    unitHooksL :: SimpleFold Character (BoardState -> CharacterIdentifier -> [Effect])
-      Nothing -> Nothing
+    unitHooksL = baseStats . traitsL . each . traitHooksL . each . filterActivatedL . hookEffectL
-    elevationBonus :: Int
+    charRunHooks :: (CharacterIdentifier, Character) -> [Effect]
-    elevationBonus = if isElevated board cid then 1 else 0
+    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

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 = []

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
+formation :: Trait
-gunwightStatBonuses board cid AttackDice  = if adjacentAllies board cid /= Just [] then 1 else 0
+formation = Trait
-gunwightStatBonuses _     _   DefenseDice = 0
+  { traitName = "Formation"
-gunwightStatBonuses _     _   FreeMove    = False
+  , traitHooks = []
+  , traitModifiers = [formationModifier]
+  }
+  where
+    formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0
+    formationModifier = Modifier
+      { modifierStat = AttackDice
+      , modifierEffect = formationF
+      }

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