diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/App.hs | 70 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Command.hs | 2 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data.hs | 59 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data/App.hs | 10 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Entities/Item.hs | 13 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 1 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/messages.yaml | 7 |
7 files changed, 131 insertions, 31 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 6ed545e3aa4f..f43b7e58fc91 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -1,6 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-} -------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} module Xanthous.App ( makeApp , RunType(..) @@ -19,6 +20,7 @@ import qualified Data.Vector as V import System.Exit import System.Directory (doesFileExist) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Vector.Lens (toVectorOf) -------------------------------------------------------------------------------- import Xanthous.App.Common import Xanthous.App.Time @@ -151,7 +153,7 @@ handleCommand PickUp = do stepGameBy 100 -- TODO handleCommand Drop = do - selectItemFromInventory_ ["drop", "menu"] Cancellable id + takeItemFromInventory_ ["drop", "menu"] Cancellable id (say_ ["drop", "nothing"]) $ \(MenuResult item) -> do entitiesAtCharacter %= (SomeEntity item <|) @@ -271,8 +273,16 @@ handleCommand Read = do handleCommand ShowInventory = showPanel InventoryPanel >> continue +handleCommand DescribeInventory = do + selectItemFromInventory_ ["inventory", "describe", "select"] Cancellable id + (say_ ["inventory", "describe", "nothing"]) + $ \(MenuResult item) -> + showPanel . ItemDescriptionPanel $ Item.fullDescription item + continue + + handleCommand Wield = do - selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem + takeItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem (say_ ["wield", "nothing"]) $ \(MenuResult item) -> do prevItems <- character . inventory . wielded <<.= inRightHand item @@ -403,8 +413,8 @@ entityMenuChar entity then ec else 'a' --- | Prompt with an item to select out of the inventory, remove it from the --- inventory, and call callback with it +-- | Prompt with an item to select out of the inventory and call callback with +-- it selectItemFromInventory :: forall item params. (ToJSON params) @@ -417,23 +427,21 @@ selectItemFromInventory -> AppM () -- ^ Action to take if there are no items matching -> (PromptResult ('Menu item) -> AppM ()) -> AppM () -selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = - uses (character . inventory . backpack) - (V.mapMaybe $ preview extraInfo) +selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do + uses (character . inventory) + (V.mapMaybe (preview extraInfo) . toVectorOf items) >>= \case Empty -> onEmpty - items' -> - menu msgPath msgParams cancellable (itemMenu items') - $ \(MenuResult (idx, item)) -> do - character . inventory . backpack %= removeVectorIndex idx - cb $ MenuResult item + items' -> menu msgPath msgParams cancellable (itemMenu items') cb where - itemMenu = mkMenuItems . imap itemMenuItem - itemMenuItem idx extraInfoItem = + itemMenu = mkMenuItems . map itemMenuItem + itemMenuItem extraInfoItem = let item = extraInfo # extraInfoItem in ( entityMenuChar item - , MenuOption (description item) (idx, extraInfoItem)) + , MenuOption (description item) extraInfoItem) +-- | Prompt with an item to select out of the inventory and call callback with +-- it selectItemFromInventory_ :: forall item. [Text] -- ^ Menu message @@ -446,6 +454,38 @@ selectItemFromInventory_ -> AppM () selectItemFromInventory_ msgPath = selectItemFromInventory msgPath () +-- | Prompt with an item to select out of the inventory, remove it from the +-- inventory, and call callback with it +takeItemFromInventory + :: forall item params. + (ToJSON params) + => [Text] -- ^ Menu message + -> params -- ^ Menu message params + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu item) -> AppM ()) + -> AppM () +takeItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = + selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty + $ \(MenuResult item) -> do + character . inventory . backpack %= filter (/= (item ^. re extraInfo)) + cb $ MenuResult item + +takeItemFromInventory_ + :: forall item. + [Text] -- ^ Menu message + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu item) -> AppM ()) + -> AppM () +takeItemFromInventory_ msgPath = takeItemFromInventory msgPath () + -- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) -- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity diff --git a/users/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs index 1d0014d78792..30359c6c6407 100644 --- a/users/grfn/xanthous/src/Xanthous/Command.hs +++ b/users/grfn/xanthous/src/Xanthous/Command.hs @@ -24,6 +24,7 @@ data Command | Save | Read | ShowInventory + | DescribeInventory | Wield | GoUp | GoDown @@ -50,6 +51,7 @@ commandFromKey (KChar 'e') [] = Just Eat commandFromKey (KChar 'S') [] = Just Save commandFromKey (KChar 'r') [] = Just Read commandFromKey (KChar 'i') [] = Just ShowInventory +commandFromKey (KChar 'I') [] = Just DescribeInventory commandFromKey (KChar 'w') [] = Just Wield commandFromKey (KChar '<') [] = Just GoUp commandFromKey (KChar '>') [] = Just GoDown diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs index ba6f98558ad8..77b0f8f8be71 100644 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ b/users/grfn/xanthous/src/Xanthous/Data.hs @@ -11,6 +11,7 @@ -------------------------------------------------------------------------------- -- | Common data types for Xanthous -------------------------------------------------------------------------------- +{-# LANGUAGE AllowAmbiguousTypes #-} module Xanthous.Data ( Opposite(..) @@ -60,6 +61,8 @@ module Xanthous.Data , Cubic(..) , Grams , Meters + , Unit(..) + , UnitSymbol(..) -- * , Dimensions'(..) @@ -114,13 +117,14 @@ import Data.Array.IArray import Data.Aeson.Generic.DerivingVia import Data.Aeson ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) +import Data.Random (Distribution) +import Data.Coerce +import Data.Proxy (Proxy(Proxy)) -------------------------------------------------------------------------------- import Xanthous.Util (EqEqProp(..), EqProp, between) import Xanthous.Util.QuickCheck (GenericArbitrary(..)) import Xanthous.Orphans () import Xanthous.Util.Graphics -import Data.Random (Distribution) -import Data.Coerce -------------------------------------------------------------------------------- -- | opposite ∘ opposite ≡ id @@ -147,6 +151,18 @@ instance Integral a => Scalar (ScalarIntegral a) where deriving via (ScalarIntegral Integer) instance Scalar Integer deriving via (ScalarIntegral Word) instance Scalar Word +-- | Units of measure +class Unit a where + unitSuffix :: Text +type UnitSymbol :: Symbol -> Type -> Type +newtype UnitSymbol suffix a = UnitSymbol a +instance KnownSymbol suffix => Unit (UnitSymbol suffix a) where + unitSuffix = pack $ symbolVal @suffix Proxy + +newtype ShowUnitSuffix a b = ShowUnitSuffix a +instance (Show b, Unit a, Coercible a b) => Show (ShowUnitSuffix a b) where + show a = show (coerce @_ @b a) <> " " <> unpack (unitSuffix @a) + -------------------------------------------------------------------------------- data Position' a where @@ -494,17 +510,21 @@ rotations orig@(Neighbors tl t tr l r bl b br) = V4 -------------------------------------------------------------------------------- newtype Per a b = Rate Double - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double deriving (Semigroup, Monoid) via Product Double + deriving Show via ShowUnitSuffix (Per a b) Double deriving via Double instance ( Distribution d Double , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) ) => Distribution d (Per a b) +instance (Unit a, Unit b) => Unit (a `Per` b) where + unitSuffix = unitSuffix @a <> "/" <> unitSuffix @b + invertRate :: a `Per` b -> b `Per` a invertRate (Rate p) = Rate $ 1 / p @@ -531,42 +551,51 @@ instance forall a. (Scalar a) => MulUnit (Square a) a where x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y' newtype Square a = Square a - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON , Scalar ) via a - + deriving Show via ShowUnitSuffix (Square a) a deriving via (a :: Type) instance ( Distribution d a , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) ) => Distribution d (Square a) +instance Unit a => Unit (Square a) where + unitSuffix = unitSuffix @a <> "²" + newtype Cubic a = Cubic a - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON , Scalar ) via a - + deriving Show via ShowUnitSuffix (Cubic a) a deriving via (a :: Type) instance ( Distribution d a , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) ) => Distribution d (Cubic a) +instance Unit a => Unit (Cubic a) where + unitSuffix = unitSuffix @a <> "³" + + -------------------------------------------------------------------------------- newtype Ticks = Ticks Word - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word deriving (Semigroup, Monoid) via (Sum Word) deriving Scalar via ScalarIntegral Ticks deriving Arbitrary via GenericArbitrary Ticks + deriving Unit via UnitSymbol "ticks" Ticks + deriving Show via ShowUnitSuffix Ticks Word deriving via Word instance ( Distribution d Word , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) @@ -574,11 +603,13 @@ deriving via Word => Distribution d Ticks newtype Tiles = Tiles Double - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double deriving (Semigroup, Monoid) via (Sum Double) deriving Arbitrary via GenericArbitrary Tiles + deriving Unit via UnitSymbol "m" Tiles + deriving Show via ShowUnitSuffix Tiles Double deriving via Double instance ( Distribution d Double , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) @@ -594,29 +625,31 @@ timesTiles = (|*|) -------------------------------------------------------------------------------- newtype Hitpoints = Hitpoints Word - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word deriving (Semigroup, Monoid) via Sum Word + deriving Unit via UnitSymbol "hp" Hitpoints + deriving Show via ShowUnitSuffix Hitpoints Word -------------------------------------------------------------------------------- -- | Grams, the fundamental measure of weight in Xanthous. newtype Grams = Grams Double - deriving stock (Show, Eq, Generic) + deriving stock (Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat , RealFrac, Scalar, ToJSON, FromJSON ) via Double deriving (Semigroup, Monoid) via Sum Double + deriving Unit via UnitSymbol "g" Grams + deriving Show via ShowUnitSuffix Grams Double -- | Every tile is 1 meter type Meters = Tiles - - -------------------------------------------------------------------------------- data Box a = Box diff --git a/users/grfn/xanthous/src/Xanthous/Data/App.hs b/users/grfn/xanthous/src/Xanthous/Data/App.hs index 0361d2a59ed5..a2cfcb8001cb 100644 --- a/users/grfn/xanthous/src/Xanthous/Data/App.hs +++ b/users/grfn/xanthous/src/Xanthous/Data/App.hs @@ -8,6 +8,7 @@ module Xanthous.Data.App import Xanthous.Prelude -------------------------------------------------------------------------------- import Test.QuickCheck +import Test.QuickCheck.Instances.Text () import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Util.QuickCheck @@ -15,8 +16,13 @@ import Xanthous.Util.QuickCheck -- | Enum for "panels" displayed in the game's UI. data Panel - = InventoryPanel -- ^ A panel displaying the character's inventory - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) + = -- | A panel displaying the character's inventory + InventoryPanel + | -- | A panel describing an item in the inventory in detail + -- + -- The argument is the full description of the item + ItemDescriptionPanel Text + deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) deriving Arbitrary via GenericArbitrary Panel diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs index 6647c42731fa..eadd62569663 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs @@ -10,6 +10,7 @@ module Xanthous.Entities.Item , newWithType , isEdible , weight + , fullDescription ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -61,3 +62,15 @@ isEdible = Raw.isEdible . view itemType -- 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/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs index 14d2dcd22cd5..3f148e8428e8 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs @@ -116,6 +116,7 @@ drawPanel game panel . viewport (Resource.Panel panel) Vertical . case panel of InventoryPanel -> drawInventoryPanel + ItemDescriptionPanel desc -> const $ txtWrap desc $ game drawCharacterInfo :: Character -> Widget ResourceName diff --git a/users/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml index 710c0c17b067..b50dc321fd28 100644 --- a/users/grfn/xanthous/src/Xanthous/messages.yaml +++ b/users/grfn/xanthous/src/Xanthous/messages.yaml @@ -24,7 +24,7 @@ entities: pickUp: menu: What would you like to pick up? - pickUp: You pick up the {{item.itemType.name}} + pickUp: You pick up the {{item.itemType.name}}. nothingToPickUp: "There's nothing here to pick up" cant: @@ -101,6 +101,11 @@ read: nothing: "There's nothing there to read" result: "\"{{message}}\"" +inventory: + describe: + select: Select an item in your inventory to describe + nothing: You aren't carrying anything + wield: nothing: - You aren't carrying anything you can wield |