diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Entities')
19 files changed, 0 insertions, 1541 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs deleted file mode 100644 index c8153086f1..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Character - - ( -- * Character datatype - Character(..) - , characterName - , HasInventory(..) - , characterDamage - , characterHitpoints' - , characterHitpoints - , hitpointRecoveryRate - , speed - , body - - -- *** Body - , Body(..) - , initialBody - , knuckles - , Knuckles(..) - , fistDamageChance - , damageKnuckles - , fistfightingDamage - - -- * Character functions - , mkCharacter - , pickUpItem - , isDead - , isFullyHealed - , damage - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) -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 Control.Monad.State.Lazy (execState) -import Control.Monad.Trans.State.Lazy (execStateT) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Entities.Item -import Xanthous.Entities.Common -import Xanthous.Data - ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned ) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Util (EqEqProp(EqEqProp), modifyKL) -import Xanthous.Monad (say_) --------------------------------------------------------------------------------- - --- | 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) - , _characterHitpoints' :: !Double - , _speed :: !TicksPerTile - , _body :: !Body - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Character -makeFieldsNoPrefix ''Character - -characterHitpoints :: Character -> Hitpoints -characterHitpoints = views characterHitpoints' floor - -scrollOffset :: Int -scrollOffset = 5 - -instance Draw Character where - draw _ = visibleRegion rloc rreg $ str "@" - where - rloc = Location (negate scrollOffset, negate scrollOffset) - rreg = (2 * scrollOffset, 2 * scrollOffset) - drawPriority = const maxBound -- Character should always be on top, for now - -instance Brain Character where - 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" - entityChar _ = "@" - -instance Arbitrary Character where - arbitrary = genericArbitrary - -initialHitpoints :: Hitpoints -initialHitpoints = 10 - -hitpointRecoveryRate :: Double `Per` Ticks -hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed) - -defaultSpeed :: TicksPerTile -defaultSpeed = 100 - -mkCharacter :: Character -mkCharacter = Character - { _inventory = mempty - , _characterName = Nothing - , _characterHitpoints' = fromIntegral initialHitpoints - , _speed = defaultSpeed - , _body = initialBody - } - -defaultCharacterDamage :: Hitpoints -defaultCharacterDamage = 1 - --- | Returns the damage that the character currently does with an attack --- TODO use double-handed/left-hand/right-hand here -characterDamage :: Character -> Hitpoints -characterDamage - = fromMaybe defaultCharacterDamage - . filter (/= 0) - . Just - . sumOf (inventory . wielded . wieldedItems . wieldableItem . Raw.damage) - --- | Is the character fully healed up to or past their initial hitpoints? -isFullyHealed :: Character -> Bool -isFullyHealed = (>= initialHitpoints) . characterHitpoints - --- | Is the character dead? -isDead :: Character -> Bool -isDead = (== 0) . characterHitpoints - -pickUpItem :: Item -> Character -> Character -pickUpItem it = inventory . backpack %~ (it <|) - -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/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs deleted file mode 100644 index 368b03f25b..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Xanthous.Entities.Common --- Description : Common data type definitions and utilities for entities --- --------------------------------------------------------------------------------- -module Xanthous.Entities.Common - ( -- * Inventory - Inventory(..) - , HasInventory(..) - , backpack - , wielded - , items - , InventoryPosition(..) - , describeInventoryPosition - , inventoryPosition - , itemsWithPosition - , removeItemFromPosition - - -- ** Wielded items - , Wielded(..) - , nothingWielded - , hands - , leftHand - , rightHand - , inLeftHand - , inRightHand - , doubleHanded - , Hand(..) - , itemsInHand - , inHand - , wieldInHand - , describeHand - , wieldedItems - , WieldedItem(..) - , wieldedItem - , wieldableItem - , asWieldedItem - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Test.QuickCheck -import Test.QuickCheck.Checkers (EqProp) --------------------------------------------------------------------------------- -import Xanthous.Data (Positioned(..), positioned) -import Xanthous.Util.QuickCheck -import Xanthous.Game.State -import Xanthous.Entities.Item -import Xanthous.Entities.RawTypes (WieldableItem, wieldable) -import Xanthous.Util (removeFirst, EqEqProp(..)) --------------------------------------------------------------------------------- - -data WieldedItem = WieldedItem - { _wieldedItem :: Item - , _wieldableItem :: WieldableItem - -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - WieldedItem -makeFieldsNoPrefix ''WieldedItem - -asWieldedItem :: Prism' Item WieldedItem -asWieldedItem = prism' hither yon - where - yon item = WieldedItem item <$> item ^. itemType . wieldable - hither (WieldedItem item _) = item - -instance Brain WieldedItem where - step ticks (Positioned p wi) = - over positioned (\i -> WieldedItem i $ wi ^. wieldableItem) - <$> step ticks (Positioned p $ wi ^. wieldedItem) - -instance Draw WieldedItem where - draw = draw . view wieldedItem - -instance Entity WieldedItem where - entityAttributes = entityAttributes . view wieldedItem - description = description . view wieldedItem - entityChar = entityChar . view wieldedItem - -instance Arbitrary WieldedItem where - arbitrary = genericArbitrary <&> \wi -> - wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem - -data Wielded - = DoubleHanded WieldedItem - | Hands { _leftHand :: !(Maybe WieldedItem) - , _rightHand :: !(Maybe WieldedItem) - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Wielded - deriving (ToJSON, FromJSON) - via WithOptions '[ 'SumEnc 'ObjWithSingleField ] - Wielded - - -nothingWielded :: Wielded -nothingWielded = Hands Nothing Nothing - -hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem) -hands = prism' (uncurry Hands) $ \case - Hands l r -> Just (l, r) - _ -> Nothing - -leftHand :: Traversal' Wielded (Maybe WieldedItem) -leftHand = hands . _1 - -inLeftHand :: WieldedItem -> Wielded -inLeftHand wi = Hands (Just wi) Nothing - -rightHand :: Traversal' Wielded (Maybe WieldedItem) -rightHand = hands . _2 - -inRightHand :: WieldedItem -> Wielded -inRightHand wi = Hands Nothing (Just wi) - -doubleHanded :: Prism' Wielded WieldedItem -doubleHanded = prism' DoubleHanded $ \case - DoubleHanded i -> Just i - _ -> Nothing - -wieldedItems :: Traversal' Wielded WieldedItem -wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded -wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r - - -data Hand - = LeftHand - | RightHand - | BothHands - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Hand - -itemsInHand :: Hand -> Wielded -> [WieldedItem] -itemsInHand LeftHand (DoubleHanded wi) = [wi] -itemsInHand LeftHand (Hands lh _) = toList lh -itemsInHand RightHand (DoubleHanded wi) = [wi] -itemsInHand RightHand (Hands _ rh) = toList rh -itemsInHand BothHands (DoubleHanded wi) = [wi] -itemsInHand BothHands (Hands lh rh) = toList lh <> toList rh - -inHand :: Hand -> WieldedItem -> Wielded -inHand LeftHand = inLeftHand -inHand RightHand = inRightHand -inHand BothHands = review doubleHanded - -wieldInHand :: Hand -> WieldedItem -> Wielded -> ([WieldedItem], Wielded) -wieldInHand hand item w = (itemsInHand hand w, doWield) - where - doWield = case (hand, w) of - (LeftHand, Hands _ r) -> Hands (Just item) r - (LeftHand, DoubleHanded _) -> inLeftHand item - (RightHand, Hands l _) -> Hands l (Just item) - (RightHand, DoubleHanded _) -> inRightHand item - (BothHands, _) -> DoubleHanded item - -describeHand :: Hand -> Text -describeHand LeftHand = "your left hand" -describeHand RightHand = "your right hand" -describeHand BothHands = "both hands" - -data Inventory = Inventory - { _backpack :: Vector Item - , _wielded :: Wielded - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Inventory - deriving EqProp via EqEqProp Inventory - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Inventory -makeFieldsNoPrefix ''Inventory - -items :: Traversal' Inventory Item -items k (Inventory bp w) = Inventory - <$> traversed k bp - <*> (wieldedItems . wieldedItem) k w - -type instance Element Inventory = Item - -instance MonoFunctor Inventory where - omap = over items - -instance MonoFoldable Inventory where - ofoldMap = foldMapOf items - ofoldr = foldrOf items - ofoldl' = foldlOf' items - otoList = toListOf items - oall = allOf items - oany = anyOf items - onull = nullOf items - ofoldr1Ex = foldr1Of items - ofoldl1Ex' = foldl1Of' items - headEx = headEx . toListOf items - lastEx = lastEx . toListOf items - -instance MonoTraversable Inventory where - otraverse = traverseOf items - -instance Semigroup Inventory where - inv₁ <> inv₂ = - let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack - (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of - (wielded₁, wielded₂@(DoubleHanded _)) -> - (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) - (wielded₁, wielded₂@(Hands (Just _) (Just _))) -> - (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) - (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack') - (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack') - (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) -> - (Hands (Just l₁) (Just r₂), backpack') - (wielded₁@(DoubleHanded _), wielded₂) -> - (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem)) - (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) -> - (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack') - (Hands Nothing r₁, Hands (Just l₂) Nothing) -> - (Hands (Just l₂) r₁, backpack') - (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) -> - (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack') - (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) -> - (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack') - (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) -> - (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack') - in Inventory backpack'' wielded' - -instance Monoid Inventory where - mempty = Inventory mempty $ Hands Nothing Nothing - -class HasInventory s a | s -> a where - inventory :: Lens' s a - {-# MINIMAL inventory #-} - --- | Representation for where in the inventory an item might be -data InventoryPosition - = Backpack - | InHand Hand - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary InventoryPosition - --- | Return a human-readable description of the given 'InventoryPosition' -describeInventoryPosition :: InventoryPosition -> Text -describeInventoryPosition Backpack = "In backpack" -describeInventoryPosition (InHand hand) = "Wielded, in " <> describeHand hand - --- | Given a position in the inventory, return a traversal on the inventory over --- all the items in that position -inventoryPosition :: InventoryPosition -> Traversal' Inventory Item -inventoryPosition Backpack = backpack . traversed -inventoryPosition (InHand LeftHand) = wielded . leftHand . _Just . wieldedItem -inventoryPosition (InHand RightHand) = wielded . leftHand . _Just . wieldedItem -inventoryPosition (InHand BothHands) = wielded . doubleHanded . wieldedItem - --- | A fold over all the items in the inventory accompanied by their position in --- the inventory --- --- Invariant: This will return items in the same order as 'items' -itemsWithPosition :: Fold Inventory (InventoryPosition, Item) -itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems - where - backpackItems = toListOf $ backpack . folded . to (Backpack ,) - handItems inv = case inv ^. wielded of - DoubleHanded i -> pure (InHand BothHands, i ^. wieldedItem) - Hands l r -> (l ^.. folded . wieldedItem . to (InHand LeftHand ,)) - <> (r ^.. folded . wieldedItem . to (InHand RightHand ,)) - --- | Remove the first item equal to 'Item' from the given position in the --- inventory -removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory -removeItemFromPosition Backpack item inv - = inv & backpack %~ removeFirst (== item) -removeItemFromPosition (InHand LeftHand) item inv - = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem) -removeItemFromPosition (InHand RightHand) item inv - = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem) -removeItemFromPosition (InHand BothHands) item inv - | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv - = inv & wielded .~ nothingWielded - | otherwise - = inv diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs deleted file mode 100644 index 3ea610795e..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Creature - ( -- * Creature - Creature(..) - -- ** Lenses - , creatureType - , hitpoints - , hippocampus - , inventory - - -- ** Creature functions - , damage - , isDead - , visionRadius - - -- * Hippocampus - , Hippocampus(..) - -- ** Lenses - , destination - -- ** Destination - , Destination(..) - , destinationFromPos - -- *** Lenses - , destinationPosition - , destinationProgress - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.AI.Gormlak -import Xanthous.Entities.RawTypes hiding - (Creature, description, damage) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Game.State -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Entities.Creature.Hippocampus -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Xanthous.Entities.Common (Inventory, HasInventory(..)) --------------------------------------------------------------------------------- - -data Creature = Creature - { _creatureType :: !CreatureType - , _hitpoints :: !Hitpoints - , _hippocampus :: !Hippocampus - , _inventory :: !Inventory - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature - deriving Arbitrary via GenericArbitrary Creature - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Creature -makeFieldsNoPrefix ''Creature - -instance HasVisionRadius Creature where - visionRadius = const 50 -- TODO - -instance Brain Creature where - step = brainVia GormlakBrain - entityCanMove = const True - -instance Entity Creature where - entityAttributes _ = defaultEntityAttributes - & blocksObject .~ True - description = view $ creatureType . Raw.description - entityChar = view $ creatureType . char - entityCollision = const $ Just Combat - --------------------------------------------------------------------------------- - -damage :: Hitpoints -> Creature -> Creature -damage amount = hitpoints %~ \hp -> - if hp <= amount - then 0 - else hp - amount - -isDead :: Creature -> Bool -isDead = views hitpoints (== 0) - -{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs deleted file mode 100644 index d13ea8055c..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Creature.Hippocampus - (-- * Hippocampus - Hippocampus(..) - , initialHippocampus - -- ** Lenses - , destination - , greetedCharacter - -- ** Destination - , Destination(..) - , destinationFromPos - -- *** Lenses - , destinationPosition - , destinationProgress - ) -where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic --------------------------------------------------------------------------------- -import Xanthous.Data --------------------------------------------------------------------------------- - - -data Destination = Destination - { _destinationPosition :: !Position - -- | The progress towards the destination, tracked as an offset from the - -- creature's original position. - -- - -- When this value reaches >= 1, the creature has reached their destination - , _destinationProgress :: !Tiles - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Destination -instance Arbitrary Destination where arbitrary = genericArbitrary -makeLenses ''Destination - -destinationFromPos :: Position -> Destination -destinationFromPos _destinationPosition = - let _destinationProgress = 0 - in Destination{..} - -data Hippocampus = Hippocampus - { _destination :: !(Maybe Destination) - , -- | Has this creature greeted the character in any way yet? - -- - -- Some creature types ignore this field - _greetedCharacter :: !Bool - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Hippocampus - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Hippocampus -makeLenses ''Hippocampus - -initialHippocampus :: Hippocampus -initialHippocampus = Hippocampus - { _destination = Nothing - , _greetedCharacter = False - } diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs deleted file mode 100644 index aa6c5fa4fc..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Xanthous.Entities.Draw.Util where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick.Widgets.Border.Style -import Brick.Types (Edges(..)) --------------------------------------------------------------------------------- - -borderFromEdges :: BorderStyle -> Edges Bool -> Char -borderFromEdges bstyle edges = ($ bstyle) $ case edges of - Edges False False False False -> const '☐' - - Edges True False False False -> bsVertical - Edges False True False False -> bsVertical - Edges False False True False -> bsHorizontal - Edges False False False True -> bsHorizontal - - Edges True True False False -> bsVertical - Edges True False True False -> bsCornerBR - Edges True False False True -> bsCornerBL - - Edges False True True False -> bsCornerTR - Edges False True False True -> bsCornerTL - Edges False False True True -> bsHorizontal - - Edges False True True True -> bsIntersectT - Edges True False True True -> bsIntersectB - Edges True True False True -> bsIntersectL - Edges True True True False -> bsIntersectR - - Edges True True True True -> bsIntersectFull diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs deleted file mode 100644 index a0c037a1b4..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Entities () where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import qualified Test.QuickCheck.Gen as Gen -import Data.Aeson --------------------------------------------------------------------------------- -import Xanthous.Entities.Character -import Xanthous.Entities.Item -import Xanthous.Entities.Creature -import Xanthous.Entities.Environment -import Xanthous.Entities.Marker -import Xanthous.Game.State -import Xanthous.Util.QuickCheck -import Data.Aeson.Generic.DerivingVia --------------------------------------------------------------------------------- - -instance Arbitrary SomeEntity where - arbitrary = Gen.oneof - [ SomeEntity <$> arbitrary @Character - , SomeEntity <$> arbitrary @Item - , SomeEntity <$> arbitrary @Creature - , SomeEntity <$> arbitrary @Wall - , SomeEntity <$> arbitrary @Door - , SomeEntity <$> arbitrary @GroundMessage - , SomeEntity <$> arbitrary @Staircase - , SomeEntity <$> arbitrary @Marker - ] - -instance FromJSON SomeEntity where - parseJSON = withObject "Entity" $ \obj -> do - (entityType :: Text) <- obj .: "type" - case entityType of - "Character" -> SomeEntity @Character <$> obj .: "data" - "Item" -> SomeEntity @Item <$> obj .: "data" - "Creature" -> SomeEntity @Creature <$> obj .: "data" - "Wall" -> SomeEntity @Wall <$> obj .: "data" - "Door" -> SomeEntity @Door <$> obj .: "data" - "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data" - "Staircase" -> SomeEntity @Staircase <$> obj .: "data" - "Marker" -> SomeEntity @Marker <$> obj .: "data" - _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\"" - -deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel - instance FromJSON GameLevel -deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState - instance FromJSON GameState - -instance Entity SomeEntity where - entityAttributes (SomeEntity ent) = entityAttributes ent - description (SomeEntity ent) = description ent - entityChar (SomeEntity ent) = entityChar ent - entityCollision (SomeEntity ent) = entityCollision ent - -instance Function SomeEntity where - function = functionJSON - -instance CoArbitrary SomeEntity where - coarbitrary = coarbitrary . encode diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot deleted file mode 100644 index 519a862c6a..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Xanthous.Entities.Entities where - -import Test.QuickCheck -import Data.Aeson -import Xanthous.Game.State (SomeEntity, GameState, Entity) - -instance Arbitrary SomeEntity -instance Function SomeEntity -instance CoArbitrary SomeEntity -instance FromJSON SomeEntity -instance Entity SomeEntity - -instance FromJSON GameState diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs b/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs deleted file mode 100644 index b45a91eabe..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Xanthous.Entities.Environment - ( - -- * Walls - Wall(..) - - -- * Doors - , Door(..) - , open - , closed - , locked - , unlockedDoor - - -- * Messages - , GroundMessage(..) - - -- * Stairs - , Staircase(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Brick (str) -import Brick.Widgets.Border.Style (unicode) -import Brick.Types (Edges(..)) -import Data.Aeson -import Data.Aeson.Generic.DerivingVia --------------------------------------------------------------------------------- -import Xanthous.Entities.Draw.Util -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Game.State -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - -data Wall = Wall - deriving stock (Show, Eq, Ord, Generic, Enum) - deriving anyclass (NFData, CoArbitrary, Function) - -instance ToJSON Wall where - toJSON = const $ String "Wall" - -instance FromJSON Wall where - parseJSON = withText "Wall" $ \case - "Wall" -> pure Wall - _ -> fail "Invalid Wall: expected Wall" - -instance Brain Wall where step = brainVia Brainless - -instance Entity Wall where - entityAttributes _ = defaultEntityAttributes - & blocksVision .~ True - & blocksObject .~ True - description _ = "a wall" - entityChar _ = "┼" - -instance Arbitrary Wall where - arbitrary = pure Wall - -wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity) - => Neighbors mono -> Edges Bool -wallEdges neighs = any (entityIs @Wall) <$> edges neighs - -instance Draw Wall where - drawWithNeighbors neighs _wall = - str . pure . borderFromEdges unicode $ wallEdges neighs - -data Door = Door - { _open :: Bool - , _locked :: Bool - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary Door -makeLenses ''Door - -instance Draw Door where - drawWithNeighbors neighs door - = str . pure . ($ door ^. open) $ case wallEdges neighs of - Edges True False False False -> vertDoor - Edges False True False False -> vertDoor - Edges True True False False -> vertDoor - Edges False False True False -> horizDoor - Edges False False False True -> horizDoor - Edges False False True True -> horizDoor - _ -> allsidesDoor - where - horizDoor True = '␣' - horizDoor False = 'ᚔ' - vertDoor True = '[' - vertDoor False = 'ǂ' - allsidesDoor True = '+' - allsidesDoor False = '▥' - -instance Brain Door where step = brainVia Brainless - -instance Entity Door where - entityAttributes door = defaultEntityAttributes - & blocksVision .~ not (door ^. open) - description door | door ^. open = "an open door" - | otherwise = "a closed door" - entityChar _ = "d" - entityCollision door | door ^. open = Nothing - | otherwise = Just Stop - -closed :: Lens' Door Bool -closed = open . involuted not - --- | A closed, unlocked door -unlockedDoor :: Door -unlockedDoor = Door - { _open = False - , _locked = False - } - --------------------------------------------------------------------------------- - -newtype GroundMessage = GroundMessage Text - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary GroundMessage - deriving (ToJSON, FromJSON) - via WithOptions '[ 'TagSingleConstructors 'True - , 'SumEnc 'ObjWithSingleField - ] - GroundMessage - deriving Draw - via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈" - GroundMessage -instance Brain GroundMessage where step = brainVia Brainless - -instance Entity GroundMessage where - description = const "a message on the ground. Press r. to read it." - entityChar = const "≈" - entityCollision = const Nothing - --------------------------------------------------------------------------------- - -data Staircase = UpStaircase | DownStaircase - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Staircase - deriving (ToJSON, FromJSON) - via WithOptions '[ 'TagSingleConstructors 'True - , 'SumEnc 'ObjWithSingleField - ] - Staircase -instance Brain Staircase where step = brainVia Brainless - -instance Draw Staircase where - draw UpStaircase = str "<" - draw DownStaircase = str ">" - -instance Entity Staircase where - description UpStaircase = "a staircase leading upwards" - description DownStaircase = "a staircase leading downwards" - entityChar UpStaircase = "<" - entityChar DownStaircase = ">" - entityCollision = const Nothing diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs deleted file mode 100644 index eadd625696..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Item - ( Item(..) - , itemType - , density - , volume - , newWithType - , isEdible - , weight - , fullDescription - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Test.QuickCheck (Arbitrary, CoArbitrary, Function) -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Control.Monad.Random (MonadRandom) --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes (ItemType) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Game.State -import Xanthous.Data (Grams, Per, Cubic, Meters, (|*|)) -import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary)) -import Xanthous.Random (choose, FiniteInterval(..)) --------------------------------------------------------------------------------- - -data Item = Item - { _itemType :: ItemType - , _density :: Grams `Per` Cubic Meters - , _volume :: Cubic Meters - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Draw via DrawRawChar "_itemType" Item - deriving Arbitrary via GenericArbitrary Item - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Item -makeLenses ''Item - --- deriving via (Brainless Item) instance Brain Item -instance Brain Item where step = brainVia Brainless - -instance Entity Item where - description = view $ itemType . Raw.description - entityChar = view $ itemType . Raw.char - entityCollision = const Nothing - -newWithType :: MonadRandom m => ItemType -> m Item -newWithType _itemType = do - _density <- choose . FiniteInterval $ _itemType ^. Raw.density - _volume <- choose . FiniteInterval $ _itemType ^. Raw.volume - pure Item {..} - -isEdible :: Item -> Bool -isEdible = Raw.isEdible . view itemType - --- | The weight of this item, calculated by multiplying its volume by the --- density of its material -weight :: Item -> Grams -weight item = (item ^. density) |*| (item ^. volume) - --- | Describe the item in full detail -fullDescription :: Item -> Text -fullDescription item = unlines - [ item ^. itemType . Raw.description - , "" - , item ^. itemType . Raw.longDescription - , "" - , "volume: " <> tshow (item ^. volume) - , "density: " <> tshow (item ^. density) - , "weight: " <> tshow (weight item) - ] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs b/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs deleted file mode 100644 index 14d02872ed..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs +++ /dev/null @@ -1,41 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Entities.Marker ( Marker(..) ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson -import Test.QuickCheck -import qualified Graphics.Vty.Attributes as Vty -import qualified Graphics.Vty.Image as Vty -import Brick.Widgets.Core (raw) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Data.Entities (EntityAttributes(..)) --------------------------------------------------------------------------------- - --- | Mark on the map - for use in debugging / development only. -newtype Marker = Marker Text - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Semigroup, Monoid, ToJSON, FromJSON, Arbitrary) via Text - -instance Brain Marker where step = brainVia Brainless - -instance Entity Marker where - entityAttributes = const EntityAttributes - { _blocksVision = False - , _blocksObject = False - , _collision = Stop - } - description (Marker m) = "[M] " <> m - entityChar = const $ "X" & style .~ markerStyle - entityCollision = const Nothing - -instance Draw Marker where - draw = const . raw $ Vty.char markerStyle 'X' - drawPriority = const maxBound - -markerStyle :: Vty.Attr -markerStyle = Vty.defAttr - `Vty.withForeColor` Vty.red - `Vty.withBackColor` Vty.black diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs deleted file mode 100644 index a7021d76cf..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DuplicateRecordFields #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.RawTypes - ( - EntityRaw(..) - , _Creature - , _Item - - -- * Creatures - , CreatureType(..) - , hostile - -- ** Generation parameters - , CreatureGenerateParams(..) - , canGenerate - -- ** Language - , LanguageName(..) - , getLanguage - -- ** Attacks - , Attack(..) - - -- * Items - , ItemType(..) - -- ** Item sub-types - -- *** Edible - , EdibleItem(..) - , isEdible - -- *** Wieldable - , WieldableItem(..) - , isWieldable - - -- * Lens classes - , HasAttackMessage(..) - , HasAttacks(..) - , HasChance(..) - , HasChar(..) - , HasCreatureAttackMessage(..) - , HasDamage(..) - , HasDensity(..) - , HasDescription(..) - , HasEatMessage(..) - , HasEdible(..) - , HasEntityName(..) - , HasEquippedItem(..) - , HasFriendly(..) - , HasGenerateParams(..) - , HasHitpointsHealed(..) - , HasLanguage(..) - , HasLevelRange(..) - , HasLongDescription(..) - , HasMaxHitpoints(..) - , HasName(..) - , HasSayVerb(..) - , HasSpeed(..) - , HasVolume(..) - , HasWieldable(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Test.QuickCheck -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) -import Data.Interval (Interval, lowerBound', upperBound') -import qualified Data.Interval as Interval --------------------------------------------------------------------------------- -import Xanthous.Messages (Message(..)) -import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters) -import Xanthous.Data.EntityChar -import Xanthous.Util.QuickCheck -import Xanthous.Generators.Speech (Language, gormlak, english) -import Xanthous.Orphans () -import Xanthous.Util (EqProp, EqEqProp(..)) --------------------------------------------------------------------------------- - --- | Identifiers for languages that creatures can speak. --- --- Non-verbal or non-sentient creatures have Nothing as their language --- --- At some point, we will likely want to make languages be defined in data files --- somewhere, and reference them that way instead. -data LanguageName = Gormlak | English - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary LanguageName - deriving (ToJSON, FromJSON) - via WithOptions '[ AllNullaryToStringTag 'True ] - LanguageName - --- | Resolve a 'LanguageName' into an actual 'Language' -getLanguage :: LanguageName -> Language -getLanguage Gormlak = gormlak -getLanguage English = english - --- | Natural attacks for creature types -data Attack = Attack - { -- | the @{{creature}}@ @{{description}}@ - _description :: !Message - -- | Damage dealt - , _damage :: !Hitpoints - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Attack - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] - , OmitNothingFields 'True - ] - Attack -makeFieldsNoPrefix ''Attack - --- | Description for generating an item equipped to a creature -data CreatureEquippedItem = CreatureEquippedItem - { -- | Name of the entity type to generate - _entityName :: !Text - -- | Chance of generating the item when generating the creature - -- - -- A chance of 1.0 will always generate the item - , _chance :: !Double - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureEquippedItem - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] - , OmitNothingFields 'True - ] - CreatureEquippedItem -makeFieldsNoPrefix ''CreatureEquippedItem - - -data CreatureGenerateParams = CreatureGenerateParams - { -- | Range of dungeon levels at which to generate this creature - _levelRange :: !(Interval Word) - -- | Item equipped to the creature - , _equippedItem :: !(Maybe CreatureEquippedItem) - } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureGenerateParams - deriving EqProp via EqEqProp CreatureGenerateParams - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - CreatureGenerateParams -makeFieldsNoPrefix ''CreatureGenerateParams - -instance Ord CreatureGenerateParams where - compare - = (compare `on` lowerBound' . _levelRange) - <> (compare `on` upperBound' . _levelRange) - <> (compare `on` _equippedItem) - --- | Can a creature with these generate params be generated on this level? -canGenerate - :: Word -- ^ Level number - -> CreatureGenerateParams - -> Bool -canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange - -data CreatureType = CreatureType - { _name :: !Text - , _description :: !Text - , _char :: !EntityChar - , _maxHitpoints :: !Hitpoints - , _friendly :: !Bool - , _speed :: !TicksPerTile - , _language :: !(Maybe LanguageName) - , -- | The verb, in present tense, for when the creature says something - _sayVerb :: !(Maybe Text) - , -- | The creature's natural attacks - _attacks :: !(NonNull (Vector Attack)) - -- | Parameters for generating the creature in levels - , _generateParams :: !(Maybe CreatureGenerateParams) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureType - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] - , OmitNothingFields 'True - ] - CreatureType -makeFieldsNoPrefix ''CreatureType - -hostile :: Lens' CreatureType Bool -hostile = friendly . involuted not - --------------------------------------------------------------------------------- - -data EdibleItem = EdibleItem - { _hitpointsHealed :: !Int - , _eatMessage :: !(Maybe Message) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EdibleItem - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - EdibleItem -makeFieldsNoPrefix ''EdibleItem - -data WieldableItem = WieldableItem - { _damage :: !Hitpoints - -- | Message to use when the character is using this item to attack a - -- creature. - -- - -- Grammatically, this should be of the form "slash at the - -- {{creature.creatureType.name}} with your dagger" - -- - -- = Parameters - -- - -- [@creature@ (type: 'Creature')] The creature being attacked - , _attackMessage :: !(Maybe Message) - -- | Message to use when a creature is using this item to attack the - -- character. - -- - -- Grammatically, should be of the form "The creature slashes you with its - -- dagger". - -- - -- = Parameters - -- - -- [@creature@ (type: 'Creature')] The creature doing the attacking - -- [@item@ (type: 'Item')] The item itself - , _creatureAttackMessage :: !(Maybe Message) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary WieldableItem - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - WieldableItem -makeFieldsNoPrefix ''WieldableItem - --------------------------------------------------------------------------------- - -data ItemType = ItemType - { _name :: !Text - , _description :: !Text - , _longDescription :: !Text - , _char :: !EntityChar - , _density :: !(Interval (Grams `Per` Cubic Meters)) - , _volume :: !(Interval (Cubic Meters)) - , _edible :: !(Maybe EdibleItem) - , _wieldable :: !(Maybe WieldableItem) - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary ItemType - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - ItemType -makeFieldsNoPrefix ''ItemType - -instance Ord ItemType where - compare x y - = compareOf name x y - <> compareOf description x y - <> compareOf longDescription x y - <> compareOf char x y - <> compareOf (density . to extractInterval) x y - <> compareOf (volume . to extractInterval) x y - <> compareOf edible x y - <> compareOf wieldable x y - where - compareOf l = comparing (view l) - extractInterval = lowerBound' &&& upperBound' - --- | Can this item be eaten? -isEdible :: ItemType -> Bool -isEdible = has $ edible . _Just - --- | Can this item be used as a weapon? -isWieldable :: ItemType -> Bool -isWieldable = has $ wieldable . _Just - --------------------------------------------------------------------------------- - -data EntityRaw - = Creature !CreatureType - | Item !ItemType - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - deriving Arbitrary via GenericArbitrary EntityRaw - deriving (FromJSON) - via WithOptions '[ SumEnc ObjWithSingleField ] - EntityRaw -makePrisms ''EntityRaw diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs deleted file mode 100644 index 10f0d83193..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Raws - ( raws - , raw - , RawType(..) - , rawsWithType - ) where --------------------------------------------------------------------------------- -import Data.FileEmbed -import qualified Data.Yaml as Yaml -import Xanthous.Prelude -import System.FilePath.Posix --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes -import Xanthous.AI.Gormlak () --------------------------------------------------------------------------------- -rawRaws :: [(FilePath, ByteString)] -rawRaws = $(embedDir "src/Xanthous/Entities/Raws") - -raws :: HashMap Text EntityRaw -raws - = mapFromList - . map (bimap - (pack . takeBaseName) - (either (error . Yaml.prettyPrintParseException) id - . Yaml.decodeEither')) - $ rawRaws - -raw :: Text -> Maybe EntityRaw -raw n = raws ^. at n - -class RawType (a :: Type) where - _RawType :: Prism' EntityRaw a - -instance RawType CreatureType where - _RawType = prism' Creature $ \case - Creature c -> Just c - _ -> Nothing - -instance RawType ItemType where - _RawType = prism' Item $ \case - Item i -> Just i - _ -> Nothing - -rawsWithType :: forall a. RawType a => HashMap Text a -rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws - --------------------------------------------------------------------------------- diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml deleted file mode 100644 index 12c76fc14b..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml +++ /dev/null @@ -1,24 +0,0 @@ -Item: - name: broken dagger - description: a short, broken dagger - longDescription: A short dagger with a twisted, chipped blade - char: - char: † - style: - foreground: black - wieldable: - damage: 3 - attackMessage: - - slash at the {{creature.creatureType.name}} with your dagger - - stab the {{creature.creatureType.name}} with your dagger - creatureAttackMessage: - - The {{creature.creatureType.name}} slashes at you with its dagger. - - The {{creature.creatureType.name}} stabs you with its dagger. - # Just the steel, not the handle, for now - density: [7750 , 8050000] - # 15cm – 45cm - # × - # 2cm – 3cm - # × - # .5cm – 1cm - volume: [0.15, 1.35] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml deleted file mode 100644 index ad3d9cb147..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml +++ /dev/null @@ -1,20 +0,0 @@ -Creature: - name: gormlak - description: a gormlak - longDescription: | - A chittering imp-like creature with bright yellow horns and sharp claws. It - adores shiny objects and gathers in swarms. - char: - char: g - style: - foreground: red - maxHitpoints: 5 - speed: 125 - friendly: false - language: Gormlak - sayVerb: yells - attacks: - - description: - - claws you - - slashes you with its claws - damage: 1 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml deleted file mode 100644 index cdfcde616d..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml +++ /dev/null @@ -1,26 +0,0 @@ -Creature: - name: husk - description: an empty husk of some humanoid creature - longDescription: | - An empty husk of a humanoid creature. All semblance of sentience has long - left its eyes; instead it shambles about aimlessly, always hungering for the - warmth of life. - char: - char: h - style: - foreground: black - maxHitpoints: 6 - speed: 110 - friendly: false - attacks: - - description: - - swings its arms at you - - elbows you - damage: 1 - - description: kicks you - damage: 2 - generateParams: - levelRange: [1, PosInf] - equippedItem: - entityName: broken-dagger - chance: 0.9 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml deleted file mode 100644 index c0501a18a8..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ /dev/null @@ -1,14 +0,0 @@ -Item: - name: noodles - description: "a big bowl o' noodles" - longDescription: You know exactly what kind of noodles - char: - char: 'n' - style: - foreground: yellow - edible: - hitpointsHealed: 2 - eatMessage: - - You slurp up the noodles. Yumm! - density: 500000 - volume: 0.001 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml deleted file mode 100644 index fe427c94ab..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml +++ /dev/null @@ -1,15 +0,0 @@ -Creature: - name: ooze - description: an ooze - longDescription: | - A jiggling, amorphous, bright green caustic blob - char: - char: o - style: - foreground: green - maxHitpoints: 3 - speed: 100 - friendly: false - attacks: - - description: slams into you - damage: 1 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml deleted file mode 100644 index 3f4e133fe2..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml +++ /dev/null @@ -1,10 +0,0 @@ -Item: - name: rock - description: a rock - longDescription: a medium-sized rock made out of some unknown stone - char: . - wieldable: - damage: 1 - attackMessage: hit the {{creature.creatureType.name}} in the head with your rock - density: [ 1500000, 2500000 ] - volume: [ 0.000125, 0.001 ] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml deleted file mode 100644 index 7f9e1faffe..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ /dev/null @@ -1,22 +0,0 @@ -Item: - name: stick - description: a wooden stick - longDescription: A sturdy branch broken off from some sort of tree - char: - char: ∤ - style: - foreground: yellow - wieldable: - damage: 2 - attackMessage: - - bonk the {{creature.creatureType.name}} over the head with your stick - - bash the {{creature.creatureType.name}} on the noggin with your stick - - whack the {{creature.creatureType.name}} with your stick - creatureAttackMessage: - - The {{creature.creatureType.name}} bonks you over the head with its stick. - - The {{creature.creatureType.name}} bashes you on the noggin with its stick. - - The {{creature.creatureType.name}} whacks you with its stick. - # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density - # it's a hard stick. so it's dense wood. - density: 890000 # g/m³ - volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length |