diff options
Diffstat (limited to 'users/aspen/xanthous/test/Xanthous/Entities')
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 0000000000..734cce1efb --- /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 0000000000..a6f8401cf7 --- /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 0000000000..e23f7faba3 --- /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 0000000000..b6c80be51b --- /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) + ] + ] |