add Compatible typeclass

2 files changed, 26 insertions, 10 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)