diff options
| -rw-r--r-- | package.yaml | 1 | ||||
| -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 | ||||
| -rw-r--r-- | test/Xanthous/Data/EntityMapSpec.hs | 5 | ||||
| -rw-r--r-- | xanthous.cabal | 7 |
10 files changed, 197 insertions, 27 deletions
diff --git a/package.yaml b/package.yaml index f982a2339708..b4c53308078e 100644 --- a/package.yaml +++ b/package.yaml @@ -41,7 +41,6 @@ dependencies: - MonadRandom - mtl - optparse-applicative -- parallel - random - random-fu - random-extras 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. + ### diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs index 88e0d0d7712c..8317f5f51f8b 100644 --- a/test/Xanthous/Data/EntityMapSpec.hs +++ b/test/Xanthous/Data/EntityMapSpec.hs @@ -3,6 +3,7 @@ module Xanthous.Data.EntityMapSpec where -------------------------------------------------------------------------------- import Test.Prelude +import Control.Lens.Properties -------------------------------------------------------------------------------- import qualified Data.Aeson as JSON -------------------------------------------------------------------------------- @@ -45,4 +46,8 @@ test = localOption (QuickCheckTests 20) let Just em' = JSON.decode $ JSON.encode em in toEIDsAndPositioned em' === toEIDsAndPositioned em ] + + , testGroup "atPosition" + [ testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos + ] ] diff --git a/xanthous.cabal b/xanthous.cabal index 7198e9ab9d9a..e70a7391f3c1 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0476b4307dfceb20b9358ca2e6f78c753e3e0a4ae60c6faed54528f6a9c0dc5c +-- hash: ae5b84ec168dd61b715e874bcb49579697873b164c43027a776dda725dfdffbf name: xanthous version: 0.1.0.0 @@ -37,6 +37,7 @@ library Xanthous.Data.EntityChar Xanthous.Data.EntityMap Xanthous.Data.EntityMap.Graphics + Xanthous.Data.VectorBag Xanthous.Entities.Character Xanthous.Entities.Creature Xanthous.Entities.Draw.Util @@ -96,7 +97,6 @@ library , megaparsec , mtl , optparse-applicative - , parallel , quickcheck-instances , quickcheck-text , random @@ -125,6 +125,7 @@ executable xanthous Xanthous.Data.EntityChar Xanthous.Data.EntityMap Xanthous.Data.EntityMap.Graphics + Xanthous.Data.VectorBag Xanthous.Entities.Character Xanthous.Entities.Creature Xanthous.Entities.Draw.Util @@ -183,7 +184,6 @@ executable xanthous , megaparsec , mtl , optparse-applicative - , parallel , quickcheck-instances , quickcheck-text , random @@ -248,7 +248,6 @@ test-suite test , megaparsec , mtl , optparse-applicative - , parallel , quickcheck-instances , quickcheck-text , random |