From 7b90b02049f891f752fff7e0e228511077bbcb84 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 15 Nov 2019 21:20:01 -0500 Subject: Recover character hitpoints over time Wrap hitpoints in a newtype, and recover character hitpoints over time --- src/Xanthous/App.hs | 4 ++-- src/Xanthous/Data.hs | 15 ++++++++++++++- src/Xanthous/Entities/Character.hs | 33 +++++++++++++++++++++++---------- src/Xanthous/Entities/Creature.hs | 4 ++-- src/Xanthous/Entities/RawTypes.hs | 4 ++-- src/Xanthous/Game/Draw.hs | 2 +- 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 -- cgit 1.4.1