diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Entities')
14 files changed, 0 insertions, 1021 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs deleted file mode 100644 index c18d726a4bfd..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# 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 deleted file mode 100644 index e95e9f0b985b..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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 deleted file mode 100644 index 501a5b597221..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 deleted file mode 100644 index aa6c5fa4fc47..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs deleted file mode 100644 index a0c037a1b4ed..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot deleted file mode 100644 index 519a862c6a5a..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Environment.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs deleted file mode 100644 index b45a91eabed2..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Item.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs deleted file mode 100644 index b50a5eab809d..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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/Marker.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs deleted file mode 100644 index 14d02872ed4e..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs deleted file mode 100644 index 30039662f071..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# 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 deleted file mode 100644 index d4cae7ccc299..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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 deleted file mode 100644 index 2eac895190b3..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index c3f19dce91d1..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ /dev/null @@ -1,12 +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! diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml deleted file mode 100644 index bc7fde4d8b02..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ /dev/null @@ -1,14 +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: - - 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. |