From bf40a269daef0517e2d0fc5961e043ece6ff4837 Mon Sep 17 00:00:00 2001
From: sanine <sanine.not@pm.me>
Date: Thu, 30 Nov 2023 13:54:44 -0600
Subject: begin adding world types
---
src/World/.Types.hs.swo | Bin 0 -> 12288 bytes
src/World/Types.hs | 61 ++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 61 insertions(+)
create mode 100644 src/World/.Types.hs.swo
create mode 100644 src/World/Types.hs
(limited to 'src')
diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo
new file mode 100644
index 0000000..527fc99
Binary files /dev/null and b/src/World/.Types.hs.swo differ
diff --git a/src/World/Types.hs b/src/World/Types.hs
new file mode 100644
index 0000000..c7f77ce
--- /dev/null
+++ b/src/World/Types.hs
@@ -0,0 +1,61 @@
+module World.Types
+ ( Merge (..)
+ , Pos
+ , LatticeProposal (..)
+ , AgentProposal (..)
+ , Proposal (..)
+ ) where
+
+
+class Merge a where
+ mergeCompatible :: a -> a -> Bool
+ merge :: a -> a -> a
+
+instance (Merge a) => Merge (Maybe a) where
+ mergeCompatible (Just x) (Just y) = mergeCompatible x y
+ mergeCompatible _ _ = 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
+ mergeEq :: a -> a -> a
+
+instance (Eq a) => MergeEq (Maybe a) where
+ mergeEqCompatible (Just x) (Just y) = x == y
+ mergeEqCompatible _ _ = True
+ mergeEq (Just x) (Just _) = Just $ x
+ mergeEq Nothing (Just y) = Just $ y
+ mergeEq (Just x) (Nothing) = Just $ x
+ mergeEq Nothing Nothing = Nothing
+
+type Pos = (Int, Int)
+
+data LatticeProposal a b = LatticeProposal
+ { cellPos :: Pos
+ , from :: Maybe a
+ , to :: Maybe a
+ , cellFlags :: Maybe b
+ }
+ deriving (Show, Eq)
+
+data AgentProposal a = AgentProposal
+ { id :: Int
+ , agentPos :: Pos
+ , agentFlags :: a
+ }
+ deriving (Show, Eq)
+
+newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) deriving (Show, Eq)
+
+
+instance (Eq a, Merge b) => Merge (LatticeProposal a b) where
+ mergeCompatible 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)
+ then True
+ else False
--
cgit v1.2.1