diff options
| -rw-r--r-- | src/World/.Types.hs.swo | bin | 12288 -> 12288 bytes | |||
| -rw-r--r-- | src/World/Types.hs | 36 | ||||
| -rw-r--r-- | test/WorldTypesTest.hs | 41 |
3 files changed, 50 insertions, 27 deletions
diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo Binary files differindex 527fc99..29646f7 100644 --- a/src/World/.Types.hs.swo +++ b/src/World/.Types.hs.swo diff --git a/src/World/Types.hs b/src/World/Types.hs index c7f77ce..f69bfa1 100644 --- a/src/World/Types.hs +++ b/src/World/Types.hs @@ -1,5 +1,6 @@ module World.Types ( Merge (..) + , Compatible (..) , Pos , LatticeProposal (..) , AgentProposal (..) @@ -8,24 +9,29 @@ module World.Types class Merge a where - mergeCompatible :: a -> a -> Bool + mergable :: a -> a -> Bool merge :: a -> a -> a +class Compatible a where + compatible :: a -> a -> Bool + instance (Merge a) => Merge (Maybe a) where - mergeCompatible (Just x) (Just y) = mergeCompatible x y - mergeCompatible _ _ = True + mergable (Just x) (Just y) = mergable x y + mergable _ _ = True + 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 class (Eq a) => MergeEq a where - mergeEqCompatible :: a -> a -> Bool + mergableEq :: a -> a -> Bool mergeEq :: a -> a -> a instance (Eq a) => MergeEq (Maybe a) where - mergeEqCompatible (Just x) (Just y) = x == y - mergeEqCompatible _ _ = True + 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 @@ -52,10 +58,20 @@ newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) der instance (Eq a, Merge b) => Merge (LatticeProposal a b) where - mergeCompatible x y = + mergable 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) + 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 (Eq a, Merge b) => Compatible (LatticeProposal a b) where + compatible x y = (cellPos x /= cellPos y) || (mergable x y) diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs index 03c41d6..3c48c4e 100644 --- a/test/WorldTypesTest.hs +++ b/test/WorldTypesTest.hs @@ -5,6 +5,7 @@ import Test.Tasty import Test.Tasty.HUnit import World.Types ( Merge (..) + , Compatible (..) , Pos , LatticeProposal (..) , AgentProposal (..) @@ -17,9 +18,9 @@ suite = testGroup "world types tests" $ [ latticePropTests ] -newtype MockMerge = MockMerge Int +newtype MockMerge = MockMerge Int deriving (Show, Eq) instance Merge MockMerge where - mergeCompatible (MockMerge x) (MockMerge y) = x == y + mergable (MockMerge x) (MockMerge y) = x == y merge x _ = x merge _ _ = error "incompatible merge!" @@ -28,44 +29,50 @@ latticePropTests = testGroup "lattice proposal tests" $ [ testCase "lattice proposals correctly detect mergability" $ do -- disjoint positions - True @=? mergeCompatible + True @=? compatible (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 + True @=? compatible (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing) -- merge from - True @=? mergeCompatible + True @=? mergable (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) (Just 4) Nothing Nothing) - True @=? mergeCompatible + True @=? mergable (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) Nothing Nothing Nothing) - False @=? mergeCompatible + False @=? mergable (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) (Just 5) Nothing Nothing) -- merge to - True @=? mergeCompatible + True @=? mergable (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) Nothing (Just 4) Nothing) - True @=? mergeCompatible + True @=? mergable (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) Nothing Nothing Nothing) - False @=? mergeCompatible + False @=? mergable (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) Nothing (Just 2) Nothing) -- merge flags - True @=? mergeCompatible + True @=? mergable (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) Nothing Nothing Nothing) - True @=? mergeCompatible + True @=? mergable (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) - False @=? mergeCompatible + 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)) ] - |