summaryrefslogtreecommitdiff
path: root/src/World
diff options
context:
space:
mode:
authorsanine <sanine.not@pm.me>2023-11-30 14:19:20 -0600
committersanine <sanine.not@pm.me>2023-11-30 14:19:20 -0600
commit671c632d5c8085a1d14a66e96890555192237be5 (patch)
tree42f151591c5f1a83d135bf77083400ca8c022f7a /src/World
parentbf40a269daef0517e2d0fc5961e043ece6ff4837 (diff)
add Compatible typeclass
Diffstat (limited to 'src/World')
-rw-r--r--src/World/.Types.hs.swobin12288 -> 12288 bytes
-rw-r--r--src/World/Types.hs36
2 files changed, 26 insertions, 10 deletions
diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo
index 527fc99..29646f7 100644
--- a/src/World/.Types.hs.swo
+++ b/src/World/.Types.hs.swo
Binary files 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)