From 9575a62e566cd5f0b91f094d88c6fdeaefaf3abb Mon Sep 17 00:00:00 2001 From: Joshua Moerman Date: Mon, 4 Nov 2024 15:53:23 +0100 Subject: [PATCH] Updates testing and benchmarking --- README.md | 3 ++ cabal.project.local | 6 ++++ ons-hs.cabal | 12 ++++--- src/Nominal.hs | 5 --- src/Nominal/Products.hs | 14 ++++---- test/Bench.hs | 63 +++++++++++++++++++--------------- test/Spec.hs | 76 ++++++++++++++++++++++++++--------------- 7 files changed, 106 insertions(+), 73 deletions(-) create mode 100644 cabal.project.local diff --git a/README.md b/README.md index b484e08..eb3c718 100644 --- a/README.md +++ b/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 diff --git a/cabal.project.local b/cabal.project.local new file mode 100644 index 0000000..f03aafb --- /dev/null +++ b/cabal.project.local @@ -0,0 +1,6 @@ +package * + optimization: True + +package ons-hs + -- profiling: True + ghc-options: -Wall -fexpose-all-unfoldings -fspecialise-aggressively diff --git a/ons-hs.cabal b/ons-hs.cabal index bc2a49d..d5532ba 100644 --- a/ons-hs.cabal +++ b/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 diff --git a/src/Nominal.hs b/src/Nominal.hs index 19839e7..35f2bbd 100644 --- a/src/Nominal.hs +++ b/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 #-} - diff --git a/src/Nominal/Products.hs b/src/Nominal/Products.hs index 35a0566..3af3070 100644 --- a/src/Nominal/Products.hs +++ b/src/Nominal/Products.hs @@ -27,15 +27,13 @@ rincProdStrings = memo2 gen where gen n 0 = pure $ replicate n LT gen 0 _ = empty gen 1 1 = pure [EQ] - gen n m + gen n m | n < m = empty | otherwise = (LT :) <$> rincProdStrings (n-1) m <|> (EQ :) <$> rincProdStrings (n-1) (m-1) -{-# INLINABLE prodStrings #-} -{-# INLINABLE sepProdStrings #-} -{-# INLINABLE rincProdStrings #-} - -{-# SPECIALIZE prodStrings :: Int -> Int -> [[Ordering]] #-} -{-# SPECIALIZE sepProdStrings :: Int -> Int -> [[Ordering]] #-} -{-# SPECIALIZE rincProdStrings :: Int -> Int -> [[Ordering]] #-} +{- NOTE on performance: +Previously, I had INLINABLE and SPECIALIZE pragmas for all above definitions. +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. +-} diff --git a/test/Bench.hs b/test/Bench.hs index d3c2ed0..96264a5 100644 --- a/test/Bench.hs +++ b/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 - m2 = EquivariantMap.fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s3 + m1 = EquivariantMap.fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s2 + m2 = EquivariantMap.fromSet (\(((_, b), (_, d)), (_, (_, h))) -> (b, (d, h))) s3 m3 = EquivariantMap.unionWith const m1 m2 main :: IO () -main = defaultMain - -- ~ 300 ms - [ bgroup "bigmap" - [ 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 "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 "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 "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" - [ bench "1 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2) )) -- found - , bench "2 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 37, Rat 37), Rat 42), (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 "4 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4) )) -- found - ] - ] +main = + defaultMain + [ bgroup + "bigmap" + [ 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 "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 "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 "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 + ] + , bgroup + "bigset" + [ bench "1 y" $ nf bigset (Rat 1, Rat 2, Rat 3, (((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2))) -- found + , bench "2 y" $ nf bigset (Rat 1, Rat 2, Rat 3, (((Rat 37, Rat 37), Rat 42), (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 "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]] + ] diff --git a/test/Spec.hs b/test/Spec.hs index 0f100bb..1f72889 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,25 +1,27 @@ {-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} - --- TODO: QuickCheck instead of these unit tests - -import GHC.Stack +{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-orphans #-} import Data.Maybe (isJust, isNothing) -import Prelude (id, const, not, ($), error, return, Bool(..), IO(..), print, (>>=)) -import qualified Prelude as P -- hide stuff +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 Support (Rat(..)) -import EquivariantSet (product, member, singleOrbit, union, map, isSubsetOf) -import EquivariantMap (unionWith, lookup, fromSet) +import EquivariantMap (fromSet, lookup, unionWith) +import EquivariantSet (isSubsetOf, map, member, product, singleOrbit, union) +import Nominal (Nominal (..)) +import OrbitList (repeatRationals, size) +import Support (Rat (..)) -assert :: (a -> Bool) -> a -> IO () -assert f x = case f x of - True -> return () - False -> whoCreated x >>= print +assert :: HasCallStack => (a -> Bool) -> a -> IO () +assert f x = assertBool "" (f x) 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 - assert isJust $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 3, Rat 2))) m1 + 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 (\(((a, b), (c, d)), ((e, f), (g, 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 + 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 @@ -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 s2 = singleOrbit (p, q) `union` singleOrbit (q, r) `union` singleOrbit (r, p) - assert id $ s2 `isSubsetOf` product (singleOrbit p) (singleOrbit p) - assert not $ product (singleOrbit p) (singleOrbit p) `isSubsetOf` s2 + 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 s = product s1 s2 - assert id $ member ( ((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2) ) s - assert id $ member ( ((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2) ) s - assert not $ member ( ((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2) ) s - assert id $ member ( ((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4) ) s + 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 + +-- 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