//Program pobrany ze strony www.algorytm.org
//Opracowal Michal Knasiecki

//UWAGA!!!!!!!!!!!

{Przykladowy graf jest zapisany w pliku graf.txt
Struktura pliku jest następująca:

Rozmiar
:waga:waga:...waga:
:waga:waga:...Waga:
...................
:waga:waga:...Waga:



Gdzie liczba kolumn i wierszy macierzy jest równa rozmiarowi.
Jesli waga=0 to nie istnieje krawędź lącząca odpowiednie wierzcholki}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, StdCtrls;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    Plik1: TMenuItem;
    Wczytajlist1: TMenuItem;
    Wyczy1: TMenuItem;
    N1: TMenuItem;
    Zakocz1: TMenuItem;
    ListBox1: TListBox;
    Button1: TButton;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    Button2: TButton;
    Label1: TLabel;
    SaveDialog1: TSaveDialog;
    N2: TMenuItem;
    Zapiszraport1: TMenuItem;
    Label2: TLabel;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Wczytajlist1Click(Sender: TObject);
    procedure Wyczy1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Zakocz1Click(Sender: TObject);
    procedure Zapiszraport1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
           wsk=^list;
        list=record
                vert:integer;
                waga:integer;
                next:wsk;
                end;

         EdgeList=^edge;
         edge=record
                pop:integer;
                nast:integer;
                waga:integer;
                next:edgelist;
                end;
       TCzas=class
        start,stop:Tdatetime;
        function Podaj:Tdatetime;
        function Oblicz:integer;
        end;

var
Form1: TForm1;
first:edgelist;
tablica:array of wsk;
current:wsk;
currlist:edgelist;
time,id,n:integer;
czas:tczas;
d,p,f:array of integer;
connected:boolean;
globalX,globalY,globalW:integer;
tree:array of boolean;
treeN:integer;
koszt:integer;
implementation

{$R *.DFM}
function tczas.Podaj:TDateTime;
begin
Result:=Now;
end;
function Tczas.Oblicz:integer;
begin
result:=trunc(TimeStampToMSecs(DateTimeToTimeStamp(czas.stop))-
TimeStampToMSecs(DateTimeToTimeStamp(czas.start)));
end;

procedure AddToList(tab:integer;vert:integer;waga:integer;var current:wsk);
var prev,next:wsk;
t:boolean;
begin
t:=false;
if tablica[tab]=nil then t:=true;
if tablica[tab]<>nil then
        begin
        prev:=current;
        next:=current^.next;
        end else
        begin
        prev:=nil;
        next:=nil;
        end;
new(current);
current^.vert:=vert;
current^.waga:=waga;
current^.next:=next;
if prev<>nil then prev^.next:=current;
if t=true then tablica[tab]:=current;
end;
procedure Removeall2;
var tmp,next:edgelist;
begin
tmp:=first;
while tmp<>nil do
begin
next:=tmp^.next;
dispose(tmp);
tmp:=next;
end;
end;

procedure Removeall(tab:integer);
var next:wsk;
begin
if tablica[tab]<>nil then begin
next:=tablica[tab];
repeat
if next<>nil then current:=next;
{if current=tablica[tab]
then form1.listbox1.items.add('Wierzcholek: '+inttostr(current^.vert)) else
form1.listbox1.items.add(inttostr(current^.vert));}
next:=current^.next;
{if remove=true then}
if current<>tablica[tab] then dispose(current) else tablica[tab]:=nil;
until next=nil;
end;
end;
procedure Wypisz(tab:integer);
var next:wsk;
begin
if tablica[tab]<>nil then begin
next:=tablica[tab];
repeat
if next<>nil then current:=next;
if form1.ListBox1.Items.Capacity<32000 then
if current=tablica[tab]
then form1.listbox1.items.add('Wierzcholek: '+inttostr(current^.vert)) else
form1.listbox1.items.add(inttostr(current^.vert)+' ['+inttostr(current^.waga)+']');
next:=current^.next;
until next=nil;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var i:integer;
begin
listbox1.clear;
for i:=1 to n do wypisz(i);
end;
function podajwage(s:string;i:integer):integer;
var p,j:integer;
c:string[1];
tmp:string;
begin
j:=0;
p:=1;
repeat
c:=s[p];
inc(p);
if c=':' then inc(j);
until j=i;
tmp:='';
repeat
c:=s[p];
inc(p);
if c<>':' then tmp:=tmp+c;
until c=':';
result:=strtoint(tmp);
end;
procedure TForm1.Wczytajlist1Click(Sender: TObject);
var f:textfile;
 s:string;
 waga,i,j:integer;
begin
if opendialog1.execute then
 begin
 assignfile(f,opendialog1.filename);
 reset(f);
 readln(f,s);
 n:=strtoint(s);
 setlength(tablica,n+1);
 current:=nil;
 for i:=1 to n do
        begin
        readln(f,s);
        for j:=1 to n do
        begin
        if j=1 then addtolist(i,i,0,current); {***********}
        waga:=podajwage(s,j);
        if waga>0 then addtolist(i,j,waga,current);
//        if strtoint(s[j])>0 then addtolist(i,j,waga,current);
        end;
        end;
 closefile(f);
 memo1.lines.add('> Graf wczytany...');
 memo1.lines.add('> Liczba wierzchołków:  '+inttostr(n));
 memo1.lines.add('> Liczba krawędzi:  '+inttostr(round((n+(n*(n-3)/2))*0.6)));
 end;
end;

procedure TForm1.Wyczy1Click(Sender: TObject);
var i:integer;
begin
for i:=1 to n do removeall(i);
removeall2;
finalize(tablica);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
czas:=tczas.create;
end;
function next(w:wsk):integer;
begin
if w^.next<>nil then
        begin
        current:=w^.next;
        result:=current^.vert;
        end
        else
        result:=0;
end;

  procedure Visit(v: Integer);    {proc. rekurencyjnego odwiedzania wierzch.}
  var i:integer;
  begin
    if id<>1 then connected:=false;
    D[v]:=time;    {przydzielenie numerka w numeracji pre-order}
    Inc(time);
      current:=tablica[v];
      repeat
      i:=next(current);
      if i>0 then
      begin
       if D[i]=-1 then    {jesli wierzch. i jest bialy to ...}
       begin
        P[i]:=v;    {zaznaczamy, ze to z wierzch. v przechozimy do i}
        Visit(i);   {przechodzimy rekurencyjnie do wierzch. i}
       end
       end;
      until i=0;
    F[v]:=time;    {przydzielenie numerka w numeracji post-order}
    Inc(time);
  end;

  procedure DFS;
  var i:integer;
  begin
    for i:=1 to N do
    begin
      D[i]:=-1;F[i]:=-1;    {oznaczamy wszystkie wierzcholki jako biale}
      {Uwaga! wierzch. biale maja obie wartosci rowne -1;
              czarne - obie rozne od -1; szare - D rozne od -1, F rowne -1}
    end;
    time:=1;    {zmienna potrzebna do numeracji}

    for i:=1 to N do
      if D[i]=-1 then    {jesli wierzch. i jest bialy to ...}
      begin
        id:=i;
        P[i]:=-1;    {zaznaczamy, ze wierzch. i jest jednym z wierzch. startowych}
        Visit(i);    {przechodzimy do wierzch. i}
      end;
  end;
procedure usun(x,y:integer);
var tmp,prev,next:wsk;
begin
tmp:=tablica[x];
repeat
prev:=tmp;
tmp:=tmp^.next;
until tmp^.vert=y;
next:=tmp^.next;
prev^.next:=next;
dispose(tmp);
end;
//Procedury Listy krawędzi
procedure AddToEdgeList(pop,nast,waga:integer{;var current:edgelist});
var prev,next:edgelist;
begin
if currlist<>nil then
begin
prev:=currlist;
next:=currlist^.next;
end else
begin
prev:=nil;
next:=nil;
end;
new(currlist);
currlist^.pop:=pop;
currlist^.nast:=nast;
currlist^.waga:=waga;
currlist^.next:=next;
if first=nil then first:=currlist;
if prev<>nil then prev^.next:=currlist;
end;
procedure findLess(waga:integer{;var first,current:edgelist});
var tmp,next:edgelist;
begin
if first<>nil then
begin
next:=first;
tmp:=next;
repeat
if (next^.next<>nil) then begin
tmp:=next;
next:=next^.next
end;
until (next^.next=nil)or(next.waga>waga);
if next.waga>waga then currlist:=tmp else currlist:=next;
end;
end;
procedure addtotree(v:integer;w:integer);
var tmp:wsk;
begin
if tree[v]=false then
        begin
//showmessage(inttostr(v)+':'+inttostr(w));
        inc(treen);
//        form1.listbox2.items.add(inttostr(v));
        tree[v]:=true;
        inc(koszt,w);
        tmp:=tablica[v]^.next;
                while tmp<>nil do
                begin
//                showmessage(inttostr(tmp^.vert));
                findless(tmp^.waga);
                addtoedgelist(v,tmp^.vert,tmp^.waga);
                tmp:=tmp^.next;
                end;
//        findless();
        end;
end;
procedure pobierz;
var tmp:edgelist;
f:edgelist;
begin
f:=first^.next;
if f{irst}<>nil then begin
globalx:=f{irst}^.pop;
globalY:=f{irst}^.nast;
GlobalW:=f{irst}^.waga;
tmp:=f{irst}^.next;
dispose(f{irst});
first^.next:=tmp;
end else
begin
globalx:=0;
globaly:=0;
globalw:=0;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var i:integer;
//next:edgelist;
begin
//Spójnosc
setlength(p,n+1);
setlength(d,n+1);
setlength(f,n+1);
connected:=true;
memo1.lines.add('> Badanie spójności grafu...');
dfs;
finalize(p);
finalize(d);
finalize(f);
if connected=false then memo1.lines.add('> Graf nie jest spójny') else
memo1.lines.add('> Graf jest spójny');
begin
memo1.lines.add('> Budowanie listy krawędzi...');
//Przepisanie listy sąsiedztwa do listy krawędzi
memo1.lines.Add('> Szukanie drzewa...');
setlength(tree,n+1);
for i:=1 to n do tree[i]:=false;
first:=nil;
currLIST:=nil;
addtoedgelist(0,0,0);
currLIST:=nil;
treen:=0;
koszt:=0;
czas.start:=czas.podaj;
addtotree(1,0);
repeat
pobierz;
addtotree(globaly,globalw);
until treen=n;
czas.stop:=czas.podaj;
finalize(tree);
memo1.lines.Add('> Znaleziono w '+inttostr(czas.oblicz)+' [ms]');
memo1.lines.Add('> Minimalny koszt wynosi '+inttostr(koszt));
end;
end;
procedure TForm1.Zakocz1Click(Sender: TObject);
begin
application.terminate;
end;

procedure TForm1.Zapiszraport1Click(Sender: TObject);
begin
if savedialog1.execute then
begin
memo1.lines.SaveToFile(savedialog1.filename);
end;
end;

end.