diff --git a/app/Main.hs b/app/Main.hs index 2cbf13b..2975daa 100644 --- 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] diff --git a/src/GameLogic.hs b/src/GameLogic.hs index 14e0085..7c76445 100644 --- 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' diff --git a/src/GameModel.hs b/src/GameModel.hs index 2c6729a..760a992 100644 --- 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 diff --git a/src/Mechanics.hs b/src/Mechanics.hs new file mode 100644 index 0000000..b80cb9b --- /dev/null +++ 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 = [] \ No newline at end of file diff --git a/src/Units/Carcass.hs b/src/Units/Carcass.hs index a6e5d75..a935149 100644 --- 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 \ No newline at end of file +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 + } \ No newline at end of file diff --git a/src/Units/Debug.hs b/src/Units/Debug.hs index 3b22b43..d02b27a 100644 --- 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 \ No newline at end of file + ] \ No newline at end of file