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

Question

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!

Answer 1

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}}}

Answer 2

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
];

Answer 3

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]