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).

2 files changed, 109 insertions, 5 deletions

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