begin adding world types

5 files changed, 136 insertions, 0 deletions

diff --git a/nerine.cabal b/nerine.cabal
index 0e1695a..418fec0 100644
--- a/nerine.cabal
+++ b/nerine.cabal
@@ -29,6 +29,7 @@ library
       Lattice
       Lib
       Mind
+      World.Types
   other-modules:
       Paths_nerine
   autogen-modules:
@@ -67,6 +68,7 @@ test-suite nerine-test
       GenomeTest
       LatticeTest
       MindTest
+      WorldTypesTest
       Paths_nerine
   autogen-modules:
       Paths_nerine
diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo
new file mode 100644
index 0000000..527fc99
--- /dev/null
+++ b/src/World/.Types.hs.swo
diff --git a/src/World/Types.hs b/src/World/Types.hs
new file mode 100644
index 0000000..c7f77ce
--- /dev/null
+++ b/src/World/Types.hs
@@ -0,0 +1,61 @@
+module World.Types
+  ( Merge (..)
+  , Pos
+  , LatticeProposal (..)
+  , AgentProposal (..)
+  , Proposal (..)
+  ) where
+
+
+class Merge a where
+  mergeCompatible :: a -> a -> Bool
+  merge :: a -> a -> a
+
+instance (Merge a) => Merge (Maybe a) where
+  mergeCompatible (Just x) (Just y) = mergeCompatible x y
+  mergeCompatible _ _ = 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
+  mergeEq :: a -> a -> a
+
+instance (Eq a) => MergeEq (Maybe a) where
+  mergeEqCompatible (Just x) (Just y) = x == y
+  mergeEqCompatible _ _ = 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)
+
+data LatticeProposal a b = LatticeProposal
+  { cellPos :: Pos
+  , from :: Maybe a
+  , to :: Maybe a
+  , cellFlags :: Maybe b
+  }
+  deriving (Show, Eq)
+
+data AgentProposal a = AgentProposal
+  { id :: Int
+  , agentPos :: Pos
+  , agentFlags :: a
+  }
+  deriving (Show, Eq)
+
+newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) deriving (Show, Eq)
+
+
+instance (Eq a, Merge b) => Merge (LatticeProposal a b) where
+  mergeCompatible 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)
+      then True
+      else False
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))
+  ]
+