# How to combine elements of a list who have two elements in common?

I am a bit new to both Mathematica and StackExchange, so I apologize if I have made any mistakes in my question or missed an obvious answer. I have lists of the form

{{1, 2, 3, 4}, {1, 4, 5, 8}, {7, 8, 11, 12}}


and want to return lists where the union of any two adjoining elements is taken if they share two elements in common. For the example above, this would result in the list below:

{{1, 2, 3, 4, 5, 8},{7, 8, 11, 12}}


I have used a Table construction (below) to find the Length of each of the intersections of adjoining elements, but am having trouble combining the lists when they share exactly two elements.

Length /@ Table[Intersection[#[[i]], #[[i + 1]]], {i, Length[#] - 1}] & @ {{1, 2, 3, 4}, {1, 4, 5, 8}, {7, 8, 11, 12}}

I have done a lot of brainstorming about this, but every way I think of runs into issues when considering the special cases of multiple of these intersections chained together (which may be able to be solved by recursion) such as:

{{1,2,3,4},{1,4,5,6},{5,6,7,8},{10,11,12,13}} -> {{1,2,3,4,5,6,7,8},{10,11,12,13}}


or when two of the unions have to occur at different points in the list such as:

{{1,2,3,4},{1,4,5,6},{7,8,9,10},{11,12,13,14},{13,14,15,16}} -> {{1,2,3,4,5,6},{7,8,9,10},{11,12,13,14,15,16}}


Furthermore the number of lists will be of arbitrary length. Thank you for any help!

• What do you want to happen in those exception cases? Like can three or more be joined? Do they join if only each pair contains 2 elements in common? Is the criteria exactly 2 or at least 2? Etc Etc. I think you'll make more progress if you clearly and explicitly define the desired behavior. Jul 10, 2023 at 19:32
• Thank you for your reply! I will edit my question to make it a bit more clear. Jul 11, 2023 at 14:11
• Welcome! As someone new to MMA, you might find this thread useful. Jul 11, 2023 at 19:11

l1 = {{1, 2, 3, 4}, {1, 4, 5, 8}, {7, 8, 11, 12}};

l2 = {{1, 2, 3, 4}, {1, 4, 5, 6}, {5, 6, 7, 8}, {10, 11, 12, 13}};

l3 = {{1, 2, 3, 4}, {1, 4, 5, 6}, {7, 8, 9, 10}, {11, 12, 13, 14},
{13, 14, 15, 16}};


### 1. ReplaceRepeated

ClearAll[f]
f = ReplaceRepeated[{a___, b_List, c___, d_List, e___} /;
Length[Intersection[b, d]] == 2 :> {a, Union[b, d], c, e}]


Examples:

f /@ {l1, l2, l3}

{{{1, 2, 3, 4, 5, 8}, {7, 8, 11, 12}},
{{1, 2, 3, 4, 5, 6, 7, 8}, {10, 11, 12, 13}},
{{1, 2, 3, 4, 5, 6}, {7, 8, 9, 10}, {11, 12, 13, 14, 15, 16}}}


### 2. FixedPoint + Gather

ClearAll[g]
g = FixedPoint[Union @@@ Gather[#, Length@Intersection[##] == 2 &] &, #] &;


Examples:

g /@ {l1, l2, l3}

{{{1, 2, 3, 4, 5, 8}, {7, 8, 11, 12}},
{{1, 2, 3, 4, 5, 6, 7, 8}, {10, 11, 12, 13}},
{{1, 2, 3, 4, 5, 6}, {7, 8, 9, 10}, {11, 12, 13, 14, 15, 16}}}


### 3. FixedPoint + SequenceReplace

ClearAll[h]
h = FixedPoint[SequenceReplace[{a_, b___, c_} /;
Length[Intersection[a, c]] == 2 :> Sequence[Union[a, c], b]], #] &;


Examples:

h /@ {l1, l2, l3}

{{{1, 2, 3, 4, 5, 8}, {7, 8, 11, 12}},
{{1, 2, 3, 4, 5, 6, 7, 8}, {10, 11, 12, 13}},
{{1, 2, 3, 4, 5, 6}, {7, 8, 9, 10}, {11, 12, 13, 14, 15, 16}}}


### 4. RelationGraph + ConnectedComponents

ClearAll[c]
c = Union @@@ ConnectedComponents @
RelationGraph[Length @ Intersection @ ## == 2 &, #] &;


Examples:

c /@ {l1, l2, l3}

{{{1, 2, 3, 4, 5, 8}, {7, 8, 11, 12}},
{{1, 2, 3, 4, 5, 6, 7, 8}, {10, 11, 12, 13}},
{{11, 12, 13, 14, 15, 16}, {1, 2, 3, 4, 5, 6}, {7, 8, 9, 10}}}

• Thank you so much for your response! This is exactly what I was looking for. I just have a quick question about what ## means since you used that in some of your answers and I can't seem to find documentation about it online. Jul 11, 2023 at 14:12
• @Jakwins, my pleasure. Welcome to mma.se. Re ## see SlotSequence.
– kglr
Jul 11, 2023 at 14:14

kglr's solution is the functional version (which is the recommended way in Mathematica). But I thought to also give a procedural version for those who are coming to Mathematica from other languages, it might be a little easier to understand at the cost of being longer.

lis = {{1, 2, 3, 4}, {1, 4, 5, 8}, {7, 8, 11, 12}};
doIt[lis]
(* {{1,2,3,4,5,8},{7,8,11,12}}*)

lis={{1,2,3,4},{1,4,5,6},{5,6,7,8},{10,11,12,13}};
doIt[lis]
(* {{1,2,3,4,5,6,7,8},{10,11,12,13}} *)

lis = {{1, 2, 3, 4}, {1, 4, 5, 6}, {7, 8, 9, 10}, {11, 12, 13, 14}, {13, 14, 15, 16}};
doIt[lis]
(* {{1,2,3,4,5,6},{7,8,9,10},{11,12,13,14,15,16}}*)


## code

This traverse the list looking at each pair of lists. Once it finds two adjacent lists that need to be union'ed, it does it, replaces the original list, and start all over again using the now new list (which will now have length of one less than before because it combined two entries into one).

It keeps doing this until it reaches the end of the list. A flag (OMG!) is used to tell it when to restart again on the list if it is updated. It stops when it reaches the end of the list.

doIt[lisIn_List]:=Module[{keepTrying,lis=lisIn,n,a,b},
keepTrying=True;
While[keepTrying,
Do[
If[n==Length[lis],
keepTrying = False
,
a = lis[[n]];b=lis[[n+1]];
If[Length[Union[a,b]]==Length[a]+Length[b]-2,
lis=ReplacePart[lis,{n->Union[a,b],n+1->Nothing}];
Break[]
]
]
,{n,1,Length[lis]}
]
];
lis
];


Another way to do this using GroupBy and a bit more:

g[lst_?MatrixQ] := Module[{ints, fints, tints, fl, tl, tlf},
ints = GroupBy[Subsets[lst, {2}],
Function[
Equal[Length[Intersection[Part[#, 1], Part[#, 2]]], 2]
]
];
tints = Lookup[ints, True];
fints = Lookup[ints, False];
fl =
DeleteDuplicates @
DeleteElements[Catenate @ fints, Catenate @ tints];
tl = MapApply[Union, tints];
tlf = Function[
Which[
Equal[Length @ #, 1],
#,
And[Equal[Length @ #, 2],
SameQ[DisjointQ[Part[#, 1], Part[#, 2]], True]
],
#,
And[Equal[Length @ #, 2],
SameQ[DisjointQ[Part[#, 1], Part[#, 2]], False]
],
{Union @@ #}
]
][tl];
Return[SortBy[Catenate @ {tlf, fl}, First]]
];


Examples:

Column[g /@ {l1, l2, l3}, Spacings -> 1.5]