From 671c632d5c8085a1d14a66e96890555192237be5 Mon Sep 17 00:00:00 2001
From: sanine <sanine.not@pm.me>
Date: Thu, 30 Nov 2023 14:19:20 -0600
Subject: add Compatible typeclass
---
src/World/.Types.hs.swo | Bin 12288 -> 12288 bytes
src/World/Types.hs | 36 ++++++++++++++++++++++++++----------
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
index 527fc99..29646f7 100644
Binary files a/src/World/.Types.hs.swo and b/src/World/.Types.hs.swo differ
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))
]
-
--
cgit v1.2.1