Kody źródłowe/Algorytm Prima

{
DANE:
  n - liczba wierzchołków grafu
  a - graf spójny i nieskierowany - tablica wskaźników na listy krawędzi incydentnych
  a[i] - adres pierwszej krawędzi incydentnej z wierzchołkiem grafu "i"
  elementem listy opisującym krawędź jest rekord zawierający trzy pola:
  wezel - numer wierzchołka grafu połączonego krawędzią
  koszt - koszt tej krawędzi
  nast  - adres następnego składnika listy
  wszystkie krawędzie grafu powinny mieć nieujemne koszty
  z - tablica, w której zapisano informację o zrobionych wierzchołkach grafu
  z[i]=prawda, gdy wierzchołek "i" został już dołączony do minimalnego drzewa rozpinającego

WYNIK:
  minimalne drzewo rozpinające "b" grafu "a"

Zaznacz wybrany wierzchołek - niech będzie to wierzchołek 1 - jako dołączony do minimalnego drzewa rozpinającego (zrobiony)
Dla wszystkich wierzchołków j incydentnych z wierzchołkiem 1:
jeżeli wierzchołek j nie został jeszcze zrobiony, to krawędź prowadzącą do tego wierzchołka dodaj do kopca
Dopóki kopiec nie jest pusty wykonuj następujące czynności:
Jeżeli krawędź o najmniejszym koszcie w kopcu prowadzi do wierzchołka jeszcze nie zrobionego, to wykonaj następujące czynności:
Dodaj tą krawędź do minimalnego drzewa rozpinającego
Zaznacz wierzchołek i, do którego prowadzi krawędź jako zrobiony
Usuń z kopca krawędź prowadzącą do wierzchołka i
Dla wszystkich wierzchołków j incydentnych z wierzchołkiem i:
  Jeżeli wierzchołek j nie został jeszcze dołączony do minimalnego drzewa rozpinającego, to dołącz krawędź [i, j] do kopca
  Jeżeli krawędź prowadzi do wierzchołka już dołączonego do minimalnego drzewa rozpinającego, to usuń ją z kopca
}

type
  WKrawedzGrafu = ^KrawedzGrafu;
  KrawedzGrafu = record
    wezel : integer;
    koszt : integer;
    nast : WKrawedzGrafu;
  end;

  Graf = array[1..20] of WKrawedzGrafu;

  WezelKopca = record
    odwezla : integer;
    dowezla : integer;
    koszt : integer;
  end;

  Kopiec = array[1..100] of WezelKopca;

Procedure Zamien(var a, b: WezelKopca);
var
  tmp: WezelKopca;
begin
  tmp := a;
  a := b;
  b := tmp;
end;

{ n - rozmiar kopca }
{ k - numer węzła   }
procedure Przywroc(Var a: Kopiec; n, k: integer);
var
  rodzic, potomek: integer;
begin
  { Przywróć strukturę ku górze, do korzenia }
  potomek := k;
  rodzic := potomek div 2;
  while (rodzic > 0) and (a[rodzic].koszt > a[potomek].koszt) do
  begin
    zamien(a[rodzic], a[potomek]);
    potomek := rodzic;
    rodzic := potomek div 2;
  end;

  { Przywróć strukturę ku dołowi, od korzenia }
  rodzic := k;
  potomek := 2 * rodzic;

  while potomek <= n do
  begin
   if (potomek<n) And (a[potomek].koszt>a[potomek+1].koszt) then Inc(potomek);
   if a[potomek].koszt<a[rodzic].koszt then
   begin
     zamien(a[rodzic], a[potomek]);
     rodzic := potomek;
     potomek := 2 * rodzic;
   end
   else
     break;
  end;
end;

{ Dodaj do kopca krawędź grafu }
{ n - rozmiar kopca            }
procedure DoKopca(var a: Kopiec; var n: integer; odwezla, dowezla, koszt: integer);
begin
  inc(n);
  a[n].odwezla := odwezla;
  a[n].dowezla := dowezla;
  a[n].koszt := koszt;
  przywroc(a, n, n);
end;

{ Usuń z kopca jego korzeń }
procedure ZKopca(var a: Kopiec; var n: integer);
begin
  zamien(a[1], a[n]);
  dec(n);
  przywroc(a, n, 1);
end;

Procedure DodajKrawedz(var a : Graf; odwezla, dowezla, koszt : integer);
var
  tmp : WKrawedzGrafu;
begin
  new(tmp);
  tmp^.wezel := dowezla;
  tmp^.koszt := koszt;
  tmp^.nast := a[odwezla];
  a[odwezla] := tmp;
  new(tmp);
  tmp^.wezel := odwezla;
  tmp^.koszt := koszt;
  tmp^.nast := a[dowezla];
  a[dowezla] := tmp;
end;

{ Przekształć graf "a" w min. drzewo rozpinające "b" }
{ n - ilość wierzchołków grafu                       }
procedure GenerujGraf(var a, b : Graf; n : integer);
var
  i : integer;
  k : Kopiec;
  ck : integer;
  ptr : WKrawedzGrafu;
  z : array[1..20] of boolean;
begin
  ck := 0;
  for i := 1 to n do
  begin
    b[i] := nil;
    z[i] := false;
  end;

  ptr := a[1];
  z[1] := true;
  while ptr <> nil Do
  begin
    if not z[ptr^.wezel] then
     DoKopca(k, ck, 1, ptr^.wezel, ptr^.koszt);
    ptr := ptr^.nast;
  end;

  while ck > 0 Do
  begin
    if not z[k[1].dowezla] then
    begin
      i := k[1].dowezla;
      DodajKrawedz(b, k[1].odwezla, k[1].dowezla, k[1].koszt);
      ZKopca(k, ck);
      z[i] := true;
      ptr := a[i];

      while ptr <> nil do
      begin
        if not z[ptr^.wezel] then
          DoKopca(k, ck, i, ptr^.wezel, ptr^.koszt);
        ptr := ptr^.nast;
      end;
    end
    else
      ZKopca(k, ck);
  end;
end;

var
  i, n : integer;
  a, b : Graf;
  ptr : WKrawedzGrafu;

begin
  n := 6;
  for i := 1 to n do
  a[i] := nil;

  DodajKrawedz(a, 1, 2, 13);
  DodajKrawedz(a, 1, 3, 2);
  DodajKrawedz(a, 1, 4, 6);
  DodajKrawedz(a, 2, 4, 5);
  DodajKrawedz(a, 2, 5, 1);
  DodajKrawedz(a, 2, 6, 5);
  DodajKrawedz(a, 3, 4, 3);
  DodajKrawedz(a, 3, 5, 15);
  DodajKrawedz(a, 4, 2, 1);
  DodajKrawedz(a, 4, 5, 10);
  DodajKrawedz(a, 5, 2, 2);

  GenerujGraf(a, b, n);

  writeln('Minimalne drzewo rozpinające :');
  for i := 1 to n do
  begin
    ptr := b[i];
    while ptr <> nil do
    begin
      if i <= ptr^.wezel then
        writeln(i, ' -> ', ptr^.wezel, ' - ', ptr^.koszt);
      ptr := ptr^.nast;
    end;
  end;

  readln;
end.