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

enter image description here

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