joshua/ons-hs
1
Fork 0
mirror of https://github.com/Jaxan/ons-hs.git synced 2025-04-26 22:27:45 +02:00
Code Issues Releases Activity

Updates testing and benchmarking

Browse source
This commit is contained in:
Joshua Moerman 2024-11-04 15:53:23 +01:00
parent d0540fe073
commit 9575a62e56
7 changed files with 106 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
README.md
View file

@ -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

6
cabal.project.local Normal file
View file

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

12
ons-hs.cabal
View file

@ -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

5
src/Nominal.hs
View file

@ -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 #-}

14
src/Nominal/Products.hs
View file

@ -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.
-}

63
test/Bench.hs
View file

@ -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]]
]

76
test/Spec.hs
View file

@ -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