Add a drop command

Add a drop command, bound to 'd', which prompts the character for an
item in their inventory, removes it from the inventory, and places it on
the ground. Along the way I had to fix a bug in the
`EntityMap.atPosition` lens, which was always appending to the existing
entities at the position on set, without removing the entities that were
already there - the rabbit hole of quickchecking the lens laws here also
lead to replacing the target of this lens with a newtype called
`VectorBag`, which ignores order (since the entitymap makes no
guarantees about order of entities at a given position).

package.yaml

@@ -41,7 +41,6 @@ dependencies:
 - MonadRandom
 - mtl
 - optparse-applicative
-- parallel
 - random
 - random-fu
 - random-extras

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)
+  selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
-       (V.mapMaybe (\item ->
+    (say_ ["wield", "nothing"])
-                      WieldedItem item <$> item ^. Item.itemType . wieldable))
+    $ \(MenuResult item) -> do
-    >>= \case
+      character . inventory . wielded .= inRightHand item
-      Empty -> say_ ["wield", "nothing"]
+      say ["wield", "wielded"] item
-      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
   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
 

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

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
+      let eids :: VectorBag EntityID
-          eids = maybe mempty (toVector . toNullable)
+          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
 
 --------------------------------------------------------------------------------

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

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)

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

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.
+
 
 ###
 

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
+    ]
   ]

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