From 450ac00012ba57fc70d655c5a8c4fb8eb5e6d5d3 Mon Sep 17 00:00:00 2001
From: sanine <sanine.not@pm.me>
Date: Thu, 30 Nov 2023 17:34:58 -0600
Subject: begin implementing lattice proposal list merging

---
 src/World/.Types.hs.swo | Bin 12288 -> 0 bytes
 src/World/Types.hs      |  50 ++++++++++++++++++++++++++++++++++++------------
 2 files changed, 38 insertions(+), 12 deletions(-)
 delete mode 100644 src/World/.Types.hs.swo

(limited to 'src/World')

diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo
deleted file mode 100644
index 29646f7..0000000
Binary files a/src/World/.Types.hs.swo and /dev/null differ
diff --git a/src/World/Types.hs b/src/World/Types.hs
index f69bfa1..f5a410e 100644
--- a/src/World/Types.hs
+++ b/src/World/Types.hs
@@ -3,6 +3,7 @@ module World.Types
   , Compatible (..)
   , Pos
   , LatticeProposal (..)
+  , LatticePropList (..)
   , AgentProposal (..)
   , Proposal (..)
   ) where
@@ -16,8 +17,6 @@ class Compatible a where
   compatible :: a -> a -> Bool
 
 instance (Merge a) => Merge (Maybe a) where
-  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
@@ -39,6 +38,8 @@ instance (Eq a) => MergeEq (Maybe a) where
 
 type Pos = (Int, Int)
 
+
+-- lattice proposals
 data LatticeProposal a b = LatticeProposal
   { cellPos :: Pos
   , from :: Maybe a
@@ -46,16 +47,7 @@ data LatticeProposal a b = LatticeProposal
   , 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)
-
+newtype LatticePropList a b = LatticePropList [LatticeProposal a b] deriving (Show, Eq)
 
 instance (Eq a, Merge b) => Merge (LatticeProposal a b) where
   mergable x y =
@@ -75,3 +67,37 @@ instance (Eq a, Merge b) => Merge (LatticeProposal a b) where
 
 instance (Eq a, Merge b) => Compatible (LatticeProposal a b) where
   compatible x y = (cellPos x /= cellPos y) || (mergable x y)
+
+instance (Eq a, Merge b) => Merge (LatticePropList a b) where
+  mergable _ _ = True
+  merge xs (LatticePropList ys) = 
+    let
+      mergeAcross as b = foldl
+        (\(valid, LatticePropList list) x -> if valid 
+          then
+            let
+              b' = head list
+              rest = tail list
+            in if mergable b' x
+              then (True, LatticePropList $ (merge b' x):rest)
+              else if compatible b' x then (True, LatticePropList $ b':x:rest) else (False, LatticePropList [])
+          else (False, LatticePropList list)
+        )
+        (True, LatticePropList [b])
+        as
+    in snd $ foldl (\(valid, LatticePropList list) x -> if valid then mergeAcross list x else (False, LatticePropList [])) (True, xs) ys
+
+
+
+-- agent proposals
+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)
+
+
+
-- 
cgit v1.2.1