diff options
Diffstat (limited to 'src/Xanthous')
| -rw-r--r-- | src/Xanthous/App.hs | 74 | ||||
| -rw-r--r-- | src/Xanthous/Command.hs | 2 | ||||
| -rw-r--r-- | src/Xanthous/Data/EntityMap.hs | 20 | ||||
| -rw-r--r-- | src/Xanthous/Data/VectorBag.hs | 94 | ||||
| -rw-r--r-- | src/Xanthous/Entities/Character.hs | 7 | ||||
| -rw-r--r-- | src/Xanthous/Game/State.hs | 3 | ||||
| -rw-r--r-- | src/Xanthous/messages.yaml | 11 |
7 files changed, 189 insertions, 22 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 6b1c2413c62e..353ab28e161a 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -49,7 +49,7 @@ import Xanthous.Entities.Environment (Door, open, locked, GroundMessage(..)) import Xanthous.Entities.RawTypes ( edible, eatMessage, hitpointsHealed - , wieldable, attackMessage + , attackMessage ) import Xanthous.Generators import qualified Xanthous.Generators.CaveAutomata as CaveAutomata @@ -158,6 +158,15 @@ handleCommand PickUp = do say ["pickUp", "pickUp"] $ object [ "item" A..= item ] stepGameBy 100 -- TODO +handleCommand Drop = do + selectItemFromInventory_ ["drop", "menu"] Cancellable id + (say_ ["drop", "nothing"]) + $ \(MenuResult item) -> do + charPos <- use characterPosition + entities . EntityMap.atPosition charPos %= (SomeEntity item <|) + say ["drop", "dropped"] $ object [ "item" A..= item ] + continue + handleCommand PreviousMessage = do messageHistory %= previousMessage continue @@ -236,22 +245,12 @@ handleCommand Read = do handleCommand ShowInventory = showPanel InventoryPanel >> continue handleCommand Wield = do - uses (character . inventory . backpack) - (V.mapMaybe (\item -> - WieldedItem item <$> item ^. Item.itemType . wieldable)) - >>= \case - Empty -> say_ ["wield", "nothing"] - wieldables -> - menu_ ["wield", "menu"] Cancellable (wieldableMenu wieldables) - $ \(MenuResult (idx, item)) -> do - character . inventory . backpack %= removeVectorIndex idx - character . inventory . wielded .= inRightHand item - say ["wield", "wielded"] item + selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem + (say_ ["wield", "nothing"]) + $ \(MenuResult item) -> do + character . inventory . wielded .= inRightHand item + say ["wield", "wielded"] item continue - where - wieldableMenu = mkMenuItems . imap wieldableMenuItem - wieldableMenuItem idx wi@(WieldedItem item _) = - (entityMenuChar item, MenuOption (description item) (idx, wi)) handleCommand Save = do -- TODO default save locations / config file? @@ -469,6 +468,49 @@ 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 +selectItemFromInventory + :: 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 () +selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = + uses (character . inventory . backpack) + (V.mapMaybe $ preview extraInfo) + >>= \case + Empty -> onEmpty + items' -> + menu msgPath msgParams cancellable (itemMenu items') + $ \(MenuResult (idx, item)) -> do + character . inventory . backpack %= removeVectorIndex idx + cb $ MenuResult item + where + itemMenu = mkMenuItems . imap itemMenuItem + itemMenuItem idx extraInfoItem = + let item = extraInfo # extraInfoItem + in ( entityMenuChar item + , MenuOption (description item) (idx, extraInfoItem)) + +selectItemFromInventory_ + :: 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 () +selectItemFromInventory_ msgPath = selectItemFromInventory msgPath () + -- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) -- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index 3547bdf09ab0..d5bb5cd9eee2 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -14,6 +14,7 @@ data Command | Move Direction | PreviousMessage | PickUp + | Drop | Open | Wait | Eat @@ -32,6 +33,7 @@ commandFromKey (KChar '.') [] = Just Wait commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage commandFromKey (KChar ',') [] = Just PickUp +commandFromKey (KChar 'd') [] = Just Drop commandFromKey (KChar 'o') [] = Just Open commandFromKey (KChar ';') [] = Just Look commandFromKey (KChar 'e') [] = Just Eat diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index 9ea952c054fb..619b4b05c4b9 100644 --- a/src/Xanthous/Data/EntityMap.hs +++ b/src/Xanthous/Data/EntityMap.hs @@ -39,6 +39,7 @@ import Xanthous.Data , Neighbors(..) , neighborPositions ) +import Xanthous.Data.VectorBag import Xanthous.Orphans () import Xanthous.Util (EqEqProp(..)) -------------------------------------------------------------------------------- @@ -184,16 +185,25 @@ insertAtReturningID pos e em = insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a insertAt pos e = snd . insertAtReturningID pos e -atPosition :: forall a. Position -> Lens' (EntityMap a) (Vector a) +atPosition :: forall a. Position -> Lens' (EntityMap a) (VectorBag a) atPosition pos = lens getter setter where getter em = - let eids :: Vector EntityID - eids = maybe mempty (toVector . toNullable) + let eids :: VectorBag EntityID + eids = maybe mempty (VectorBag . toVector . toNullable) $ em ^. byPosition . at pos in getEIDAssume em <$> eids setter em Empty = em & byPosition . at pos .~ Nothing - setter em entities = alaf Endo foldMap (insertAt pos) entities em + setter em entities = + alaf Endo foldMap (insertAt pos) entities + . removeAllAt pos + $ em + where + removeAllAt p e = + let eids = e ^.. byPosition . at p >>= toList >>= toList + in alaf Endo foldMap (\eid -> byID . at eid .~ Nothing) eids + . (byPosition . at pos .~ Nothing) + $ e getEIDAssume :: EntityMap a -> EntityID -> a getEIDAssume em eid = fromMaybe byIDInvariantError @@ -237,7 +247,7 @@ lookup eid = fmap (view positioned) . lookupWithPosition eid -- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b) -- positionedEntities = byID . itraversed -neighbors :: Position -> EntityMap a -> Neighbors (Vector a) +neighbors :: Position -> EntityMap a -> Neighbors (VectorBag a) neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Data/VectorBag.hs b/src/Xanthous/Data/VectorBag.hs new file mode 100644 index 000000000000..bd9af369e01c --- /dev/null +++ b/src/Xanthous/Data/VectorBag.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.VectorBag + (VectorBag(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Data.Aeson +import qualified Data.Vector as V +import Test.QuickCheck +import Test.QuickCheck.Instances.Vector () +-------------------------------------------------------------------------------- + +-- | Acts exactly like a Vector, except ignores order when testing for equality +newtype VectorBag a = VectorBag (Vector a) + deriving stock + ( Traversable + , Generic + ) + deriving newtype + ( Show + , Read + , Foldable + , FromJSON + , FromJSON1 + , ToJSON + , Reversing + , Applicative + , Functor + , Monad + , Monoid + , Semigroup + , Arbitrary + , CoArbitrary + ) +makeWrapped ''VectorBag + +instance Function a => Function (VectorBag a) where + function = functionMap (\(VectorBag v) -> v) VectorBag + +type instance Element (VectorBag a) = a +deriving via (Vector a) instance MonoFoldable (VectorBag a) +deriving via (Vector a) instance GrowingAppend (VectorBag a) +deriving via (Vector a) instance SemiSequence (VectorBag a) +deriving via (Vector a) instance MonoPointed (VectorBag a) +deriving via (Vector a) instance MonoFunctor (VectorBag a) + +instance Cons (VectorBag a) (VectorBag b) a b where + _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) -> + if V.null v + then Left (VectorBag mempty) + else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v) + +instance AsEmpty (VectorBag a) where + _Empty = prism' (const $ VectorBag Empty) $ \case + (VectorBag Empty) -> Just () + _ -> Nothing + +{- + TODO: + , Ixed + , FoldableWithIndex + , FunctorWithIndex + , TraversableWithIndex + , Snoc + , Each +-} + +instance Ord a => Eq (VectorBag a) where + (==) = (==) `on` (view _Wrapped . sort) + +instance Ord a => Ord (VectorBag a) where + compare = compare `on` (view _Wrapped . sort) + +instance MonoTraversable (VectorBag a) where + otraverse f (VectorBag v) = VectorBag <$> otraverse f v + +instance IsSequence (VectorBag a) where + fromList = VectorBag . fromList + break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v + span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v + dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v + takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v + splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v + unsafeSplitAt idx (VectorBag v) = + bimap VectorBag VectorBag $ unsafeSplitAt idx v + take n (VectorBag v) = VectorBag $ take n v + unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v + drop n (VectorBag v) = VectorBag $ drop n v + unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v + partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 955c94fc77c4..43d4f8a52942 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -27,6 +27,7 @@ module Xanthous.Entities.Character , WieldedItem(..) , wieldedItem , wieldableItem + , asWieldedItem -- * , mkCharacter @@ -68,6 +69,12 @@ data WieldedItem = WieldedItem 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) diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 3b401d366d10..d8a0f0b32077 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -80,6 +80,7 @@ import Xanthous.Util (KnownBool(..)) import Xanthous.Data import Xanthous.Data.EntityMap (EntityMap, EntityID) import Xanthous.Data.EntityChar +import Xanthous.Data.VectorBag import Xanthous.Orphans () import Xanthous.Game.Prompt import Xanthous.Resource @@ -185,7 +186,7 @@ type AppM = AppT (EventM Name) -------------------------------------------------------------------------------- class Draw a where - drawWithNeighbors :: Neighbors (Vector SomeEntity) -> a -> Widget n + drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n drawWithNeighbors = const draw draw :: a -> Widget n diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 3967a0cba067..9e59f4fb0fa8 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -76,6 +76,17 @@ wield: # TODO: use actual hands wielded : You wield the {{wieldedItem.itemType.name}} in your right hand. +drop: + nothing: You aren't carrying anything + menu: What would you like to drop? + # TODO: use actual hands + dropped: + - You drop the {{item.itemType.name}}. + - You drop the {{item.itemType.name}} on the ground. + - You put the {{item.itemType.name}} on the ground. + - You take the {{item.itemType.name}} out of your backpack and put it on the ground. + - You take the {{item.itemType.name}} out of your backpack and drop it on the ground. + ### |