implement Combinable for LatticePropList

3 files changed, 58 insertions, 65 deletions

diff --git a/src/Agent.hs b/src/Agent.hs
new file mode 100644
index 0000000..bb9e284
--- /dev/null
+++ b/src/Agent.hs
@@ -0,0 +1,16 @@
+module Agent
+  (
+  ) where
+
+
+import Mind (Network (..))
+
+
+data Agent a = Agent
+  { id :: Int
+  , net :: Network
+  , state :: [Float]
+  , x :: Int
+  , y :: Int
+  , flags :: a
+  }
diff --git a/src/Proposal.hs b/src/Proposal.hs
new file mode 100644
index 0000000..dd2ea84
--- /dev/null
+++ b/src/Proposal.hs
@@ -0,0 +1,7 @@
+module Proposal
+  (
+  ) where
+
+
+class Flag a where
+  compatibleFlag :: a -> a -> Bool
diff --git a/src/World/Types.hs b/src/World/Types.hs
index f5a410e..32e4df6 100644
--- a/src/World/Types.hs
+++ b/src/World/Types.hs
@@ -1,6 +1,5 @@
 module World.Types
-  ( Merge (..)
-  , Compatible (..)
+  ( Combinable (..)
   , Pos
   , LatticeProposal (..)
   , LatticePropList (..)
@@ -9,32 +8,27 @@ module World.Types
   ) where
 
 
-class Merge a where
-  mergable :: a -> a -> Bool
-  merge :: a -> a -> a
+class Combinable a where
+  -- the "identity" element of the class is combinable with all others
+  -- and (naturally) results in those others when combined
+  identity :: a
+  -- determine if two class elements can be combined
+  combinable :: a -> a -> Bool
+  -- combine two class elements
+  combine :: a -> a -> a
 
-class Compatible a where
-  compatible :: a -> a -> Bool
+-- define Combinable for Maybe
+instance (Eq a) => Combinable (Maybe a) where
+  identity = Nothing
 
-instance (Merge a) => Merge (Maybe a) where
-  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
+  combinable (Just x) (Just y) = x == y
+  combinable _ _ = True
 
-class (Eq a) => MergeEq a where
-  mergableEq :: a -> a -> Bool
-  mergeEq :: a -> a -> a
+  combine (Just x) (Just y) = if x /= y then error "attempt to combine non-combinable Justs" else Just x
+  combine (Just x) Nothing = Just x
+  combine Nothing (Just x) = Just x
+  combine Nothing Nothing = Nothing
 
-instance (Eq a) => MergeEq (Maybe a) where
-  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
-  mergeEq Nothing Nothing = Nothing
 
 type Pos = (Int, Int)
 
@@ -42,51 +36,30 @@ type Pos = (Int, Int)
 -- lattice proposals
 data LatticeProposal a b = LatticeProposal
   { cellPos :: Pos
-  , from :: Maybe a
-  , to :: Maybe a
-  , cellFlags :: Maybe b
+  , from :: a
+  , to :: a
+  , cellFlags :: b
   }
   deriving (Show, Eq)
 newtype LatticePropList a b = LatticePropList [LatticeProposal a b] deriving (Show, Eq)
 
-instance (Eq a, Merge b) => Merge (LatticeProposal a b) where
-  mergable x y =
-    if (cellPos x /= cellPos y) then True else
-      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 (Combinable a, Combinable b) => Combinable (LatticePropList a b) where
+  identity = LatticePropList []
 
-instance (Eq a, Merge b) => Compatible (LatticeProposal a b) where
-  compatible x y = (cellPos x /= cellPos y) || (mergable x y)
-
-instance (Eq a, Merge b) => Merge (LatticePropList a b) where
-  mergable _ _ = True
-  merge xs (LatticePropList ys) = 
+  combinable (LatticePropList xs) (LatticePropList ys) = 
     let
-      mergeAcross as b = foldl
-        (\(valid, LatticePropList list) x -> if valid 
-          then
-            let
-              b' = head list
-              rest = tail list
-            in if mergable b' x
-              then (True, LatticePropList $ (merge b' x):rest)
-              else if compatible b' x then (True, LatticePropList $ b':x:rest) else (False, LatticePropList [])
-          else (False, LatticePropList list)
-        )
-        (True, LatticePropList [b])
-        as
-    in snd $ foldl (\(valid, LatticePropList list) x -> if valid then mergeAcross list x else (False, LatticePropList [])) (True, xs) ys
+      pairIsCombinable (a, b) = 
+        if (cellPos a) /= (cellPos b) then True
+        else if
+          combinable (from a) (from b) &&
+          combinable (to a) (to b) &&
+          combinable (cellFlags a) (cellFlags b)
+          then True else False
+      pairs = [ (x, y) | x <- xs, y <- ys ]
+    in
+      all pairIsCombinable pairs
 
+  combine (LatticePropList xs) (LatticePropList ys) = LatticePropList $ xs ++ ys
 
 
 -- agent proposals
@@ -98,6 +71,3 @@ data AgentProposal a = AgentProposal
   deriving (Show, Eq)
 
 newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) deriving (Show, Eq)
-
-
-