Recover character hitpoints over time

Wrap hitpoints in a newtype, and recover character hitpoints over time

6 files changed, 44 insertions, 18 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index d3f266a1e340..2f27948cdee5 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -95,7 +95,7 @@ stepGameBy ticks = do
     pEntity' <- step ticks pEntity
     entities . ix eid .= pEntity'
 
-  whenM (uses (character . characterHitpoints) (== 0))
+  whenM (uses character isDead)
     . prompt_ @'Continue ["dead"] Uncancellable
     . const . lift . liftIO
     $ exitSuccess
@@ -186,7 +186,7 @@ handleCommand Eat = do
               in before <> fromMaybe Empty (tailMay after)
             let msg = fromMaybe (Messages.lookup ["eat", "eat"])
                       $ edibleItem ^. eatMessage
-            character . characterHitpoints +=
+            character . characterHitpoints' +=
               edibleItem ^. hitpointsHealed . to fromIntegral
             message msg $ object ["item" A..= item]
   stepGame -- TODO
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index 569922843644..b0d865fa5d79 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -59,6 +59,9 @@ module Xanthous.Data
   , edges
   , neighborDirections
   , neighborPositions
+
+    -- *
+  , Hitpoints(..)
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude hiding (Left, Down, Right)
@@ -344,7 +347,7 @@ neighborPositions pos = (`move` pos) <$> neighborDirections
 newtype Per a b = Rate Double
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
-  deriving (Num, Ord, Enum, Real, ToJSON, FromJSON) via Double
+  deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double
   deriving (Semigroup, Monoid) via Product Double
 instance Arbitrary (Per a b) where arbitrary = genericArbitrary
 
@@ -378,3 +381,13 @@ type TilesPerTick = Tiles `Per` Ticks
 
 timesTiles :: TicksPerTile -> Tiles -> Ticks
 timesTiles = (|*|)
+
+--------------------------------------------------------------------------------
+
+newtype Hitpoints = Hitpoints Word
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON)
+       via Word
+  deriving (Semigroup, Monoid) via Sum Word
+
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index e3cbb2c038ff..271492d6ce26 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -1,10 +1,13 @@
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Character
   ( Character(..)
   , characterName
   , inventory
   , characterDamage
+  , characterHitpoints'
   , characterHitpoints
+  , hitpointRecoveryRate
   , speed
 
     -- *
@@ -22,17 +25,18 @@ import Test.QuickCheck.Arbitrary.Generic
 import Brick
 import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
+import Data.Coerce (coerce)
 --------------------------------------------------------------------------------
 import Xanthous.Entities
 import Xanthous.Entities.Item
-import Xanthous.Data (TicksPerTile)
+import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned)
 --------------------------------------------------------------------------------
 
 data Character = Character
   { _inventory :: !(Vector Item)
   , _characterName :: !(Maybe Text)
-  , _characterDamage :: !Word
-  , _characterHitpoints :: !Word
+  , _characterDamage :: !Hitpoints
+  , _characterHitpoints' :: !Double
   , _speed :: TicksPerTile
   }
   deriving stock (Show, Eq, Generic)
@@ -42,6 +46,9 @@ data Character = Character
            Character
 makeLenses ''Character
 
+characterHitpoints :: Character -> Hitpoints
+characterHitpoints = views characterHitpoints' floor
+
 scrollOffset :: Int
 scrollOffset = 5
 
@@ -52,8 +59,11 @@ instance Draw Character where
       rreg = (2 * scrollOffset, 2 * scrollOffset)
   drawPriority = const maxBound -- Character should always be on top, for now
 
--- the character does not (yet) have a mind of its own
-instance Brain Character where step = brainVia Brainless
+instance Brain Character where
+  step ticks = (pure .) $ positioned . characterHitpoints' %~ \hp ->
+    if hp > fromIntegral initialHitpoints
+    then hp
+    else hp + hitpointRecoveryRate |*| ticks
 
 instance Entity Character where
   blocksVision _ = False
@@ -62,9 +72,12 @@ instance Entity Character where
 instance Arbitrary Character where
   arbitrary = genericArbitrary
 
-initialHitpoints :: Word
+initialHitpoints :: Hitpoints
 initialHitpoints = 10
 
+hitpointRecoveryRate :: Double `Per` Ticks
+hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed)
+
 defaultSpeed :: TicksPerTile
 defaultSpeed = 100
 
@@ -73,17 +86,17 @@ mkCharacter = Character
   { _inventory = mempty
   , _characterName = Nothing
   , _characterDamage = 1
-  , _characterHitpoints = initialHitpoints
+  , _characterHitpoints' = fromIntegral initialHitpoints
   , _speed = defaultSpeed
   }
 
 isDead :: Character -> Bool
-isDead = (== 0) . view characterHitpoints
+isDead = (== 0) . characterHitpoints
 
 pickUpItem :: Item -> Character -> Character
 pickUpItem item = inventory %~ (item <|)
 
-damage :: Word -> Character -> Character
-damage amount = characterHitpoints %~ \case
+damage :: Hitpoints -> Character -> Character
+damage (fromIntegral -> amount) = characterHitpoints' %~ \case
   n | n <= amount -> 0
     | otherwise  -> n - amount
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 4ad751a58240..11cad1ce6b8b 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -78,7 +78,7 @@ initialHippocampus = Hippocampus Nothing
 
 data Creature = Creature
   { _creatureType :: !CreatureType
-  , _hitpoints    :: !Word
+  , _hitpoints    :: !Hitpoints
   , _hippocampus  :: !Hippocampus
   }
   deriving stock (Eq, Show, Generic)
@@ -99,7 +99,7 @@ newWithType _creatureType =
       _hippocampus = initialHippocampus
   in Creature {..}
 
-damage :: Word -> Creature -> Creature
+damage :: Hitpoints -> Creature -> Creature
 damage amount = hitpoints %~ \hp ->
   if hp <= amount
   then 0
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index fd66140376bb..09b250fb310d 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -29,13 +29,13 @@ import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Entities (EntityChar, HasChar(..))
 import Xanthous.Messages (Message(..))
-import Xanthous.Data (TicksPerTile)
+import Xanthous.Data (TicksPerTile, Hitpoints)
 --------------------------------------------------------------------------------
 data CreatureType = CreatureType
   { _name         :: !Text
   , _description  :: !Text
   , _char         :: !EntityChar
-  , _maxHitpoints :: !Word
+  , _maxHitpoints :: !Hitpoints
   , _friendly     :: !Bool
   , _speed        :: !TicksPerTile
   }
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index b7d7a76956ed..ffbf30cca864 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -96,7 +96,7 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
              = emptyWidget
     charHitpoints
         = txt "Hitpoints: "
-      <+> txt (tshow $ ch ^. characterHitpoints)
+      <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
 
 drawGame :: GameState -> [Widget Name]
 drawGame game