feat(xanthous): Fistfighting builds knuckle calluses r/2676

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 <grfn@gws.fyi>
Tested-by: BuildkiteCI

8 files changed, 229 insertions, 20 deletions

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