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

Split tests to separate modules

Browse source
This commit is contained in:
Joshua Moerman 2024-11-05 10:59:40 +01:00
parent 9575a62e56
commit c206b16cba
6 changed files with 125 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
README.md
View file

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

6
ons-hs.cabal
View file

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

77
test/Spec.hs
View file

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

43
test/SpecMap.hs Normal file
View file

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

50
test/SpecSet.hs Normal file
View file

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

15
test/SpecUtils.hs Normal file
View file

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