Раздел «Алгоритмы».MinimalCoveringTreePAS:

Минимальное покрывающее дерево на Pascal

Алгоритм Прима (без использования двоичной кучи):

//(C) Igor Kvasov
const
  maxn = 100;
  infinity = maxlongint;

var
  i,j,u,v,n,m,c,min:longint;
  e,w:array[1..maxn,1..maxn]of longint;
  ne,use,p,key:array[1..maxn]of longint;

//Пояснения переменных
//e - списки инцидентности; e[i] - список смежных вершин вершины i
//ne[i] - количество вершин, инцидентных i-ой вершине
//w[i,j] - вес ребра, соединяющего вершины i и j
//use - множество вершин, уже входящих в текущее минимальное покрывающее дерево
//key[i] - расстояние вершины до текущего минимального покрывающего дерева
//p[i] - родитель i-ой вершины в построенном минимальном покрывающем дереве

begin
  //считывание входных данных
  read(n,m);
  for i:=1 to m do begin
    read(u,v,c);
    inc(ne[u]); e[u,ne[u]]:=v;
    inc(ne[v]); e[v,ne[v]]:=u;
    w[u,v]:=c; w[v,u]:=c;
  end;
  //инициализация структур
  for i:=1 to n do key[i]:=infinity;
  key[1]:=0;
  // по очереди добавляем к дереву по одной все вершины, на каждом шаге 
  // выбирая ближайшую к дереву
  for i:=1 to n do begin
    // выбор вешины, ближайшей к дереву, номер вершины - u
    min:=infinity;
    for j:=1 to n do if (use[j]=0)and(key[j]<min) then begin
      min:=key[j]; u:=j;
    end;
    use[u]:=1;      //помечаем вершину как добавленную
    for j:=1 to ne[u] do 
    begin   // обоновляем расстояние до дерева 
            // для всех вершин, инцидентных добавленной
       v:=e[u,j];
       if (use[v]=0)and(w[u,v]<key[v]) then begin
          p[v]:=u; key[v]:=w[u,v];
       end;
    end;
  end;
  for i:=2 to n do writeln(i,' ',p[i]);
end.

Алгоритм Крускала (с использованием непересекающихся множеств):

//(C) Igor Kvasov
const
  maxn = 10;
  maxm = 50;
type
  TEdge = record          //структура, необходимая для хранения 
    u,v,w:longint;        // иформации о ребре - соединяемые вершины, вес

  end;
var
  n,m,i,mid:longint;
  p,rank:array[1..maxn]of longint;  //структуры, необходимые для реализации системы 
                                    // непересекающихся множеств
                                    //p[i] - номер вершины-родителя множества, 
                                    // в которое входит i-ая вершина
                                    // rank[i] - оценка сверху глубины поддерева 
                                    // с корнем в i-ой вершине
  e:array[1..maxm]of TEdge;
  buf:TEdge;

procedure qsort(l,r:Longint); //быстрая сортировка
var
  j:longint;
begin
  i:=l; j:=r; mid:=e[(i+j)div 2].w;
  repeat
    while e[i].w<mid do inc(i);
    while e[j].w>mid do dec(j);
    if i<=j then begin
      buf:=e[i]; e[i]:=e[j]; e[j]:=buf;
      inc(i); dec(j);
    end;
  until i>j;
  if i<r then qsort(i,r);
  if j>l then qsort(l,j);
end;

//две процедуры для работы с системой непересекающихся множеств
function findset(x:longint):longint;
begin
  if x<>p[x] then p[x]:=findset(p[x]);
  findset:=p[x];
end;

procedure union(x,y:longint);
begin
  x:=findset(x); y:=findset(y);
  if rank[x]>rank[y] then p[y]:=x else p[x]:=y;
  if rank[x]=rank[y] then inc(rank[y]);
end;

begin
  //ввод входных данных
  read(n,m);
  for i:=1 to m do read(e[i].u,e[i].v,e[i].w);
  qsort(1,m); //сортировка ребер по возрастанию веса
  for i:=1 to n do 
  begin //инициализация множеств: делаем n множеств, 
        // в каждом множестве сначала по одной вершине
    p[i]:=i; rank[i]:=0;
  end;
  // бежим по ребрам, в порядке возрастания их веса. Если текущее ребро 
  // соединяет вершины, принадлежащие разным множествам, то оно добавляется 
  // к дереву, а соответствующие множества вершин объединяются
  for i:=1 to m do 
       if findset(e[i].u)<>findset(e[i].v) then
       begin
           union(e[i].u,e[i].v);
           writeln(e[i].u,' ',e[i].v);
       end;
end.

-- IgorKvasov? - 16 Mar 2005

AlgorithmClasifyForm
Type: Код
Scope: Графы
Strategy: Жадность
Complexity: Low