From 135ce23bd188c9351c8e9dde783a713b72dff8f3 Mon Sep 17 00:00:00 2001 From: sanine Date: Sun, 3 Dec 2023 23:44:33 -0600 Subject: implement Combinable for LatticePropList --- test/AgentTest.hs | 10 ++++++ test/ProposalTest.hs | 10 ++++++ test/WorldTypesTest.hs | 84 ++++++++++---------------------------------------- 3 files changed, 37 insertions(+), 67 deletions(-) create mode 100644 test/AgentTest.hs create mode 100644 test/ProposalTest.hs (limited to 'test') diff --git a/test/AgentTest.hs b/test/AgentTest.hs new file mode 100644 index 0000000..c89d28a --- /dev/null +++ b/test/AgentTest.hs @@ -0,0 +1,10 @@ +module AgentTest (suite) where + +import Test.Tasty +import Test.Tasty.HUnit +import Agent + +suite :: TestTree +suite = testGroup "agent tests" $ + [ + ] diff --git a/test/ProposalTest.hs b/test/ProposalTest.hs new file mode 100644 index 0000000..1b78c69 --- /dev/null +++ b/test/ProposalTest.hs @@ -0,0 +1,10 @@ +module ProposalTest (suite) where + +import Test.Tasty +import Test.Tasty.HUnit +import Proposal + +suite :: TestTree +suite = testGroup "proposal tests" $ + [ + ] diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs index f1822fc..5a45418 100644 --- a/test/WorldTypesTest.hs +++ b/test/WorldTypesTest.hs @@ -4,8 +4,7 @@ module WorldTypesTest (suite) where import Test.Tasty import Test.Tasty.HUnit import World.Types - ( Merge (..) - , Compatible (..) + ( Combinable (..) , Pos , LatticeProposal (..) , LatticePropList (..) @@ -19,73 +18,24 @@ suite = testGroup "world types tests" $ [ latticePropTests ] -newtype MockMerge = MockMerge Int deriving (Show, Eq) -instance Merge MockMerge where - mergable (MockMerge x) (MockMerge y) = x == y - merge x _ = x - merge _ _ = error "incompatible merge!" latticePropTests :: TestTree latticePropTests = testGroup "lattice proposal tests" $ - [ testCase "lattice proposals correctly detect mergability" $ - do - -- disjoint positions - True @=? compatible - (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 1) Nothing Nothing Nothing) - True @=? compatible - (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing) - -- merge from - True @=? mergable - (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) (Just 4) Nothing Nothing) - True @=? mergable - (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing Nothing) - False @=? mergable - (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) (Just 5) Nothing Nothing) - -- merge to - True @=? mergable - (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing (Just 4) Nothing) - True @=? mergable - (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing Nothing) - False @=? mergable - (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing (Just 2) Nothing) - -- merge flags - True @=? mergable - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing Nothing) - True @=? mergable - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) - False @=? mergable - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 5)) - - - , testCase "merge lattice proposals" $ - do - LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) @?= merge - (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) - LatticeProposal (0, 0) (Just 2) (Just 4) (Just $ MockMerge 4) @?= merge - (LatticeProposal (0, 0) (Just 2) Nothing Nothing) - (LatticeProposal (0, 0) Nothing (Just 4) (Just $ MockMerge 4)) - - , testCase "merge lattice proposal lists" $ + [ testCase "combine LatticePropList with identity" $ + let + propList :: LatticePropList (Maybe Int) (Maybe Int) + propList = LatticePropList + [ LatticeProposal (0, 0) (Just 0) (Just 0) (Just 0) + , LatticeProposal (0, 1) Nothing (Just 0) (Just 0) + , LatticeProposal (1, 1) (Just 0) Nothing Nothing + ] + in combine identity propList @?= propList + , testCase "conditionally combine proposal lists" $ let - a = LatticeProposal (0, 0) Nothing (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge - b = LatticeProposal (1, 0) Nothing (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge - c = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge - d = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 5) :: LatticeProposal Int MockMerge - in do - (LatticePropList [a, b]) @=? merge (LatticePropList [a]) (LatticePropList [b]) - (LatticePropList [c, b]) @=? merge (LatticePropList [a]) (LatticePropList [b, c]) - (LatticePropList [c]) @=? merge (LatticePropList [a, b]) (LatticePropList [c, d]) - (LatticePropList [b, d]) @=? merge (LatticePropList [b]) (LatticePropList [d]) + a :: [LatticeProposal (Maybe Int) (Maybe Int)] + a = [ LatticeProposal (0, 0) (Just 0) Nothing Nothing ] + a' :: [LatticeProposal (Maybe Int) (Maybe Int)] + a' = [ LatticeProposal(0, 0) (Just 4) Nothing Nothing ] + in + combinable (LatticePropList a) (LatticePropList a') @?= False ] -- cgit v1.2.1