chore(users): grfn -> aspen r/7511

Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>

1 files changed, 65 insertions, 0 deletions

diff --git a/users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs
new file mode 100644
index 000000000000..a6f8401cf75b
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs
@@ -0,0 +1,65 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.CommonSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+import           Data.Vector.Lens (toVectorOf)
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Common
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+newtype OneHand = OneHand Hand
+  deriving stock Show
+
+instance Arbitrary OneHand where
+  arbitrary = OneHand <$> elements [LeftHand, RightHand]
+
+otherHand :: Hand -> Hand
+otherHand LeftHand = RightHand
+otherHand RightHand = LeftHand
+otherHand BothHands = error "OtherHand BothHands"
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.CommonSpec"
+  [ testGroup "Inventory"
+    [ testProperty "items === itemsWithPosition . _2" $ \inv ->
+        inv ^.. items === inv ^.. itemsWithPosition . _2
+    , testGroup "removeItemFromPosition" $
+      let rewield w inv =
+            let (old, inv') = inv & wielded <<.~ w
+            in inv' & backpack <>~ toVectorOf (wieldedItems . wieldedItem) old
+      in [ (Backpack, \item -> backpack %~ (item ^. wieldedItem <|))
+         , (InHand LeftHand, rewield . inLeftHand)
+         , (InHand RightHand, rewield . inRightHand)
+         , (InHand BothHands, rewield . review doubleHanded)
+         ] <&> \(pos, addItem) ->
+           testProperty (show pos) $ \inv item ->
+             let inv' = addItem item inv
+                 inv'' = removeItemFromPosition pos (item ^. wieldedItem) inv'
+             in inv'' ^.. items === inv ^.. items
+    ]
+  , testGroup "Wielded items"
+    [ testGroup "wieldInHand"
+      [ testProperty "puts the item in the hand" $ \w hand item ->
+          let (_, w') = wieldInHand hand item w
+          in itemsInHand hand w' === [item]
+      , testProperty "returns items in both hands when wielding double-handed"
+        $ \lh rh newItem ->
+          let w = Hands (Just lh) (Just rh)
+              (prevItems, _) = wieldInHand BothHands newItem w
+          in prevItems === [lh, rh]
+      , testProperty "wielding in one hand leaves the item in the other hand"
+        $ \(OneHand h) existingItem newItem ->
+          let (_, w) = wieldInHand h existingItem nothingWielded
+              (prevItems, w') = wieldInHand (otherHand h) newItem w
+          in   prevItems === []
+          .&&. sort (w' ^.. wieldedItems) === sort [existingItem, newItem]
+      , testProperty "always leaves the same items overall" $ \w hand item ->
+          let (prevItems, w') = wieldInHand hand item w
+          in  sort (prevItems <> (w' ^.. wieldedItems))
+          === sort (item : w ^.. wieldedItems)
+      ]
+    ]
+  ]