(*^

::[paletteColors = 128;
fontset = title, "Times", 24, L2, center, bold, nohscroll;
fontset = subtitle, "Times", 18, L2, center, bold, nohscroll;
fontset = subsubtitle, "Times", 14, L2, center, bold, nohscroll;
fontset = section, "Times", 14, L2, bold, nohscroll, grayBox;
fontset = subsection, "Times", 12, L2, bold, nohscroll, blackBox;
fontset = subsubsection, "Times", 12, L2, nohscroll, whiteBox;
fontset = text, "Times", 12, L2, nohscroll;
fontset = smalltext, "Times", 10, L2, nohscroll;
fontset = input, "Courier", 10, L2, nohscroll;
fontset = output, "Courier", 10, L2, condense, nowordwrap;
fontset = message, "Courier", 10, L2, R65535, nowordwrap;
fontset = print, "Courier", 10, L2, condense, nowordwrap;
fontset = info, "Courier", 10, L2, nohscroll;
fontset = postscript, "Courier", 12, L2, nowordwrap;
fontset = name, "Geneva", 10, L2, italic, B65535, nowordwrap, nohscroll;
fontset = header, "Times", 10, L2;
fontset = footer, "Times", 12, L2, center;
fontset = help, "Geneva", 10, L2, nohscroll;
fontset = clipboard, "New York", 12, L2;
fontset = completions, "New York", 12, L2, nowordwrap;
fontset = network, "Courier", 10, L2, nowordwrap;
fontset = graphlabel, "Courier", 10, L2, nowordwrap;
fontset = special1, "Times", 12, L2, nowordwrap;
fontset = special2, "Times", 12, L2, center, nowordwrap;
fontset = special3, "Times", 12, L2, right, nowordwrap;
fontset = special4, "New York", 12, L2, nowordwrap;
fontset = special5, "New York", 12, L2, nowordwrap;]
:[font = title; inactive; hscroll; ]
Kruskal's Method
ALLAN HAYES
Department of Mathematics,The University, Leicester LE1 7RH , UK
Tel. 0533-523883 (Office), 0533-714198 (Home)
fax: 0533 522200, email: hay@le.ac.uk
;[s]
3:0,0;18,1;187,0;183,-1;
4:2,26,18,Times,1,24,0,0,0;1,14,9,Times,0,12,0,0,0;0,13,9,Times,0,10,0,0,0;0,15,11,Warwick A,0,10,0,0,0;
:[font = subsection; inactive; startGroup; Cclosed; hscroll; ]
Implementation
;[s]
2:0,0;15,0;16,-1;
5:2,14,9,Times,1,12,0,0,0;0,13,9,Courier,0,10,0,0,0;0,13,9,Courier,1,10,0,0,0;0,13,9,Times,0,10,0,0,0;0,13,9,Courier,32,10,0,0,0;
:[font = input; initialization; ]
*)
BeginPackage["kruskal`"];
(*
;[s]
3:0,0;14,1;21,0;26,-1;
4:2,13,9,Courier,0,10,0,0,0;1,12,9,Courier,1,10,0,0,0;0,13,9,Courier,32,10,0,0,0;0,12,8,Courier,0,9,0,0,0;
:[font = input; initialization; ]
*)
kruskalInfo::usage = "An extension of Kruskal's algorithm for least-weight spanning trees to cope with unconnected graphs and multiple arcs.\n
For any weighted undirected graph G given as a list of ARCS (triples of real numbers of the form aa = {s,w,f} with s < f, of which s,f are the ENDS and w the WEIGHT) e.g. {{1,4,8},{2,1,9},...}. The sum of the weights of the arcs is the WEIGHT of G, w(G).\n
The ends of the arcs are NODES of G. A node p is DIRECTLY CONNECTED to the node q if {p,w,q} is in G for some w. kruskal first constructs a list of the equivalence classes of the derived eqivalence relation which have more than one member (the non-trivial connected components, C1,C2, . . . of G). Then, for each Ci it finds a least weight spanning subgraph, Ti (it must be a tree).\n
kruskalList[G] is the list\n
{w,w1,C1,w2,C2,T2,...}, where wi = w(Ti) and w is the sum of the wi.\n
kruskalColumn[G] is the column form of this list.\n
kruskalGraph[n,w,nmbr] is a suitable input for the above.";

kruskalList::usage = "kruskalList[G], for the weighted graph G is a least-weight subgraph with the same connected components (see kruskalInfo).";
kruskalColumn::usage = "kruskalList[G], for the weighted graph G is a a column giving a least-weight subgraph with the same connected components (see kruskalInfo).";
kruskalGraph::usage = "kruskalGraph[n,w,nmbr], is a random graph with <= nmbr arcs having integer nodes drawn from [1,n] and integer weights drawn from [1,w] suitable as an input to kruskalList and to kruskalColumn";
(*
;[s]
16:0,1;13,0;797,1;808,0;907,1;920,0;963,1;975,0;985,1;986,0;1030,1;1041,0;1176,1;1189,0;1342,1;1354,0;1560,-1;
3:8,13,9,Courier,0,10,0,0,0;8,13,9,Courier,1,10,0,0,0;0,13,9,Courier,32,10,0,0,0;
:[font = input; initialization; ]
*)

Begin["`private`"];
(*
;[s]
2:0,0;27,0;28,-1;
3:2,13,9,Courier,0,10,0,0,0;0,13,9,Courier,1,10,0,0,0;0,13,9,Courier,32,10,0,0,0;
:[font = input; initialization; ]
*)

sort[G_]:=Sort[G,OrderedQ[{#1[[2]],#2[[2]]}]&] (* sort arcs by weight *)
weight[G_]:= Plus@@(Part[#,2]&/@G)
connectedQ[x_,CC_]:= MemberQ[Map[Complement[x,#]&,CC],{}]
(*CC is a list of lists of elements of A, say. A list, x, of 2 elements of A is connected by CC if all its elements, in either order, are in some one member of CC *)

connComp[CC_]:= CC//.connectedComponentRules
connectedComponentRules =
{a_List,y___,b_List,z___}:>{Union[a,b],y,z}/;Intersection[a,b]!={};
(*Replace pairs of intersecting sets by their union, using the simplification allowed by the fact that in the algorithm below we will be adding a new two-element set to the beginning of a list of disjoint sets *)

kruskalRules = {{x___},{{s_,w_,f_},z___},{cc___}}:>
If[connectedQ[{s,f},{cc}],{{x},{z},{cc}},
{{x,{s,w,f}},{z},connComp[{{s,f},cc}]}];

kruskal1[G_]:=
{{},sort[G],{}}//.kruskalRules/.{{a___},{},{cc___}}:> {{a},{cc}}

(*We form the triple
{{},sort[G],{}}.
This is then transformed by the kuskal rules: At any stage except at the end it will be of the form
{{a___},{{s_,w_,f_},aa___},{cc___}},
where {a___} is a subgraph of G and {cc___} is a list of the connected components of {a___}. The arc {s_,w_,f_} is then examined.If it connects two nodes in the same component of {cc___} it is simply removed, if not then it is appended to {a___} and {cc___} is replaced by connComp[{{s,f},cc}].Eventually we reach
{{a___},{},{cc___}}
where {a___} is the list of arcs which were not removed and {cc___} is the list of connected components of {a___}(= connected components of original graph). Then {} is removed to give
{{a___},{cc___}} *)

kruskal2[G_]:= Block[{k=kruskal1[G]},{weight[k[[1]]],k[[1]],k[[2]] }]

(* (A) changed to {weight{a___}, {a___}, {cc___}}*)

setUp[S_]:=
S//.{w_,{aa___},{c___,cc_List,ccc___}}:>{w,{aa},{c,L[0,cc,{}],ccc}}//.L->List

(*Each connected component cc is changed into the triple {0,cc,{}}.
The next stage, decomposition (below), changes each such triple to {ww, cc, {a__}}, where
{a__ } is the list of all arcs from aa which join nodes in cc, and ww is the weight of {a__}. Each arc from aa is successively transferred to the right list of arcs for some cc. Finally the emptied aa is removed to give
{w,{{ww, cc, {a__}}. . }} *)

decompose[S_]:=
S//.{w_,{{s_,ww_,f_},a___},{k___,{www_,cc_,{aa___}},kk___}}:>
{w,{a},{k,{ww+www,cc,{aa,{s,ww,f}}},kk}}/;Complement[{s,f},cc]=={}/.
{w_,{},{k___,{ww_,c_,{a___}},kk___}}:>{w,{k,{ww,c,{a}},kk}}

kruskalList[G_]:=decompose[setUp[kruskal2[G]]]
kruskalColumn[G_]:= ColumnForm[Flatten[kruskalList[G],2]]

kruskalGraph[n_,w_,nmbr_]:=
Select[Table[Random[Integer,{1,#}]&/@{n,w,n},{nmbr}],(First[#]<Last[#])&]
(*
;[s]
30:0,0;8,1;12,0;82,1;88,0;117,1;127,0;342,1;350,0;387,1;410,0;697,1;709,0;833,1;841,0;1745,1;1753,0;1879,1;1884,0;1892,2;2409,1;2418,0;2617,1;2628,0;2664,1;2677,0;2723,1;2735,0;2748,1;2751,0;2826,-1;
3:15,13,9,Courier,0,10,0,0,0;14,13,9,Courier,1,10,0,0,0;1,13,9,Courier,32,10,0,0,0;
:[font = input; initialization; endGroup; ]
*)
End[]
EndPackage[];
(*
:[font = subsection; inactive; startGroup; Cclosed; hscroll; ]
Example
:[font = output; ]
G = kruskalGraph[18,16,21]
:[font = input; endGroup; hscroll; ]
Timing[kruskalColumn[G]]
^*)