add Compatible typeclass

3 files changed, 50 insertions, 27 deletions

diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo
index 527fc99..29646f7 100644
--- a/src/World/.Types.hs.swo
+++ b/src/World/.Types.hs.swo
diff --git a/src/World/Types.hs b/src/World/Types.hs
index c7f77ce..f69bfa1 100644
--- a/src/World/Types.hs
+++ b/src/World/Types.hs
@@ -1,5 +1,6 @@
 module World.Types
   ( Merge (..)
+  , Compatible (..)
   , Pos
   , LatticeProposal (..)
   , AgentProposal (..)
@@ -8,24 +9,29 @@ module World.Types
 
 
 class Merge a where
-  mergeCompatible :: a -> a -> Bool
+  mergable :: a -> a -> Bool
   merge :: a -> a -> a
 
+class Compatible a where
+  compatible :: a -> a -> Bool
+
 instance (Merge a) => Merge (Maybe a) where
-  mergeCompatible (Just x) (Just y) = mergeCompatible x y
-  mergeCompatible _ _ = True
+  mergable (Just x) (Just y) = mergable x y
+  mergable _ _ = True
+  mergable (Just x) (Just y) = mergable x y
+  mergable _ _ = True
   merge (Just x) (Just y) = Just $ merge x y
   merge Nothing (Just y) = Just $ y
   merge (Just x) (Nothing) = Just $ x
   merge Nothing Nothing = Nothing
 
 class (Eq a) => MergeEq a where
-  mergeEqCompatible :: a -> a -> Bool
+  mergableEq :: a -> a -> Bool
   mergeEq :: a -> a -> a
 
 instance (Eq a) => MergeEq (Maybe a) where
-  mergeEqCompatible (Just x) (Just y) = x == y
-  mergeEqCompatible _ _ = True
+  mergableEq (Just x) (Just y) = x == y
+  mergableEq _ _ = True
   mergeEq (Just x) (Just _) = Just $ x
   mergeEq Nothing (Just y) = Just $ y
   mergeEq (Just x) (Nothing) = Just $ x
@@ -52,10 +58,20 @@ newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) der
 
 
 instance (Eq a, Merge b) => Merge (LatticeProposal a b) where
-  mergeCompatible x y =
+  mergable x y =
     if (cellPos x /= cellPos y) then True else
-      if mergeEqCompatible (from x) (from y)
-        && mergeEqCompatible (to x) (to y)
-        && mergeCompatible (cellFlags x) (cellFlags y)
+      if mergableEq (from x) (from y)
+        && mergableEq (to x) (to y)
+        && mergable (cellFlags x) (cellFlags y)
       then True
       else False
+  merge x y = if not (mergable x y)
+    then error "attempt to merge incompatible lattice proposals"
+    else LatticeProposal 
+      (cellPos x) 
+      (mergeEq (from x) (from y)) 
+      (mergeEq (to x) (to y)) 
+      (merge (cellFlags x) (cellFlags y))
+
+instance (Eq a, Merge b) => Compatible (LatticeProposal a b) where
+  compatible x y = (cellPos x /= cellPos y) || (mergable x y)
diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs
index 03c41d6..3c48c4e 100644
--- a/test/WorldTypesTest.hs
+++ b/test/WorldTypesTest.hs
@@ -5,6 +5,7 @@ import Test.Tasty
 import Test.Tasty.HUnit
 import World.Types
   ( Merge (..)
+  , Compatible (..)
   , Pos
   , LatticeProposal (..)
   , AgentProposal (..)
@@ -17,9 +18,9 @@ suite = testGroup "world types tests" $
   [ latticePropTests
   ]
 
-newtype MockMerge = MockMerge Int
+newtype MockMerge = MockMerge Int deriving (Show, Eq)
 instance Merge MockMerge where
-  mergeCompatible (MockMerge x) (MockMerge y) = x == y
+  mergable (MockMerge x) (MockMerge y) = x == y
   merge x _ = x
   merge _ _ = error "incompatible merge!"
 
@@ -28,44 +29,50 @@ latticePropTests = testGroup "lattice proposal tests" $
   [ testCase "lattice proposals correctly detect mergability" $
     do
       -- disjoint positions
-      True @=? mergeCompatible
+      True @=? compatible 
         (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
+      True @=? compatible
         (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing)
       -- merge from
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing)
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      False @=? mergeCompatible
+      False @=? mergable
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) (Just 5) Nothing Nothing)
       -- merge to
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing)
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      False @=? mergeCompatible
+      False @=? mergable
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing (Just 2) Nothing)
       -- merge flags
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4))
-      False @=? mergeCompatible
+      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))
   ]
-