From bf40a269daef0517e2d0fc5961e043ece6ff4837 Mon Sep 17 00:00:00 2001
From: sanine <sanine.not@pm.me>
Date: Thu, 30 Nov 2023 13:54:44 -0600
Subject: begin adding world types

---
 test/Main.hs           |  2 ++
 test/WorldTypesTest.hs | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 73 insertions(+)
 create mode 100644 test/WorldTypesTest.hs

(limited to 'test')

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))
+  ]
+        
-- 
cgit v1.2.1