implement Combinable for AgentPropList

2 files changed, 127 insertions, 4 deletions

diff --git a/src/World/Types.hs b/src/World/Types.hs
index 32e4df6..cf66dd9 100644
--- a/src/World/Types.hs
+++ b/src/World/Types.hs
@@ -4,10 +4,14 @@ module World.Types
   , LatticeProposal (..)
   , LatticePropList (..)
   , AgentProposal (..)
+  , AgentPropList (..)
   , Proposal (..)
   ) where
 
 
+import Data.Maybe
+
+
 class Combinable a where
   -- the "identity" element of the class is combinable with all others
   -- and (naturally) results in those others when combined
@@ -64,10 +68,37 @@ instance (Combinable a, Combinable b) => Combinable (LatticePropList a b) where
 
 -- agent proposals
 data AgentProposal a = AgentProposal
-  { id :: Int
-  , agentPos :: Pos
+  { agentId :: Int
+  , agentPos :: Maybe Pos
   , agentFlags :: a
   }
   deriving (Show, Eq)
+newtype AgentPropList a = AgentPropList [AgentProposal a] deriving (Show, Eq)
+
+instance (Combinable a) => Combinable (AgentPropList a) where
+  identity = AgentPropList []
+
+  combinable (AgentPropList xs) (AgentPropList ys) =
+    let
+      pairIsCombinable (x, y) =
+        if (agentId x) == (agentId y)
+          -- same agent
+          then if 
+            combinable (agentPos x) (agentPos y) && 
+            combinable (agentFlags x) (agentFlags y)
+            then True else False
+          -- different agents
+          else if 
+            (isJust $ agentPos x) && 
+            (isJust $ agentPos y) &&
+            (fromJust $ agentPos x) == (fromJust $ agentPos y)
+            then False -- agents moving to the same location
+            else True -- c:
+      pairs = [ (x, y) | x <- xs, y <- ys ]
+    in
+      all pairIsCombinable pairs
+
+  combine (AgentPropList xs) (AgentPropList ys) = AgentPropList $ xs ++ ys
+
 
 newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) deriving (Show, Eq)
diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs
index 5a45418..e151fed 100644
--- a/test/WorldTypesTest.hs
+++ b/test/WorldTypesTest.hs
@@ -9,6 +9,7 @@ import World.Types
   , LatticeProposal (..)
   , LatticePropList (..)
   , AgentProposal (..)
+  , AgentPropList (..)
   , Proposal (..)
   )
 
@@ -16,6 +17,7 @@ import World.Types
 suite :: TestTree
 suite = testGroup "world types tests" $
   [ latticePropTests
+  , agentPropTests
   ]
 
 
@@ -30,12 +32,102 @@ latticePropTests = testGroup "lattice proposal tests" $
         , LatticeProposal (1, 1) (Just 0) Nothing Nothing
         ]
     in combine identity propList @?= propList
-  , testCase "conditionally combine proposal lists" $
+  , testCase "incompatible proposal lists are not combinable" $
     let
       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 ]
+      a' = [ LatticeProposal (0, 0) (Just 4) Nothing Nothing ]
     in
       combinable (LatticePropList a) (LatticePropList a') @?= False
+  , testCase "compatible proposal lists are combinable" $
+    let
+      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 0) (Just 4) (Just 2) ]
+    in
+      combinable (LatticePropList a) (LatticePropList a') @?= True
+  , testCase "otherwise incompatible proposal lists are still compatible for different cells" $
+    let
+      a :: [LatticeProposal (Maybe Int) (Maybe Int)]
+      a = [ LatticeProposal (0, 1) (Just 0) Nothing Nothing ]
+      a' :: [LatticeProposal (Maybe Int) (Maybe Int)]
+      a' = [ LatticeProposal (0, 0) (Just 4) Nothing Nothing ]
+    in
+      combinable (LatticePropList a) (LatticePropList a') @?= True 
+  , testCase "a single incompatible proposal results in overall incompatibility" $
+    let
+      a :: [LatticeProposal (Maybe Int) (Maybe Int)]
+      a = [ LatticeProposal (0, 0) (Just 0) Nothing Nothing 
+          , LatticeProposal (0, 1) (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
+  ]
+
+
+agentPropTests :: TestTree
+agentPropTests = testGroup "lattice proposal tests" $
+  [ testCase "combine AgentPropList with identity" $
+    let 
+      propList :: AgentPropList (Maybe Int)
+      propList = AgentPropList
+        [ AgentProposal 0 (Just (0, 0)) (Just 0)
+        , AgentProposal 0 (Just (0, 1)) Nothing
+        , AgentProposal 0 (Just (1, 1)) Nothing
+        ]
+    in combine identity propList @?= propList
+  , testCase "incompatible proposal lists are not combinable" $
+    let
+      a :: [AgentProposal (Maybe Int)]
+      a = [ AgentProposal 0 (Just (0, 0)) (Just 0) ]
+      a' :: [AgentProposal (Maybe Int)]
+      a' = [ AgentProposal 0 (Just (0, 0)) (Just 4) ]
+    in
+      combinable (AgentPropList a) (AgentPropList a') @?= False
+  , testCase "compatible proposal lists are combinable" $
+    let
+      a :: [AgentProposal (Maybe Int)]
+      a = [ AgentProposal 0 (Just (0, 0)) (Just 0) ]
+      a' :: [AgentProposal (Maybe Int) ]
+      a' = [ AgentProposal 0 (Just (0, 0)) (Just 0) ]
+    in
+      combinable (AgentPropList a) (AgentPropList a') @?= True
+  , testCase "trying to move an agent to two different locations is incompatible" $
+    let
+      a :: [AgentProposal (Maybe Int)]
+      a = [ AgentProposal 0 (Just (0, 1)) (Just 0) ]
+      a' :: [AgentProposal (Maybe Int)]
+      a' = [ AgentProposal 0 (Just (0, 0)) (Just 0) ]
+    in
+      combinable (AgentPropList a) (AgentPropList a') @?= False
+  , testCase "a single incompatible proposal results in overall incompatibility" $
+    let
+      a :: [AgentProposal (Maybe Int)]
+      a = [ AgentProposal 0 (Just (0, 0)) (Just 0) 
+          , AgentProposal 0 (Just (0, 1)) (Just 0) 
+          ]
+      a' :: [AgentProposal (Maybe Int)]
+      a' = [ AgentProposal 0 (Just (0, 0)) (Just 4) ]
+    in
+      combinable (AgentPropList a) (AgentPropList a') @?= False
+  , testCase "two updates moving different agents to the same location are incompatible" $
+    let
+      a :: [AgentProposal (Maybe Int)]
+      a = [ AgentProposal 0 (Just (0, 0)) Nothing ]
+      a' :: [AgentProposal (Maybe Int)]
+      a' = [ AgentProposal 1 (Just (0, 0)) Nothing ]
+    in
+      combinable (AgentPropList a) (AgentPropList a') @?= False
+   , testCase "two updates moving the same agent to the same location are compatible" $
+    let
+      a :: [AgentProposal (Maybe Int)]
+      a = [ AgentProposal 0 (Just (0, 0)) Nothing ]
+      a' :: [AgentProposal (Maybe Int)]
+      a' = [ AgentProposal 0 (Just (0, 0)) Nothing ]
+    in
+      combinable (AgentPropList a) (AgentPropList a') @?= True
   ]