Задача коммивояжёра на делфи

Я думаю все слышали о Задаче коммивояжёра, если нет, то используем вики.

Вкратце расскажу об этой задаче допустим у нас есть граф, на нам необходим обойти все вершины, так что бы они не повторялись и так что бы этот путь был минимальным. Есть несколько алгоритмов решения:
полный лексический перебор, случайный перебор но такие методы не совсем интересно использовать в программировании. Поэтому рассорим метода «Метод ветвей и границ»
Собственно код на делфи), «999» это как бы бесконечность, или просто очень больное число… Матрица на форме это матрица путей на пересечении(столбца и строки) путей — длина пути
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
memo1: TMemo;
StringGrid2: TStringGrid;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
TMatr=array [0..7,0..7]of integer;///Тип--количество вершин
Trec=record
row:Integer;
col:Integer;
end;

var
RecRez:Trec;
m:TMatr;
Form1: TForm1;
l,p:Integer;
Size:Integer=6;
implementation

uses Math;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);Инициализая начальной формы
var i,j:Integer;
begin
Size:=6;l:=0;p:=0;
m[2,1]:=45;
m[3,1]:=14;
m[4,1]:=71;
m[5,1]:=19;
m[6,1]:=12;

m[1,2]:=15;
m[3,2]:=54;
m[4,2]:=3;
m[5,2]:=34;
m[6,2]:=23;

m[1,3]:=58;
m[2,3]:=15;
m[4,3]:=4;
m[5,3]:=62;
m[6,3]:=26;

m[1,4]:=52;
m[2,4]:=16;
m[3,4]:=24;
m[5,4]:=21;
m[6,4]:=47;

m[1,5]:=24;
m[2,5]:=74;
m[3,5]:=35;
m[4,5]:=24;
m[6,5]:=81;

m[1,6]:=54;
m[2,6]:=10;
m[3,6]:=16;
m[4,6]:=52;
m[5,6]:=26;

memo1.Clear;
memo1.Lines.Add('Зажаданая:');
for i:=0 to 7 do begin
m[i,i]:=999;
m[0,i]:=i;
m[i,0]:=i;
end;
end;

procedure initz ;
var i,j:Integer;
begin
for i:=1 to 6 do begin
for j:=1 to 6 do
Form1.StringGrid1.Cells[j,i]:=Inttostr(m[i,j]);
end;

end;

Procedure MemoAdd(siz:Integer);////вывод данных на форму
var i,j:integer;s:String;
begin
for i:=0 to siz do
begin
s:='';
for j:=0 to siz do
begin
if m[i,j]<=9 then s:=s+IntToStr(m[i,j])+' '
else if m[i,j]<=99 then s:=s+IntToStr(m[i,j])+' '
else if m[i,j]<=999 then s:=s+IntToStr(m[i,j])+' ';
end;
form1.memo1.lines.add(s);
end;
form1.memo1.lines.add('');
end;

procedure obrSTR;///приводим по строкам
var i,j,k,sz:Integer;
minstr,mincol:Integer;
begin
for i:=1 to Size do
begin
minstr:=666;
for j:=1 to Size do
if m[i,j]<minstr then minstr:=m[i,j];
for j:=1 to size do
if m[i,j]<>999 then
m[i,j]:=m[i,j]-minstr;
m[i,size+1]:=minstr;
end;
form1.memo1.Lines.add('Приведенная по строкам:');
sz:=size;
m[sz+1,sz+1]:=999;
m[0,sz+1]:=0;
m[sz+1,0]:=0;

Memoadd(sz+1);
end;

procedure obrCOL;;///приводим по столбцам
var i,j,sz,k:Integer;
minstr,mincol:Integer;
begin
I:=0;j:=0;
for i:=1 to Size do
begin
mincol:=666;
For j:=1 to size do
if m[j,i]<mincol then mincol:=m[j,i];
for j:=1 to size do
if m[j,i]<>999 then
m[j,i]:=m[j,i]-mincol;
m[size+1,i]:=mincol;
end;

sz:=size;
m[sz+1,sz+1]:=999;
m[0,sz+1]:=0;
m[sz+1,0]:=0;
form1.memo1.Lines.add('Приведенная по столбцам:');
Memoadd(sz+1);
end;

function Qcol(z:Integer):Integer;
var iq:Integer;
begin
iq:=0;
for iq:=1 to z do
Result:=m[iq,size+1]+Result;
end;

function Qstr(z:Integer):Integer;
var iq:Integer;
begin
iq:=0;
Result:=0;
for iq:=1 to z do
Result:=m[size+1,iq]+Result;
end;

function DeltaMAX(var r:Integer; var c:Integer):Integer;
var i,j,k,w,v,y,x:Integer;
RowPos,ColPos:Integer;
begin
Result:=-1000;
for i:=1 to Size do
begin
for j:=1 to size do
begin
RowPos:=999;ColPos:=998;
if m[i,j]=0 then
begin
for k:=1 to size do
begin
if (m[i,k]<RowPos)and(k<>j) then RowPos:=m[i,k];
if (m[k,j]<ColPos)and(i<>k) then ColPos:=m[k,j];
end;
if RowPos=999 then RowPos:=0;
if ColPos=999 then ColPos:=0;
Form1.Memo1.Lines.Add('D('+IntToStr(M[i,0])+','+IntToStr(M[0,j])+')='+IntToStr(RowPos)+'+'+IntToStr(ColPos)+'='+IntToStr(RowPos+ColPos));
If RowPos+ColPos>Result then
begin
Result:=RowPos+ColPos;
R:=M[i,0];
C:=M[0,j];
end;
end;

end;
end;
Form1.Memo1.Lines.Add('DeltaMax=D('+IntToStr(R)+','+IntToStr(C)+')='+IntToStr(Result));
Form1.Memo1.Lines.Add('');
end;

procedure DeleteRC(row:Integer;col:Integer);
var i,sz,f,w,j:Integer;
begin
w:=0;f:=0;

I:=0;j:=0;
while m[i,0]<row do
inc(i);
while m[0,j]<col do
Inc(j);

for f:=0 to size do
for w:=j to size do
m[f,w]:=m[f,w+1];
for f:=i to size do
for w:=0 to size do
m[f,w]:=m[f+1,w];
dec(Size);
Form1.Memo1.Lines.Add('');
form1.memo1.Lines.Add('Вычеркивеам '+'('+inttostr(row)+' '+IntToStr(col)+')'+':');
Memoadd(size);
l:=0;
Form1.StringGrid2.Cells[l,p]:=IntToStr(row);
l:=1;
Form1.StringGrid2.Cells[l,p]:=IntToStr(col);
inc(p);
end;

procedure TForm1.Button1Click(Sender: TObject);Основная процедура
type TQC=array [0..26] of char;
var i,j,w:integer;
first:Boolean;
QA,QB,Qbaz:Integer;
work,sz,row,col,WQ,iQ,jQ:Integer;
Q:TQC;
ch:Char;
ok:Boolean;
begin
initz;
Memoadd(size);
QB:=0;

obrSTR;
obrCOL;
Qbaz:=Qcol(size)+Qstr(Size);
memo1.Lines.Add('Базвовая оценка Гамельтонова цикла:'+inttostr(Qbaz));
wq:=DeltaMAX(row,col);
QA:=WQ+Qbaz;
memo1.Lines.Add('Qa: '+IntToStr(Qbaz)+'+'+IntToStr(wq)+'='+IntToStr(QA));
deleteRC(row,col);

I:=0;j:=0;
while m[i,0]<col do
inc(i);
while m[0,j]<row do
Inc(j);
m[i,j]:=999;
repeat
obrSTR;
obrCOL;

Qb:=Qb+Qbaz;
Memo1.Lines.Add('Qb='+IntToStr(Qbaz)+'+'+IntToStr(Qb-Qbaz)+'='+IntToStr(Qb));
Memo1.Lines.Add('');

if Qa<Qb then
begin
Memo1.Lines.Add('Qa<Qb');
Qbaz:=Qa;
end;
if Qa>Qb then
begin
Memo1.Lines.Add('Qa>Qb');
Qbaz:=Qb;
end;

wq:=DeltaMAX(row,col);
QA:=WQ+Qbaz;
memo1.Lines.Add('Qa: '+IntToStr(Qbaz)+'+'+IntToStr(wq)+'='+IntToStr(QA));
deleteRC(row,col);

I:=0;j:=0;
while m[i,0]<col do
inc(i);
while m[0,j]<row do
Inc(j);
m[i,j]:=999;

until Size=2;
obrSTR;
obrCOL;
Qb:=WQ+Qbaz;

for i:=1 to Size do
for j:=1 to size do
if (m[i,j]=0) and (i+j=3) then
begin
l:=0;
Form1.StringGrid2.Cells[l,p]:=IntToStr(m[i,0]);
l:=1;
Form1.StringGrid2.Cells[l,p]:=IntToStr(m[0,j]);
inc(p);
end;
Qb:=Qb+Qbaz;
Memo1.Lines.Add('Qb='+IntToStr(Qbaz)+'+'+IntToStr(Qb-Qbaz)+'='+IntToStr(Qb));
Memo1.Lines.Add('');

if Qa<Qb then Memo1.Lines.Add('Длина цикла :'+IntToStr(Qa))
else Memo1.Lines.Add('Длина цикла :'+IntToStr(Qb));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
memo1.Clear;
end;

end.





Ахрхив с иходником

Rapidshare.RU/1313487