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>

4 files changed, 164 insertions, 0 deletions

diff --git a/users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs
new file mode 100644
index 000000000000..734cce1efbbe
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.CharacterSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Character
+import           Xanthous.Util (endoTimes)
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.CharacterSpec"
+  [ testGroup "Knuckles"
+    [ testBatch $ monoid @Knuckles mempty
+    , testGroup "damageKnuckles"
+      [ testCase "caps at 5" $
+          let knuckles' = endoTimes 6 damageKnuckles mempty
+          in _knuckleDamage knuckles' @?= 5
+      ]
+    ]
+  ]
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)
+      ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs
new file mode 100644
index 000000000000..e23f7faba3a6
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypesSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Data.Interval (Extended(..), (<=..<=))
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.RawTypesSpec"
+  [ testGroup "CreatureGenerateParams"
+    [ testGroup "Ord laws"
+      [ testProperty "comparability" $ \(a :: CreatureGenerateParams) b ->
+          a <= b || b <= a
+      , testProperty "transitivity" $ \(a :: CreatureGenerateParams) b c ->
+          a <= b && b <= c ==> a <= c
+      , testProperty "reflexivity" $ \(a :: CreatureGenerateParams) ->
+          a <= a
+      , testProperty "antisymmetry" $ \(a :: CreatureGenerateParams) b ->
+          (a <= b && b <= a) == (a == b)
+      ]
+    , testGroup "canGenerate" $
+      let makeParams minB maxB =
+            let _levelRange = maybe NegInf Finite minB <=..<= maybe PosInf Finite maxB
+                _equippedItem = Nothing
+            in CreatureGenerateParams {..}
+      in
+        [ testProperty "no bounds" $ \level ->
+            let gps = makeParams Nothing Nothing
+            in canGenerate level gps
+        , testProperty "min bound" $ \level minB ->
+            let gps = makeParams (Just minB) Nothing
+            in canGenerate level gps === (level >= minB)
+        , testProperty "max bound" $ \level maxB ->
+            let gps = makeParams Nothing (Just maxB)
+            in canGenerate level gps === (level <= maxB)
+        ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs
new file mode 100644
index 000000000000..b6c80be51be7
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs
@@ -0,0 +1,30 @@
+-- |
+
+module Xanthous.Entities.RawsSpec (main, test) where
+
+import Test.Prelude
+import Xanthous.Entities.Raws
+import Xanthous.Entities.RawTypes
+       (_Creature, entityName, generateParams, HasEquippedItem (equippedItem))
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.Raws"
+  [ testGroup "raws"
+    [ testCase "are all valid" $ raws `deepseq` pure ()
+    , testCase "all CreatureEquippedItems reference existent entity names" $
+      let notFound
+            = raws
+              ^.. folded
+              . _Creature
+              . generateParams
+              . _Just
+              . equippedItem
+              . _Just
+              . entityName
+              . filtered (isNothing . raw)
+      in null notFound @? ("Some entities weren't found: " <> show notFound)
+    ]
+  ]