diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Entities')
13 files changed, 977 insertions, 0 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs new file mode 100644 index 0000000000..c18d726a4b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE TemplateHaskell #-} +module Xanthous.Entities.Character + ( Character(..) + , characterName + , inventory + , characterDamage + , characterHitpoints' + , characterHitpoints + , hitpointRecoveryRate + , speed + + -- * Inventory + , Inventory(..) + , backpack + , wielded + , items + -- ** Wielded items + , Wielded(..) + , hands + , leftHand + , rightHand + , inLeftHand + , inRightHand + , doubleHanded + , wieldedItems + , WieldedItem(..) + , wieldedItem + , wieldableItem + , asWieldedItem + + -- * + , mkCharacter + , pickUpItem + , isDead + , 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 Xanthous.Util.QuickCheck +import Xanthous.Game.State +import Xanthous.Entities.Item +import Xanthous.Data + ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned + , Positioned(..) + ) +import Xanthous.Entities.RawTypes (WieldableItem, wieldable) +import qualified Xanthous.Entities.RawTypes as Raw +-------------------------------------------------------------------------------- + +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 + +hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem) +hands = prism' (uncurry Hands) $ \case + Hands l r -> Just (l, r) + _ -> Nothing + +leftHand :: Traversal' Wielded WieldedItem +leftHand = hands . _1 . _Just + +inLeftHand :: WieldedItem -> Wielded +inLeftHand wi = Hands (Just wi) Nothing + +rightHand :: Traversal' Wielded WieldedItem +rightHand = hands . _2 . _Just + +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 Inventory = Inventory + { _backpack :: Vector Item + , _wielded :: Wielded + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary 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 + +-------------------------------------------------------------------------------- + +data Character = Character + { _inventory :: !Inventory + , _characterName :: !(Maybe Text) + , _characterHitpoints' :: !Double + , _speed :: TicksPerTile + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Character +makeLenses ''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 = (pure .) $ positioned . characterHitpoints' %~ \hp -> + if hp > fromIntegral initialHitpoints + then hp + else hp + hitpointRecoveryRate |*| 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 + } + +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 + . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage) + +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 diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs new file mode 100644 index 0000000000..e95e9f0b98 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature + ( -- * Creature + Creature(..) + -- ** Lenses + , creatureType + , hitpoints + , hippocampus + + -- ** Creature functions + , newWithType + , damage + , isDead + , visionRadius + + -- * Hippocampus + , Hippocampus(..) + -- ** Lenses + , destination + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +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 +-------------------------------------------------------------------------------- + +data Creature = Creature + { _creatureType :: !CreatureType + , _hitpoints :: !Hitpoints + , _hippocampus :: !Hippocampus + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Creature +instance Arbitrary Creature where arbitrary = genericArbitrary +makeLenses ''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 + +-------------------------------------------------------------------------------- + +newWithType :: CreatureType -> Creature +newWithType _creatureType = + let _hitpoints = _creatureType ^. maxHitpoints + _hippocampus = initialHippocampus + in Creature {..} + +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/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs new file mode 100644 index 0000000000..501a5b5972 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature.Hippocampus + (-- * Hippocampus + Hippocampus(..) + , initialHippocampus + -- ** Lenses + , destination + -- ** 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 +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + + +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) + } + 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 Nothing diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs new file mode 100644 index 0000000000..aa6c5fa4fc --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs @@ -0,0 +1,31 @@ +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/glittershark/xanthous/src/Xanthous/Entities/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs new file mode 100644 index 0000000000..62e6e15c98 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs @@ -0,0 +1,60 @@ +{-# 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.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 + ] + +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" + _ -> 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/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot new file mode 100644 index 0000000000..519a862c6a --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot @@ -0,0 +1,14 @@ +{-# 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/glittershark/xanthous/src/Xanthous/Entities/Environment.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs new file mode 100644 index 0000000000..b45a91eabe --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs @@ -0,0 +1,160 @@ +{-# 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/glittershark/xanthous/src/Xanthous/Entities/Item.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs new file mode 100644 index 0000000000..b50a5eab80 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Item + ( Item(..) + , itemType + , newWithType + , isEdible + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson.Generic.DerivingVia +-------------------------------------------------------------------------------- +import Xanthous.Entities.RawTypes hiding (Item, description, isEdible) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Game.State +-------------------------------------------------------------------------------- + +data Item = Item + { _itemType :: ItemType + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Draw via DrawRawChar "_itemType" Item + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Item +makeLenses ''Item + +{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-} + +-- deriving via (Brainless Item) instance Brain Item +instance Brain Item where step = brainVia Brainless + +instance Arbitrary Item where + arbitrary = Item <$> arbitrary + +instance Entity Item where + description = view $ itemType . Raw.description + entityChar = view $ itemType . Raw.char + entityCollision = const Nothing + +newWithType :: ItemType -> Item +newWithType = Item + +isEdible :: Item -> Bool +isEdible = Raw.isEdible . view itemType diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs new file mode 100644 index 0000000000..30039662f0 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.RawTypes + ( + EntityRaw(..) + , _Creature + , _Item + + -- * Creatures + , CreatureType(..) + , hostile + + -- * Items + , ItemType(..) + -- ** Item sub-types + -- *** Edible + , EdibleItem(..) + , isEdible + -- *** Wieldable + , WieldableItem(..) + , isWieldable + + -- * Lens classes + , HasAttackMessage(..) + , HasChar(..) + , HasDamage(..) + , HasDescription(..) + , HasEatMessage(..) + , HasEdible(..) + , HasFriendly(..) + , HasHitpointsHealed(..) + , HasLongDescription(..) + , HasMaxHitpoints(..) + , HasName(..) + , HasSpeed(..) + , HasWieldable(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.Messages (Message(..)) +import Xanthous.Data (TicksPerTile, Hitpoints) +import Xanthous.Data.EntityChar +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +data CreatureType = CreatureType + { _name :: !Text + , _description :: !Text + , _char :: !EntityChar + , _maxHitpoints :: !Hitpoints + , _friendly :: !Bool + , _speed :: !TicksPerTile + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary CreatureType + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + 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 + , _attackMessage :: !(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 + , _edible :: Maybe EdibleItem + , _wieldable :: Maybe WieldableItem + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary ItemType + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + ItemType +makeFieldsNoPrefix ''ItemType + +-- | 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/glittershark/xanthous/src/Xanthous/Entities/Raws.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs new file mode 100644 index 0000000000..d4cae7ccc2 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Raws + ( raws + , raw + , RawType(..) + , rawsWithType + , entityFromRaw + ) where +-------------------------------------------------------------------------------- +import Data.FileEmbed +import qualified Data.Yaml as Yaml +import Xanthous.Prelude +import System.FilePath.Posix +-------------------------------------------------------------------------------- +import Xanthous.Entities.RawTypes +import Xanthous.Game.State +import qualified Xanthous.Entities.Creature as Creature +import qualified Xanthous.Entities.Item as Item +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 + +-------------------------------------------------------------------------------- + +entityFromRaw :: EntityRaw -> SomeEntity +entityFromRaw (Creature creatureType) + = SomeEntity $ Creature.newWithType creatureType +entityFromRaw (Item itemType) + = SomeEntity $ Item.newWithType itemType diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml new file mode 100644 index 0000000000..2eac895190 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml @@ -0,0 +1,13 @@ +Creature: + name: gormlak + description: a gormlak + longDescription: | + A chittering imp-like creature with bright yellow horns. It adores shiny objects + and gathers in swarms. + char: + char: g + style: + foreground: red + maxHitpoints: 5 + speed: 125 + friendly: false diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml new file mode 100644 index 0000000000..c3f19dce91 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml @@ -0,0 +1,12 @@ +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! diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml new file mode 100644 index 0000000000..bc7fde4d8b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml @@ -0,0 +1,14 @@ +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: + - You bonk the {{creature.creatureType.name}} over the head with your stick. + - You bash the {{creature.creatureType.name}} on the noggin with your stick. + - You whack the {{creature.creatureType.name}} with your stick. |