diff options
| author | sanine <sanine.not@pm.me> | 2023-11-30 13:54:44 -0600 |
|---|---|---|
| committer | sanine <sanine.not@pm.me> | 2023-11-30 13:54:44 -0600 |
| commit | bf40a269daef0517e2d0fc5961e043ece6ff4837 (patch) | |
| tree | 4d337ed89a9ccebf03f815adbab7406e8d98978f /test | |
| parent | 587cbadb3e6388c29454ab41c120757f108918fa (diff) | |
begin adding world types
Diffstat (limited to 'test')
| -rw-r--r-- | test/Main.hs | 2 | ||||
| -rw-r--r-- | test/WorldTypesTest.hs | 71 |
2 files changed, 73 insertions, 0 deletions
diff --git a/test/Main.hs b/test/Main.hs index 24666a6..8abc870 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -5,10 +5,12 @@ import Test.Tasty import qualified MindTest import qualified GenomeTest import qualified LatticeTest +import qualified WorldTypesTest main :: IO () main = defaultMain $ testGroup "all tests" $ [ MindTest.suite , GenomeTest.suite , LatticeTest.suite + , WorldTypesTest.suite ] diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs new file mode 100644 index 0000000..03c41d6 --- /dev/null +++ b/test/WorldTypesTest.hs @@ -0,0 +1,71 @@ +module WorldTypesTest (suite) where + + +import Test.Tasty +import Test.Tasty.HUnit +import World.Types + ( Merge (..) + , Pos + , LatticeProposal (..) + , AgentProposal (..) + , Proposal (..) + ) + + +suite :: TestTree +suite = testGroup "world types tests" $ + [ latticePropTests + ] + +newtype MockMerge = MockMerge Int +instance Merge MockMerge where + mergeCompatible (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 @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 1) Nothing Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing) + -- merge from + True @=? mergeCompatible + (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) (Just 4) Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + False @=? mergeCompatible + (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) (Just 5) Nothing Nothing) + -- merge to + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing (Just 4) Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + False @=? mergeCompatible + (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing (Just 2) Nothing) + -- merge flags + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) + False @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 5)) + ] + |