# Union of list with logical rules for combination

I have an list that I would like to reduce according to rules for combination. Examples of the input list (this will be a list of pairs and may be several hundred elements long) and the output I'm looking for with some function f are:

f[{{1,4},{1,6}}]
-> {{1,4,6}}


The two input lists both contain 1 and are combined. Or

f[{{1, 4}, {1, 6}, {2, 3}}]
-> {{1,4,6},{2,3}}


As in the first but {2,3} has no common elements with the others and remains separate. One way of doing this is with a repeated rule:

{{1, 4},{1,6}, {2, 3}} //. {head___, {x_, y_}, mid___, {x_, z_} | {z_, x_} | {y_, z_} | {z_, y_}, tail___} -> {head, {x, y, z}, mid, tail}
-> {{1,4,6},{2,3}}


This produces the correct output but has a problem that some other inputs makes clear - the last {4,6} term should have been combined with {1,4,6} and disappear:

{{1, 4},{1, 6}, {2, 3}, {4, 6}}//. {head___, {x_, y_}, mid___, {x_, z_} | {z_, x_} | {y_, z_} | {z_, y_}, tail___} -> {head, {x, y, z}, mid, tail}
-> {{1, 4, 6}, {2, 3}, {4, 6}}


The correct output should be:

{{1,4,6},{2,3}}


Or

{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}//. {head___, {x_, y_}, mid___, {x_, z_} | {z_, x_} | {y_, z_} | {z_, y_}, tail___} -> {head, {x, y, z}, mid, tail}
-> {{1, 4, 6}, {2, 3, 5}, {4, 6}}


The correct output should be:

{{1, 4, 6}, {2, 3, 5}}


The repeated rule above builds longer lists than pairs (there are then not matched in subsequent iterations) but I haven't found a way of writing a pattern to deal with it (so maybe rule replacement isn't the way to go here), I've tried a couple of other approaches of a more functional nature but seem to be missing something. Any suggestions?

• So, are you familiar with Union[] and Intersection[]? Feb 18 at 13:10
• @J.M. yes, of course, Union[{1,4},{1,6}] yields {1,4,6} but this isn't all there is to it, it would need to be selectively applied and some form of recursion is needed I think. I don't immediately see how Intersection would help here. Feb 18 at 13:31

f[sep: List[__List]]:= Union @@@ Gather[
sep,
IntersectingQ
]

f@{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}
(* {{1, 4, 6}, {2, 3, 5}} *)

f@{{1, 4},{1, 6}, {2, 3}, {4, 6}}
(* {{1, 4, 6}, {2, 3}} *)


Alternatively, use pattern:

{{1,4},{1,6},{2,3},{4,6}} //. {
{OrderlessPatternSequence[x1: {__}, x2: {__}, y___]}
:> {Union[x1, x2], y}/;IntersectingQ[x1, x2]
}
(* {{1, 4, 6}, {2, 3}} *)

• Thanks @Chromo Runge the Gather method is very elegant and I didn't know the OrderlessPatternSequence function until now Feb 18 at 17:58

### KCoreComponents

The function KCoreComponents with 1 as the second argument gives the desired result:

ClearAll[f1]

f1 = KCoreComponents[#, 1] &;


Examples:

f1  @ {{1, 4}, {1, 6}, {2, 3}}

{{1, 4, 6}, {2, 3}}

f1  @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}}

{{1, 4, 6}, {2, 3}}

f1 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}

{{2, 3, 5}, {1, 4, 6}}


### ConnectedComponents

Alternatively, you can use ConnectedComponents and delete singleton elements:

ClearAll[f2]

f2 = DeleteCases[{_}] @* ConnectedComponents


Examples:

f2 @ {{1, 4}, {1, 6}, {2, 3}}

{{1, 4, 6}, {2, 3}}

f2 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}}

{{1, 4, 6}, {2, 3}}

f2 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}

{{2, 3, 5}, {1, 4, 6}}


For fun:

pairs = {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}};

HighlightGraph[pairs,
Subgraph[pairs, #] & /@ KCoreComponents[pairs, 1],
GraphHighlightStyle -> "Thick", PlotTheme -> "IndexLabeled"] Note: The fact that KCoreComponents, ConnectedComponents, Graph and HighlightGraph (as well as many other graph-related functions) accept a list of pairs as the first argument is not documented. The pairs are interpreted as undirected edges. (See also: this answer.)

• Thanks @kglr I keep getting surprised by what can be done with graph functionality once a problem has been formulated in a way that exploits it Feb 20 at 14:16

If I understand your question correctly, you would like to join all sub lists that have some elements in common und delete duplicates. This can be achieved by e.g.:

{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3,
5}} //. {y1___, x1:{__}, y2___, x2:{__}, y3___} /;
Intersection[x1, x2] != {} :> {y1, Union[x1, x2], y2, y3}

(*{{1, 4, 6}, {2, 3, 5}}*)