implement Combinable for LatticePropList

7 files changed, 99 insertions, 132 deletions

diff --git a/nerine.cabal b/nerine.cabal
index 418fec0..903ef49 100644
--- a/nerine.cabal
+++ b/nerine.cabal
@@ -25,10 +25,12 @@ source-repository head
 
 library
   exposed-modules:
+      Agent
       Genome
       Lattice
       Lib
       Mind
+      Proposal
       World.Types
   other-modules:
       Paths_nerine
@@ -65,9 +67,11 @@ test-suite nerine-test
   type: exitcode-stdio-1.0
   main-is: Main.hs
   other-modules:
+      AgentTest
       GenomeTest
       LatticeTest
       MindTest
+      ProposalTest
       WorldTypesTest
       Paths_nerine
   autogen-modules:
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)
-
-
-
diff --git a/test/AgentTest.hs b/test/AgentTest.hs
new file mode 100644
index 0000000..c89d28a
--- /dev/null
+++ b/test/AgentTest.hs
@@ -0,0 +1,10 @@
+module AgentTest (suite) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Agent
+
+suite :: TestTree
+suite = testGroup "agent tests" $
+  [
+  ]
diff --git a/test/ProposalTest.hs b/test/ProposalTest.hs
new file mode 100644
index 0000000..1b78c69
--- /dev/null
+++ b/test/ProposalTest.hs
@@ -0,0 +1,10 @@
+module ProposalTest (suite) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Proposal 
+
+suite :: TestTree
+suite = testGroup "proposal tests" $
+  [
+  ]
diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs
index f1822fc..5a45418 100644
--- a/test/WorldTypesTest.hs
+++ b/test/WorldTypesTest.hs
@@ -4,8 +4,7 @@ module WorldTypesTest (suite) where
 import Test.Tasty
 import Test.Tasty.HUnit
 import World.Types
-  ( Merge (..)
-  , Compatible (..)
+  ( Combinable (..)
   , Pos
   , LatticeProposal (..)
   , LatticePropList (..)
@@ -19,73 +18,24 @@ suite = testGroup "world types tests" $
   [ latticePropTests
   ]
 
-newtype MockMerge = MockMerge Int deriving (Show, Eq)
-instance Merge MockMerge where
-  mergable (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 @=? compatible 
-        (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 1) Nothing Nothing Nothing)
-      True @=? compatible
-        (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing)
-      -- merge from
-      True @=? mergable
-        (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) (Just 4) Nothing Nothing)
-      True @=? mergable
-        (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      False @=? mergable
-        (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) (Just 5) Nothing Nothing)
-      -- merge to
-      True @=? mergable
-        (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing (Just 4) Nothing)
-      True @=? mergable
-        (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      False @=? mergable
-        (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing (Just 2) Nothing)
-      -- merge flags
-      True @=? mergable
-        (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      True @=? mergable
-        (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4))
-      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))
-
-  , testCase "merge lattice proposal lists" $
+  [ testCase "combine LatticePropList with identity" $
+    let 
+      propList :: LatticePropList (Maybe Int) (Maybe Int)
+      propList = LatticePropList
+        [ LatticeProposal (0, 0) (Just 0) (Just 0) (Just 0)
+        , LatticeProposal (0, 1) Nothing (Just 0) (Just 0)
+        , LatticeProposal (1, 1) (Just 0) Nothing Nothing
+        ]
+    in combine identity propList @?= propList
+  , testCase "conditionally combine proposal lists" $
     let
-      a = LatticeProposal (0, 0) Nothing  (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge
-      b = LatticeProposal (1, 0) Nothing  (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge
-      c = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge
-      d = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 5) :: LatticeProposal Int MockMerge
-    in do
-      (LatticePropList [a, b]) @=? merge (LatticePropList [a])    (LatticePropList [b])
-      (LatticePropList [c, b]) @=? merge (LatticePropList [a])    (LatticePropList [b, c])
-      (LatticePropList [c])    @=? merge (LatticePropList [a, b]) (LatticePropList [c, d])
-      (LatticePropList [b, d]) @=? merge (LatticePropList [b])    (LatticePropList [d])
+      a :: [LatticeProposal (Maybe Int) (Maybe Int)]
+      a = [ LatticeProposal (0, 0) (Just 0) Nothing Nothing ]
+      a' :: [LatticeProposal (Maybe Int) (Maybe Int)]
+      a' = [ LatticeProposal(0, 0) (Just 4) Nothing Nothing ]
+    in
+      combinable (LatticePropList a) (LatticePropList a') @?= False
   ]