summaryrefslogtreecommitdiff
path: root/src/World
diff options
context:
space:
mode:
authorsanine <sanine.not@pm.me>2023-11-30 17:34:58 -0600
committersanine <sanine.not@pm.me>2023-11-30 17:34:58 -0600
commit450ac00012ba57fc70d655c5a8c4fb8eb5e6d5d3 (patch)
tree05a831a4acf2bde010af45c2aa8c7a85f158b179 /src/World
parent671c632d5c8085a1d14a66e96890555192237be5 (diff)
begin implementing lattice proposal list merging
Diffstat (limited to 'src/World')
-rw-r--r--src/World/.Types.hs.swobin12288 -> 0 bytes
-rw-r--r--src/World/Types.hs50
2 files changed, 38 insertions, 12 deletions
diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo
deleted file mode 100644
index 29646f7..0000000
--- a/src/World/.Types.hs.swo
+++ /dev/null
Binary files 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
@@ -18,8 +19,6 @@ class Compatible a where
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
merge Nothing (Just y) = Just $ y
merge (Just x) (Nothing) = Just $ x
@@ -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)
+
+
+