Updates testing and benchmarking

README.md

@@ -114,6 +114,9 @@ values, that can be much faster.
 
 ## Changelog
 
+version 0.2.1.0 (2024-11-04):
+* Updates the testing and benchmarking framework.
+
 version 0.2.0.0 (2024-11-01):
 * Resolves compiler warnings.
 * Moved from own `Generic` to `GHC.Generically` (needs base 4.17+). If you want

cabal.project.local

@@ -0,0 +1,6 @@
+package *
+  optimization: True
+
+package ons-hs
+  -- profiling: True
+  ghc-options: -Wall -fexpose-all-unfoldings -fspecialise-aggressively

ons-hs.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.2
 name:                ons-hs
-version:             0.2.0.0
+version:             0.2.1.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
@@ -75,16 +75,20 @@ benchmark ons-hs-bench
   hs-source-dirs: test
   main-is: Bench.hs
   build-depends:
-    criterion,
     deepseq,
-    ons-hs
+    ons-hs,
+    tasty-bench
 
 test-suite ons-hs-test
   import: stuff
   type: exitcode-stdio-1.0
   hs-source-dirs: test
   main-is: Spec.hs
-  build-depends: ons-hs
+  build-depends:
+    ons-hs,
+    tasty,
+    tasty-hunit,
+    tasty-quickcheck
 
 source-repository head
   type: git

src/Nominal.hs

@@ -32,8 +32,3 @@ separatedProduct pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> sepProdString
 -- "Left product": A |x B = { (a,b) | C supports a => C supports b }
 leftProduct :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)]
 leftProduct pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> rincProdStrings (index pa oa) (index pb ob)
-
-{-# INLINABLE product #-}
-{-# INLINABLE separatedProduct #-}
-{-# INLINABLE leftProduct #-}
-

src/Nominal/Products.hs

@@ -32,10 +32,8 @@ rincProdStrings = memo2 gen where
     | otherwise = (LT :) <$> rincProdStrings (n-1) m
               <|> (EQ :) <$> rincProdStrings (n-1) (m-1)
 
-{-# INLINABLE prodStrings #-}
+{- NOTE on performance:
-{-# INLINABLE sepProdStrings #-}
+Previously, I had INLINABLE and SPECIALIZE pragmas for all above definitions.
-{-# INLINABLE rincProdStrings #-}
+But with benchmarking, I concluded that they do not make any difference. So
-
+I have removed them. The memoisation does seem to help. So that stays.
-{-# SPECIALIZE prodStrings :: Int -> Int -> [[Ordering]] #-}
+-}
-{-# SPECIALIZE sepProdStrings :: Int -> Int -> [[Ordering]] #-}
-{-# SPECIALIZE rincProdStrings :: Int -> Int -> [[Ordering]] #-}

test/Bench.hs

@@ -1,14 +1,15 @@
-{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-orphans #-}
 
 import Control.DeepSeq
-import Criterion.Main
+import Test.Tasty.Bench
 
-import Nominal
-import Support
-import EquivariantSet
 import EquivariantMap
+import EquivariantSet
+import Nominal
+import OrbitList (repeatRationals, size)
+import Support
 
 instance NFData Rat
 
@@ -16,35 +17,41 @@ instance NFData Rat
 (\/) = EquivariantSet.union
 
 bigset :: (Rat, Rat, Rat, _) -> Bool
-bigset (p, q, r, t) = EquivariantSet.member t s where
+bigset (p, q, r, t) = EquivariantSet.member t s
+ where
   s1 = singleOrbit ((p, p), p) \/ singleOrbit ((p, p), q) \/ singleOrbit ((p, q), r)
   s2 = singleOrbit (p, q) \/ singleOrbit (q, r) \/ singleOrbit (r, p)
-  s  = EquivariantSet.product s1 s2
+  s = EquivariantSet.product s1 s2
 
 bigmap :: (Rat, Rat, _) -> Maybe (Rat, (Rat, Rat))
-bigmap (p, q, t) = EquivariantMap.lookup t m3 where
+bigmap (p, q, t) = EquivariantMap.lookup t m3
+ where
   s = EquivariantSet.product (EquivariantSet.singleOrbit (p, q)) (EquivariantSet.singleOrbit (q, p))
   s2 = EquivariantSet.product s s
   s3 = EquivariantSet.map (\((a, b), (c, d)) -> ((b, a), (d, c))) s2
-  m1 = EquivariantMap.fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s2
+  m1 = EquivariantMap.fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s2
-  m2 = EquivariantMap.fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s3
+  m2 = EquivariantMap.fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s3
   m3 = EquivariantMap.unionWith const m1 m2
 
 main :: IO ()
-main = defaultMain
+main =
-         -- ~ 300 ms
+  defaultMain
-         [ bgroup "bigmap"
+    [ bgroup
-             [ bench "1 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 43)))) -- found
+        "bigmap"
-             , bench "2 n" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 65)))) -- not found
+        [ bench "1 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 43)))) -- found
-             , bench "3 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 100), (Rat 90, Rat 20)), ((Rat 30, Rat 80), (Rat 70, Rat 65)))) -- found
+        , bench "2 n" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 65)))) -- not found
-             , bench "4 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 100), (Rat 100, Rat 1)), ((Rat 1, Rat 100), (Rat 100, Rat 1)))) -- found
+        , bench "3 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 100), (Rat 90, Rat 20)), ((Rat 30, Rat 80), (Rat 70, Rat 65)))) -- found
-             , bench "5 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 100, Rat 1), (Rat 1, Rat 100)), ((Rat 200, Rat 2), (Rat 2, Rat 200)))) -- found
+        , bench "4 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 100), (Rat 100, Rat 1)), ((Rat 1, Rat 100), (Rat 100, Rat 1)))) -- found
-             ]
+        , bench "5 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 100, Rat 1), (Rat 1, Rat 100)), ((Rat 200, Rat 2), (Rat 2, Rat 200)))) -- found
-         -- ~ 13 us
+        ]
-         , bgroup "bigset"
+    , bgroup
-             [ bench "1 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2) )) -- found
+        "bigset"
-             , bench "2 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2) )) -- found
+        [ bench "1 y" $ nf bigset (Rat 1, Rat 2, Rat 3, (((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2))) -- found
-             , bench "3 n" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2) )) -- not found
+        , bench "2 y" $ nf bigset (Rat 1, Rat 2, Rat 3, (((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2))) -- found
-             , bench "4 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4) )) -- found
+        , bench "3 n" $ nf bigset (Rat 1, Rat 2, Rat 3, (((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2))) -- not found
-             ]
+        , bench "4 y" $ nf bigset (Rat 1, Rat 2, Rat 3, (((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4))) -- found
-         ]
+        ]
+    , bgroup
+        "counting orbits"
+        [bench (show i) $ nf (sum . OrbitList.size . repeatRationals) i | i <- [1 .. 7]]
+    ]

test/Spec.hs

@@ -1,25 +1,27 @@
 {-# LANGUAGE PartialTypeSignatures #-}
-{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-orphans #-}
-
--- TODO: QuickCheck instead of these unit tests
-
-import GHC.Stack
 
 import Data.Maybe (isJust, isNothing)
-import Prelude (id, const, not, ($), error, return, Bool(..), IO(..), print, (>>=))
+import Test.Tasty
-import qualified Prelude as P -- hide stuff
+import Test.Tasty.HUnit hiding (assert)
+import Test.Tasty.QuickCheck as QC
+import Prelude (Bool (..), Eq (..), IO, Int, const, id, length, not, show, (!!), ($), (<$>))
 
-import Support (Rat(..))
+import EquivariantMap (fromSet, lookup, unionWith)
-import EquivariantSet (product, member, singleOrbit, union, map, isSubsetOf)
+import EquivariantSet (isSubsetOf, map, member, product, singleOrbit, union)
-import EquivariantMap (unionWith, lookup, fromSet)
+import Nominal (Nominal (..))
+import OrbitList (repeatRationals, size)
+import Support (Rat (..))
 
-assert :: (a -> Bool) -> a -> IO ()
+assert :: HasCallStack => (a -> Bool) -> a -> IO ()
-assert f x = case f x of
+assert f x = assertBool "" (f x)
-  True -> return ()
-  False -> whoCreated x >>= print
 
 main :: IO ()
-main = do
+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))
@@ -39,12 +41,12 @@ main = do
   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 (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s2
+  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 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 (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s3
+  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 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
@@ -55,14 +57,32 @@ main = do
   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 s1 = singleOrbit ((p, p), p) `union` singleOrbit ((p, p), q) `union` singleOrbit ((p, q), r)
+  let s4 = singleOrbit ((p, p), p) `union` singleOrbit ((p, p), q) `union` singleOrbit ((p, q), r)
-  let s2 = singleOrbit (p, q) `union` singleOrbit (q, r) `union` singleOrbit (r, p)
+  let s5 = singleOrbit (p, q) `union` singleOrbit (q, r) `union` singleOrbit (r, p)
-  assert id  $ s2 `isSubsetOf` product (singleOrbit p) (singleOrbit p)
+  assert id $ s5 `isSubsetOf` product (singleOrbit p) (singleOrbit p)
-  assert not $ product (singleOrbit p) (singleOrbit p) `isSubsetOf` s2
+  assert not $ product (singleOrbit p) (singleOrbit p) `isSubsetOf` s5
 
-  let s  = product s1 s2
+  let s6 = product s4 s5
-  assert id  $ member ( ((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2) ) s
+  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) ) s
+  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) ) s
+  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) ) s
+  assert id $ member (((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4)) s6
 
+
+-- 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]]
+
+-- 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 = 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