diff --git a/README.md b/README.md index eb3c718..6c3692a 100644 --- a/README.md +++ b/README.md @@ -114,7 +114,7 @@ values, that can be much faster. ## Changelog -version 0.2.1.0 (2024-11-04): +version 0.2.2.0 (2024-11-05): * Updates the testing and benchmarking framework. version 0.2.0.0 (2024-11-01): diff --git a/ons-hs.cabal b/ons-hs.cabal index d5532ba..c2e45ca 100644 --- a/ons-hs.cabal +++ b/ons-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ons-hs -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Implementation of the ONS (Ordered Nominal Sets) library in Haskell description: Nominal sets are structured infinite sets. They have symmetries which make them finitely representable. This library provides basic manipulation of them for the total order symmetry. It includes: products, sums, maps and sets. Can work with custom data types. homepage: https://github.com/Jaxan/ons-hs @@ -84,6 +84,10 @@ test-suite ons-hs-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: + SpecMap, + SpecSet, + SpecUtils build-depends: ons-hs, tasty, diff --git a/test/Spec.hs b/test/Spec.hs index 1f72889..94e7069 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,88 +1,33 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} -import Data.Maybe (isJust, isNothing) import Test.Tasty import Test.Tasty.HUnit hiding (assert) import Test.Tasty.QuickCheck as QC -import Prelude (Bool (..), Eq (..), IO, Int, const, id, length, not, show, (!!), ($), (<$>)) +import Prelude (Eq (..), IO, Int, length, show, (!!), ($), (<>)) -import EquivariantMap (fromSet, lookup, unionWith) -import EquivariantSet (isSubsetOf, map, member, product, singleOrbit, union) import Nominal (Nominal (..)) import OrbitList (repeatRationals, size) import Support (Rat (..)) -assert :: HasCallStack => (a -> Bool) -> a -> IO () -assert f x = assertBool "" (f x) +import SpecMap +import SpecSet +import SpecUtils () main :: IO () -main = defaultMain (testGroup "main" [unitTests, countingTests, qcTests]) - - -unitTests :: _ -unitTests = testCase "Examples" $ do - let p = Rat 1 - let q = Rat 2 - let s = product (singleOrbit (p, q)) (singleOrbit (q, p)) - assert id $ member ((Rat 1, Rat 2), (Rat 5, Rat 4)) s - assert not $ member ((Rat 5, Rat 2), (Rat 5, Rat 4)) s - assert id $ member ((Rat 1, Rat 2), (Rat 2, Rat 1)) s - assert id $ member ((Rat 3, Rat 4), (Rat 2, Rat 1)) s - - let s2 = product s s - assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 2), (Rat 5, Rat 4))) s2 - assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 2), (Rat 5, Rat 1))) s2 - assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 1))) s2 - assert id $ member (((Rat 0, Rat 27), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 1))) s2 - assert not $ member (((Rat 0, Rat 27), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 5))) s2 - - let s3 = map (\((a, b), (c, d)) -> ((b, a), (d, c))) s2 - assert id $ member (((Rat 5, Rat 4), (Rat 1, Rat 2)), ((Rat 5, Rat 4), (Rat 1, Rat 2))) s3 - assert id $ member (((Rat 2, Rat 1), (Rat 4, Rat 5)), ((Rat 2, Rat 1), (Rat 4, Rat 5))) s3 - - let m1 = fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s2 - assert isJust $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 3, Rat 2))) m1 - assert isNothing $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 1, Rat 2))) m1 - - let m2 = fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s3 - assert isJust $ lookup (((Rat 6, Rat 1), (Rat 1, Rat 5)), ((Rat 4, Rat 1), (Rat 1, Rat 3))) m2 - assert isNothing $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 4, Rat 2))) m2 - - let m3 = unionWith const m1 m2 - assert isJust $ lookup (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 43))) m3 - assert isNothing $ lookup (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 65))) m3 - assert isJust $ lookup (((Rat 1, Rat 100), (Rat 90, Rat 20)), ((Rat 30, Rat 80), (Rat 70, Rat 65))) m3 - assert isJust $ lookup (((Rat 1, Rat 100), (Rat 100, Rat 1)), ((Rat 1, Rat 100), (Rat 100, Rat 1))) m3 - assert isJust $ lookup (((Rat 100, Rat 1), (Rat 1, Rat 100)), ((Rat 200, Rat 2), (Rat 2, Rat 200))) m3 - - let r = Rat 3 - let s4 = singleOrbit ((p, p), p) `union` singleOrbit ((p, p), q) `union` singleOrbit ((p, q), r) - let s5 = singleOrbit (p, q) `union` singleOrbit (q, r) `union` singleOrbit (r, p) - assert id $ s5 `isSubsetOf` product (singleOrbit p) (singleOrbit p) - assert not $ product (singleOrbit p) (singleOrbit p) `isSubsetOf` s5 - - let s6 = product s4 s5 - assert id $ member (((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2)) s6 - assert id $ member (((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2)) s6 - assert not $ member (((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2)) s6 - assert id $ member (((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4)) s6 +main = defaultMain allTests +allTests :: TestTree +allTests = testGroup "main" [setTests, mapTests, countingTests, qcTests] -- Verifying that the number of orbits is correct. Up to length 7, because -- length 8 and longer take at least one second. -countingTests :: _ -countingTests = testGroup "Counting" [testCase (show n) $ length (OrbitList.size (repeatRationals n)) @?= (a000670 !! n) | n <- [0..7]] +countingTests :: TestTree +countingTests = testGroup "OrbitList" [testCase ("count " <> show n) $ length (OrbitList.size (repeatRationals n)) @?= (a000670 !! n) | n <- [0 .. 7]] -- A000670: Ordered Bell numbers or Fubini numbers a000670 :: [Int] a000670 = [1, 1, 3, 13, 75, 541, 4683, 47293, 545835, 7087261, 102247563, 1622632573, 28091567595] - -- TODO: Add more quickcheck tests -qcTests :: _ +qcTests :: TestTree qcTests = testGroup "QuickCheck" [QC.testProperty "all atoms in same orbit" $ \p q -> toOrbit (p :: Rat) == toOrbit (q :: Rat)] - -instance Arbitrary Rat where - arbitrary = Rat <$> arbitrary - shrink (Rat p) = Rat <$> shrink p diff --git a/test/SpecMap.hs b/test/SpecMap.hs new file mode 100644 index 0000000..c24da95 --- /dev/null +++ b/test/SpecMap.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module SpecMap (mapTests) where + +import Data.Maybe (isJust, isNothing) +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Prelude (const, ($)) + +import EquivariantMap +import EquivariantSet qualified as EqSet +import Support + +import SpecUtils + +mapTests :: TestTree +mapTests = testGroup "Map" [unitTests] + +unitTests :: TestTree +unitTests = testCase "Examples" $ do + let + p = Rat 1 + q = Rat 2 + s = EqSet.product (EqSet.singleOrbit (p, q)) (EqSet.singleOrbit (q, p)) + s2 = EqSet.product s s + m1 = fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s2 + + assert isJust $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 3, Rat 2))) m1 + assert isNothing $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 1, Rat 2))) m1 + + let + s3 = EqSet.map (\((a, b), (c, d)) -> ((b, a), (d, c))) s2 + m2 = fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s3 + + assert isJust $ lookup (((Rat 6, Rat 1), (Rat 1, Rat 5)), ((Rat 4, Rat 1), (Rat 1, Rat 3))) m2 + assert isNothing $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 4, Rat 2))) m2 + + let m3 = unionWith const m1 m2 + assert isJust $ lookup (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 43))) m3 + assert isNothing $ lookup (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 65))) m3 + assert isJust $ lookup (((Rat 1, Rat 100), (Rat 90, Rat 20)), ((Rat 30, Rat 80), (Rat 70, Rat 65))) m3 + assert isJust $ lookup (((Rat 1, Rat 100), (Rat 100, Rat 1)), ((Rat 1, Rat 100), (Rat 100, Rat 1))) m3 + assert isJust $ lookup (((Rat 100, Rat 1), (Rat 1, Rat 100)), ((Rat 200, Rat 2), (Rat 2, Rat 200))) m3 diff --git a/test/SpecSet.hs b/test/SpecSet.hs new file mode 100644 index 0000000..eaee1c7 --- /dev/null +++ b/test/SpecSet.hs @@ -0,0 +1,50 @@ +module SpecSet (setTests) where + +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Prelude (id, not, ($)) + +import EquivariantSet +import Support (Rat (..)) + +import SpecUtils + +setTests :: TestTree +setTests = testGroup "Set" [unitTests] + +unitTests :: TestTree +unitTests = testCase "Examples" $ do + let + p = Rat 1 + q = Rat 2 + s = product (singleOrbit (p, q)) (singleOrbit (q, p)) + + assert id $ member ((Rat 1, Rat 2), (Rat 5, Rat 4)) s + assert not $ member ((Rat 5, Rat 2), (Rat 5, Rat 4)) s + assert id $ member ((Rat 1, Rat 2), (Rat 2, Rat 1)) s + assert id $ member ((Rat 3, Rat 4), (Rat 2, Rat 1)) s + + let s2 = product s s + assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 2), (Rat 5, Rat 4))) s2 + assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 2), (Rat 5, Rat 1))) s2 + assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 1))) s2 + assert id $ member (((Rat 0, Rat 27), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 1))) s2 + assert not $ member (((Rat 0, Rat 27), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 5))) s2 + + let s3 = map (\((a, b), (c, d)) -> ((b, a), (d, c))) s2 + assert id $ member (((Rat 5, Rat 4), (Rat 1, Rat 2)), ((Rat 5, Rat 4), (Rat 1, Rat 2))) s3 + assert id $ member (((Rat 2, Rat 1), (Rat 4, Rat 5)), ((Rat 2, Rat 1), (Rat 4, Rat 5))) s3 + + let + r = Rat 3 + s4 = singleOrbit ((p, p), p) `union` singleOrbit ((p, p), q) `union` singleOrbit ((p, q), r) + s5 = singleOrbit (p, q) `union` singleOrbit (q, r) `union` singleOrbit (r, p) + + assert id $ s5 `isSubsetOf` product (singleOrbit p) (singleOrbit p) + assert not $ product (singleOrbit p) (singleOrbit p) `isSubsetOf` s5 + + let s6 = product s4 s5 + assert id $ member (((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2)) s6 + assert id $ member (((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2)) s6 + assert not $ member (((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2)) s6 + assert id $ member (((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4)) s6 diff --git a/test/SpecUtils.hs b/test/SpecUtils.hs new file mode 100644 index 0000000..0d95fa8 --- /dev/null +++ b/test/SpecUtils.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SpecUtils where + +import Test.Tasty.HUnit hiding (assert) +import Test.Tasty.QuickCheck as QC + +import Support (Rat (..)) + +assert :: HasCallStack => (a -> Bool) -> a -> IO () +assert f x = assertBool "" (f x) + +instance Arbitrary Rat where + arbitrary = Rat <$> arbitrary + shrink (Rat p) = Rat <$> shrink p