diff options
| -rw-r--r-- | src/World/Types.hs | 35 | ||||
| -rw-r--r-- | test/WorldTypesTest.hs | 96 |
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 ] |