From f00dd30cad191bf53729fdedf66d49e9b539e19e Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 18 Jun 2021 16:07:39 -0400 Subject: feat(xanthous): Fistfighting builds knuckle calluses 2000 ticks after the character damages their fists by hitting something, the character now develops calluses on their fists (scaled by *how* damaged they've become) that reduce the chance of them receiving additional damage from hitting things - up to a max of 5, which prevents *all* damage from fistfighting. This is all tracked in a new "Knuckles" struct in a new "Body" struct on the character datatype, which manages stepping itself forward as part of the Brain impl on the character. Change-Id: Ica269f16fb340fb25900d2c77fbad32f10c00be2 Reviewed-on: https://cl.tvl.fyi/c/depot/+/3222 Reviewed-by: grfn Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/App.hs | 15 ++- .../xanthous/src/Xanthous/Entities/Character.hs | 149 +++++++++++++++++++-- users/grfn/xanthous/src/Xanthous/Util.hs | 39 +++++- users/grfn/xanthous/src/Xanthous/messages.yaml | 8 ++ users/grfn/xanthous/test/Spec.hs | 2 + .../test/Xanthous/Entities/CharacterSpec.hs | 24 ++++ users/grfn/xanthous/test/Xanthous/UtilSpec.hs | 9 ++ users/grfn/xanthous/xanthous.cabal | 3 +- 8 files changed, 229 insertions(+), 20 deletions(-) create mode 100644 users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index fa4ef2d6a5c3..1e915a03fe05 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -362,10 +362,7 @@ attackAt pos = message msg msgParams entities . ix creatureID . positioned .= SomeEntity creature' - whenM (uses character $ isNothing . weapon) - $ whenM (chance (0.08 :: Float)) $ do - say_ ["combat", "fistSelfDamage"] - character %= Character.damage 1 + whenM (uses character $ isNothing . weapon) handleFists stepGame -- TODO weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem @@ -377,6 +374,16 @@ attackAt pos = Nothing -> Messages.lookup ["combat", "hit", "fists"] + handleFists = do + damageChance <- use $ character . body . knuckles . to fistDamageChance + whenM (chance damageChance) $ do + damageAmount <- use $ character . body . knuckles . to fistfightingDamage + say_ [ "combat" , if damageAmount > 1 + then "fistExtraSelfDamage" + else "fistSelfDamage" ] + character %= Character.damage damageAmount + character . body . knuckles %= damageKnuckles + entityMenu_ :: (Comonad w, Entity entity) => [w entity] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs index f27ed1e475d6..b073f0d0719b 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs @@ -1,6 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- module Xanthous.Entities.Character - ( Character(..) + + ( -- * Character datatype + Character(..) , characterName , inventory , characterDamage @@ -8,13 +12,14 @@ module Xanthous.Entities.Character , characterHitpoints , hitpointRecoveryRate , speed + , body - -- * Inventory + -- ** Inventory , Inventory(..) , backpack , wielded , items - -- ** Wielded items + -- *** Wielded items , Wielded(..) , hands , leftHand @@ -28,7 +33,16 @@ module Xanthous.Entities.Character , wieldableItem , asWieldedItem - -- * + -- *** Body + , Body(..) + , initialBody + , knuckles + , Knuckles(..) + , fistDamageChance + , damageKnuckles + , fistfightingDamage + + -- * Character functions , mkCharacter , pickUpItem , isDead @@ -45,6 +59,8 @@ import Data.Coerce (coerce) import Test.QuickCheck import Test.QuickCheck.Instances.Vector () import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Gen (chooseUpTo) +import Test.QuickCheck.Checkers (EqProp) -------------------------------------------------------------------------------- import Xanthous.Util.QuickCheck import Xanthous.Game.State @@ -55,6 +71,10 @@ import Xanthous.Data ) import Xanthous.Entities.RawTypes (WieldableItem, wieldable) import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Util (EqEqProp(EqEqProp), modifyKL) +import Control.Monad.State.Lazy (execState) +import Control.Monad.Trans.State.Lazy (execStateT) +import Xanthous.Monad (say_) -------------------------------------------------------------------------------- data WieldedItem = WieldedItem @@ -199,11 +219,107 @@ instance Monoid Inventory where -------------------------------------------------------------------------------- +-- | The status of the character's knuckles +-- +-- This struct is used to track the damage and then eventual build-up of +-- calluses when the character is fighting with their fists +data Knuckles = Knuckles + { -- | How damaged are the knuckles currently, from 0 to 5? + -- + -- At 0, no calluses will form + -- At 1 and up, the character will form calluses after a while + -- At 5, continuing to fistfight will deal the character even more damage + _knuckleDamage :: !Word + -- | How built-up are the character's calluses, from 0 to 5? + -- + -- Each level of calluses decreases the likelihood of being damaged when + -- fistfighting by 1%, up to 5 where the character will never be damaged + -- fistfighting + , _knuckleCalluses :: !Word + + -- | Number of turns that have passed since the last time the knuckles were + -- damaged + , _ticksSinceDamaged :: Ticks + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving EqProp via EqEqProp Knuckles + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Knuckles +makeLenses ''Knuckles + +instance Semigroup Knuckles where + (Knuckles d₁ c₁ t₁) <> (Knuckles d₂ c₂ t₂) = Knuckles + (min (d₁ + d₂) 5) + (min (c₁ + c₂) 5) + (max t₁ t₂) + +instance Monoid Knuckles where + mempty = Knuckles 0 0 0 + +instance Arbitrary Knuckles where + arbitrary = do + _knuckleDamage <- fromIntegral <$> chooseUpTo 5 + _knuckleCalluses <- fromIntegral <$> chooseUpTo 5 + _ticksSinceDamaged <- arbitrary + pure Knuckles{..} + +-- | Likelihood that the character fighting with their fists will damage +-- themselves +fistDamageChance :: Knuckles -> Float +fistDamageChance knuckles + | calluses == 5 = 0 + | otherwise = baseChance - (0.01 * fromIntegral calluses) + where + baseChance = 0.08 + calluses = knuckles ^. knuckleCalluses + +-- | Damage the knuckles by a level (capping at the max knuckle damage) +damageKnuckles :: Knuckles -> Knuckles +damageKnuckles = execState $ do + knuckleDamage %= min 5 . succ + ticksSinceDamaged .= 0 + +-- | Damage taken when fistfighting and 'fistDamageChance' has occurred +fistfightingDamage :: Knuckles -> Hitpoints +fistfightingDamage knuckles + | knuckles ^. knuckleDamage == 5 = 2 + | otherwise = 1 + +stepKnuckles :: Ticks -> Knuckles -> AppM Knuckles +stepKnuckles ticks = execStateT . whenM (uses knuckleDamage (> 0)) $ do + ticksSinceDamaged += ticks + whenM (uses ticksSinceDamaged (>= 2000)) $ do + dam <- knuckleDamage <<.= 0 + knuckleCalluses %= min 5 . (+ dam) + ticksSinceDamaged .= 0 + lift $ say_ ["character", "body", "knuckles", "calluses"] + + +-- | Status of the character's body +data Body = Body + { _knuckles :: !Knuckles + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Body + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Body +makeLenses ''Body + +initialBody :: Body +initialBody = Body { _knuckles = mempty } + +-------------------------------------------------------------------------------- + data Character = Character - { _inventory :: !Inventory - , _characterName :: !(Maybe Text) + { _inventory :: !Inventory + , _characterName :: !(Maybe Text) , _characterHitpoints' :: !Double - , _speed :: TicksPerTile + , _speed :: !TicksPerTile + , _body :: !Body } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) @@ -226,10 +342,12 @@ instance Draw Character where drawPriority = const maxBound -- Character should always be on top, for now instance Brain Character where - step ticks = (pure .) $ positioned . characterHitpoints' %~ \hp -> - if hp > fromIntegral initialHitpoints - then hp - else hp + hitpointRecoveryRate |*| ticks + step ticks = execStateT $ do + positioned . characterHitpoints' %= \hp -> + if hp > fromIntegral initialHitpoints + then hp + else hp + hitpointRecoveryRate |*| ticks + modifyKL (positioned . body . knuckles) $ lift . stepKnuckles ticks instance Entity Character where description _ = "yourself" @@ -249,10 +367,11 @@ defaultSpeed = 100 mkCharacter :: Character mkCharacter = Character - { _inventory = mempty - , _characterName = Nothing + { _inventory = mempty + , _characterName = Nothing , _characterHitpoints' = fromIntegral initialHitpoints - , _speed = defaultSpeed + , _speed = defaultSpeed + , _body = initialBody } defaultCharacterDamage :: Hitpoints @@ -280,3 +399,5 @@ damage :: Hitpoints -> Character -> Character damage (fromIntegral -> amount) = characterHitpoints' %~ \case n | n <= amount -> 0 | otherwise -> n - amount + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs index 524ad4819dac..189e781e6cec 100644 --- a/users/grfn/xanthous/src/Xanthous/Util.hs +++ b/users/grfn/xanthous/src/Xanthous/Util.hs @@ -30,7 +30,10 @@ module Xanthous.Util , minimum1 -- * Combinators - , times, times_ + , times, times_, endoTimes + + -- * State utilities + , modifyK, modifyKL -- * Type-level programming utils , KnownBool(..) @@ -45,6 +48,7 @@ import Data.Proxy import qualified Data.Vector as V import Data.Semigroup (Max(..), Min(..)) import Data.Semigroup.Foldable +import Control.Monad.State.Class -------------------------------------------------------------------------------- newtype EqEqProp a = EqEqProp a @@ -237,6 +241,13 @@ times n f = traverse f [1..n] times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a] times_ n fa = times n (const fa) +-- | Multiply an endomorphism by an integral +-- +-- >>> endoTimes (4 :: Int) succ (5 :: Int) +-- 9 +endoTimes :: Integral n => n -> (a -> a) -> a -> a +endoTimes n f = appEndo $ stimes n (Endo f) + -------------------------------------------------------------------------------- -- | This class gives a boolean associated with a type-level bool, a'la @@ -250,3 +261,29 @@ class KnownBool (bool :: Bool) where instance KnownBool 'True where boolVal = True instance KnownBool 'False where boolVal = False + +-------------------------------------------------------------------------------- + +-- | Modify some monadic state via the application of a kleisli endomorphism on +-- the state itself +-- +-- Note that any changes made to the state during execution of @k@ will be +-- overwritten +-- +-- @@ +-- modifyK pure === pure () +-- @@ +modifyK :: MonadState s m => (s -> m s) -> m () +modifyK k = get >>= k >>= put + +-- | Modify some monadic state via the application of a kleisli endomorphism on +-- the target of a lens +-- +-- Note that any changes made to the state during execution of @k@ will be +-- overwritten +-- +-- @@ +-- modifyKL id pure === pure () +-- @@ +modifyKL :: MonadState s m => LensLike m s s a b -> (a -> m b) -> m () +modifyKL l k = get >>= traverseOf l k >>= put diff --git a/users/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml index e3ebd8bebec2..710c0c17b067 100644 --- a/users/grfn/xanthous/src/Xanthous/messages.yaml +++ b/users/grfn/xanthous/src/Xanthous/messages.yaml @@ -57,6 +57,11 @@ look: character: namePrompt: "What's your name? " + body: + knuckles: + calluses: + - You've started developing calluses on your knuckles from all the punching you've been doing. + - You've been fighting with your fists so much they're starting to develop calluses. combat: nothingToAttack: There's nothing to attack there. @@ -64,6 +69,9 @@ combat: fistSelfDamage: - You hit so hard with your fists you hurt yourself! - The punch leaves your knuckles bloody! + fistExtraSelfDamage: + - You hurt your already-bloody fists with the strike! + - Ouch! Your fists were already bleeding! hit: fists: - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot. diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs index 46e82c8c6c6b..85f49fd07c91 100644 --- a/users/grfn/xanthous/test/Spec.hs +++ b/users/grfn/xanthous/test/Spec.hs @@ -10,6 +10,7 @@ import qualified Xanthous.Data.MemoSpec import qualified Xanthous.Data.NestedMapSpec import qualified Xanthous.DataSpec import qualified Xanthous.Entities.RawsSpec +import qualified Xanthous.Entities.CharacterSpec import qualified Xanthous.GameSpec import qualified Xanthous.Game.StateSpec import qualified Xanthous.Generators.Level.UtilSpec @@ -36,6 +37,7 @@ test = testGroup "Xanthous" , Xanthous.Data.NestedMapSpec.test , Xanthous.DataSpec.test , Xanthous.Entities.RawsSpec.test + , Xanthous.Entities.CharacterSpec.test , Xanthous.GameSpec.test , Xanthous.Game.StateSpec.test , Xanthous.Generators.Level.UtilSpec.test diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs new file mode 100644 index 000000000000..734cce1efbbe --- /dev/null +++ b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wno-type-defaults #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.CharacterSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Xanthous.Entities.Character +import Xanthous.Util (endoTimes) +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Entities.CharacterSpec" + [ testGroup "Knuckles" + [ testBatch $ monoid @Knuckles mempty + , testGroup "damageKnuckles" + [ testCase "caps at 5" $ + let knuckles' = endoTimes 6 damageKnuckles mempty + in _knuckleDamage knuckles' @?= 5 + ] + ] + ] diff --git a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs index 8538ea5098ba..01e8e402c54f 100644 --- a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs @@ -2,6 +2,7 @@ module Xanthous.UtilSpec (main, test) where import Test.Prelude import Xanthous.Util +import Control.Monad.State.Lazy (execState) main :: IO () main = defaultMain test @@ -25,4 +26,12 @@ test = testGroup "Xanthous.Util" [ testProperty "takeWhileInclusive (const True) ≡ id" $ \(xs :: [Int]) -> takeWhileInclusive (const True) xs === xs ] + , testGroup "endoTimes" + [ testCase "endoTimes 4 succ 5" + $ endoTimes (4 :: Int) succ (5 :: Int) @?= 9 + ] + , testGroup "modifyKL" + [ testCase "_1 += 1" + $ execState (modifyKL _1 $ pure . succ) (1 :: Int, 2 :: Int) @?= (2, 2) + ] ] diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal index 3880969d7d39..4cbabdb58eba 100644 --- a/users/grfn/xanthous/xanthous.cabal +++ b/users/grfn/xanthous/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 715e0ab333afb8723ffec128cf69c065f6f018e9622d65c45d404e5084852f54 +-- hash: b39d4dd906804ca42f8965c2dbe519434e80622fef7fafce1dca0d211a1c6663 name: xanthous version: 0.1.0.0 @@ -355,6 +355,7 @@ test-suite test Xanthous.Data.MemoSpec Xanthous.Data.NestedMapSpec Xanthous.DataSpec + Xanthous.Entities.CharacterSpec Xanthous.Entities.RawsSpec Xanthous.Game.StateSpec Xanthous.GameSpec -- cgit 1.4.1