Union of list with logical rules for combination
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}} *)
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.)
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}}*)