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

---
 .gitignore              |   1 +
 src/World/.Types.hs.swo | Bin 12288 -> 0 bytes
 src/World/Types.hs      |  50 ++++++++++++++++++++++++++++++++++++------------
 test/WorldTypesTest.hs  |  13 +++++++++++++
 4 files changed, 52 insertions(+), 12 deletions(-)
 delete mode 100644 src/World/.Types.hs.swo

diff --git a/.gitignore b/.gitignore
index f88a72f..f55c96b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
 *~
 *.swp
 .stack-work
+*.swo
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)
+
+
+
diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs
index 3c48c4e..f1822fc 100644
--- a/test/WorldTypesTest.hs
+++ b/test/WorldTypesTest.hs
@@ -8,6 +8,7 @@ import World.Types
   , Compatible (..)
   , Pos
   , LatticeProposal (..)
+  , LatticePropList (..)
   , AgentProposal (..)
   , Proposal (..)
   )
@@ -75,4 +76,16 @@ latticePropTests = testGroup "lattice proposal tests" $
       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))
+
+  , testCase "merge lattice proposal lists" $
+    let
+      a = LatticeProposal (0, 0) Nothing  (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge
+      b = LatticeProposal (1, 0) Nothing  (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge
+      c = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge
+      d = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 5) :: LatticeProposal Int MockMerge
+    in do
+      (LatticePropList [a, b]) @=? merge (LatticePropList [a])    (LatticePropList [b])
+      (LatticePropList [c, b]) @=? merge (LatticePropList [a])    (LatticePropList [b, c])
+      (LatticePropList [c])    @=? merge (LatticePropList [a, b]) (LatticePropList [c, d])
+      (LatticePropList [b, d]) @=? merge (LatticePropList [b])    (LatticePropList [d])
   ]
-- 
cgit v1.2.1