Лабораторная работа №5. Решение задачи о коммивояжере

1. Решение задачи методом ветвей и границ.

Модуль Traveller

Входные данные

Программа позволяет вводить исходные данные в двух форматах:

- готовую матрицу расстояний;

- набор координат точек, через которые проходит путь коммивояжера.

В последнем случае матрица расстояний высчитывается автоматически.

Ввести входные данные можно:

- с клавиатуры;

- из указанного текстового файла.

Координаты точек в файле должны располагаться в двух строках: в первой – координаты каждой точки по оси X, во второй – по оси Y.

Матрица расстояний задается построчно.

При вводе данных из файла, число точек находится автоматически. При вводе же с клавиатуры оно задается.

Выходные данные.

Все основные выходные данные, включая матрицы расстояний для каждой итерации, оценки ветвления и т.п., выводятся в файл output.res в текущем каталоге.

При наличии в текущем каталоге видеодрайвера egavga.bgi программа также покажет результат графически (при задании координат точек).

Пример.

Имеется четыре пункта, расстояние между которыми описано матрицей расстояний. Найти оптимальный (минимальный) замкнутый маршрут объезда городов.

¥ 13 12 4

13 ¥ 7 8

12 7 ¥ 5

4 8 5 ¥

Текст программы.

Program Traveller;

Uses Crt,Graph;

const

 N=30;

 CurrentN:word=N;

 BinMapSize:word=N;

 NoWay=-1;

type

 TVector=array [0..N] of single;

 TMap=array [0..N] of TVector;

 TPoint=record X:single;

Y:single;

 end;

 TPointVector=array [1..N] of TPoint;

var

 Map:TMap;

 BinMap:TMap;

 Points:TPointVector;

Procedure LoadPointsFromFile(FileName:string);

var

 f:text;

 i:word;

begin

 assign(f,FileName);

 {$I-}

 reset(f);

 {$I+}

 if IOResult<>0 then

begin

writeln( ,FileName,');

halt(1);

end;

 i:=1;

 while not EoLn(f) do

begin

read(f,Points[i].X);

inc(i);

end;

 CurrentN:=i-1;

 for i:=1 to CurrentN do

read(f,Points[i].Y);

 close(f);

end;

Procedure LoadPointsFromCon;

var i:word;

begin

 readln(CurrentN);

 for i:=1 to CurrentN do

begin

write('Point N',i,' X=');

readln(Points[i].x);

write('Point N',i,' Y=');

readln(Points[i].y);

end;

end;

Procedure ClearBitMap;

var i,j:word;

begin

 for i:=1 to CurrentN do

for j:=1 to CurrentN do

BinMap[i][j]:=0;

 BinMapSize:=CurrentN;

end;

Procedure PointsToMap;

var i,j:word;

begin

 for i:=1 to CurrentN do

begin

Map[0][i]:=i;

Map[i][0]:=i;

end;

 for i:=1 to CurrentN do

begin

for j:=1 to CurrentN do

if i<>j then

begin

Map[i][j]:=SQRT(SQR(abs(Points[i].X-Points[j].X))+SQR(abs(Points[i].Y-Points[j].Y)));

end else Map[i][j]:=NoWay;

end;

end;

Procedure LoadMapFromFile(FileName:string);

var f:text;

i,j:word;

k:single;

begin

 assign(f,FileName);

 {$I-}

 reset(f);

 {$I+}

 if IOResult<>0 then

begin

writeln(' "',FileName,'".');

halt(1);

end;

 i:=1;

 while not EOF(f) do

begin

Map[0][i]:=i;

Map[i][0]:=i;

j:=1;

while not EOLN(f) do

begin

read(f,k);

if i=j then k:=NoWay;

Map[i][j]:=k;

inc(j);

end;

inc(i);

readln(f);

end;

 CurrentN:=i-1;

 close(f);

end;

Function GetMarkIJ(M:TMap;i,j:word):single;

var i1,j1:word;

tmp:TVector;

k1,k2:single;

begin

 M[i][j]:=NoWay;

 k1:=0;

 k2:=0;

 for i1:=1 to CurrentN do

if M[i][i1]<>NoWay then

begin

k1:=M[i][i1];

break;

end;

 for i1:=1 to CurrentN do

if M[i1][j]<>NoWay then

begin

k2:=M[i1][j];

break;

end;

 for i1:=1 to CurrentN do

if (M[i][i1]<k1)and(M[i][i1]<>NoWay) then

k1:=M[i][i1];

 for i1:=1 to CurrentN do

if (M[i1][j]<k2)and(M[i1][j]<>NoWay) then

k2:=M[i1][j];

 GetMarkIJ:=k1+k2;

end;

Procedure GetHeaviestZero(M:TMap;var i,j:word;var q:single;CurrentN:word);

var

 i1,j1:word;

 max,m1:single;

 t:boolean;

begin

 max:=0;

 i:=0;J:=0;

 q:=0;

 t:=true;

 for i1:=1 to CurrentN do

begin

for j1:=1 to CurrentN do

if M[i1][j1]=0 then

begin

m1:=GetMarkIJ(M,i1,j1);

if t then

begin

  t:=false;

  max:=m1;

  i:=i1;

  j:=j1;

end;

if m1>max then

begin

  max:=m1;

  i:=i1;

  j:=j1;

end;

end;

end;

q:=max;

end;

Procedure ReduceMap(var M:TMap;CurrentN:word;var res:single);

var

i,j:word;

colm,rowm:single;

begin

 res:=0;

 for i:=1 to CurrentN do

begin

for j:=1 to CurrentN do

if M[i][j]<>NoWay then

begin

  rowm:=M[i][j];

  break;

end;

for j:=1 to CurrentN do

if M[i][j]<>NoWay then

begin

  if M[i][j]<rowm then rowm:=M[i][j];

end;

if rowm>0 then

begin

for j:=1 to CurrentN do

if Map[i][j]<>NoWay then

   Map[i][j]:=Map[i][j]-rowm;

res:=res+rowm;

end;

end;

 for j:=1 to CurrentN do

begin

colm:=0;

for i:=1 to CurrentN do

if Map[i,j]<>NoWay then

begin

  colm:=M[i][j];

  break;

end;

for i:=1 to CurrentN do

if M[i][j]<>NoWay then

begin

  if M[i][j]<colm then colm:=M[i][j];

end;

if colm>0 then

begin

for i:=1 to CurrentN do

if Map[i,j]<>NoWay then

  Map[i,j]:=Map[i,j]-colm;

res:=res+colm;

end;

end;

end;

Procedure PrintMap(M:TMap;toFile:byte;var f:text);

var i,j:word;

begin

 for i:=0 to CurrentN do

begin

for j:=0 to CurrentN do

begin

if M[i][j]<>NoWay then

begin

case toFile of

0:write(' ',M[i][j]:5:1);

1:write(f,' ',M[i][j]:5:1);

2:begin write(f,' ',M[i][j]:5:1); write(' ',M[i][j]:5:1); end;

end;

end else

begin

case toFile of

0:write('*':6);

1:write(f,'*':6);

2:begin write(f,'*':6); write('*':6); end;

end;

end;

end;

case toFile of

0:writeln;

1:writeln(f);

2:begin writeln(f); writeln; end;

end;

end;

end;

Procedure ShowPoints(k:single);

var i:word;

s:string;

begin

 for i:=1 to CurrentN do

begin

setcolor(Yellow);

circle(round(Points[i].X*k),round(Points[i].Y*k),2);

str(i,s);

setcolor(red);

outtextxy(round(Points[i].X*k)+2,round(Points[i].Y*k)+2,s);

end;

end;

var i,j:word;

out:text;

tmp:TVector;

Procedure PointToPointWay(M:TMap;var V:TVector);

var ind,j:word;

Procedure NextPoint(z:word;point:word);

var i:word;

begin

 for i:=1 to BinMapSize do

if (M[point][i]=1)and(i<>z) then

begin

V[ind]:=i;

inc(ind);

NextPoint(point,i);

end;

end;

begin

ind:=1;

NextPoint(0,1);

write(' 1 - ');

write(out,' 1 - ');

for j:=1 to ind-1 do

begin

write(V[j]:1:0,' - ');

write(OUT,V[j]:1:0,' - ');

end;

writeln(1:3);

writeln(OUT,1:3);

end;

Function AreConnected(p1,p2:word;B:TMap;CurrentN:word):boolean;

var l:word;

Procedure Next(predp,p:word);

var i:word;

begin

 for i:=1 to CurrentN do

 if (B[p][i]=1)and(i<>predp) then

if i<>p2 then

begin

Next(p,i);

Break;

end

else

begin

l:=p2;

Exit;

end;

end;

begin

 l:=0;

 Next(0,p1);

 if l=p2 then

AreConnected:=true else

AreConnected:=false;

end;

Procedure SetToInfinity(var M:TMap;i,j:word);

var i1,j1:word;

t:boolean;

begin

 t:=true;

 for j1:=1 to CurrentN do

if M[0][j1]>=j then break;

 if M[0][j1]<>j then t:=false;

 if t then

begin

for i1:=1 to CurrentN do

if M[i1][0]>=i then break;

if M[i1][0]<>i then t:=false;

end;

 if t then M[i1][j1]:=NoWay;

end;

Procedure ExcludeWays(var Map:TMap);

var i,j:word;

begin

 for i:=1 to BinMapSize-1 do

for j:=i+1 to BinMapSize do

begin

if AreConnected(i,j,BinMap,BinMapSize) then

begin

SetToInfinity(Map,i,j);

SetToInfinity(Map,j,i);

end;

end;

end;

Function GetPointNumX(n:word):word;

begin

 GetPointNumX:=round(Map[n][0]);

end;

Function GetPointNumY(n:word):word;

begin

 GetPointNumY:=round(Map[0][n]);

end;

Procedure CutMatrix(var M:TMap;i,j:word;var CurrentN:word);

var ie,je,s:single;

i1,j1:word;

tmp1:TMap;

begin

 tmp1:=M;

 ie:=M[i][0];

 je:=M[0][j];

 ExcludeWays(M);

 for i1:=0 to CurrentN do

for j1:=j to CurrentN-1 do M[i1][j1]:=M[i1][j1+1];

 for j1:=0 to CurrentN do

for i1:=i to CurrentN-1 do M[i1][j1]:=M[i1+1][j1];

 Dec(CurrentN);

end;

var tmp1,tmp2:TMap;

m1x,m2x:word;

m1y,m2y:word;

s1,q1:single;

NodeCost,NonCutted,Cutted:single;

k:char;

NoVisiblePoints:boolean;

fn:string;

label 1;

Procedure InitGraphicMode(path:string);

var d,m:integer;

begin

 d:=detect;

 Initgraph(d,m,path);

 if GraphResult<>0 then

begin

ClrScr;

writeln('');

writeln('“');

NoVisiblePoints:=true;

end;

end;

Procedure CloseGraphicMode;

begin

 CloseGraph;

end;

BEGIN

 assign(out,'output.res');

 rewrite(out);

 ClrScr;

 writeln('m');

 repeat

k:=readkey;

case k of

'1':

begin

writeln('‡Ђѓђ“‡ЉЂ ’Ћ—…Љ €‡ ”Ђ‰‹Ђ');

write(' ');

readln(fn);

LoadPointsFromFile(fn);

PointsToMap;

NoVisiblePoints:=false;

end;

'2':

begin

writeln('‡Ђѓђ“‡ЉЂ ЊЂ’ђ€–› ђЂ‘‘’ЋџЌ€‰ €‡ ”Ђ‰‹Ђ');

write(' ');

readln(fn);

LoadMapFromFile(fn);

NoVisiblePoints:=true;

end;

'3':

begin

writeln('‚‚Ћ„ ’Ћ—…Љ');

write(' ');

LoadPointsFromCon;

PointsToMap;

NoVisiblePoints:=false;

end;

{ '4':

begin

writeln('TYPING WAYS-MATRIX');

write('Enter points count: ');

end; }

'5':

begin

Halt(0);

end;

end;

 until (k in ['1','2','3','5']);

 ClearBitMap;

 if not NoVisiblePoints then

 InitGraphicMode('');

 if not NoVisiblePoints then

 ShowPoints(2);

 if not NoVisiblePoints then

 readkey;

 writeln(out,' ');

 writeln(out,'Ґв®¤® ўҐвўҐ© Ё Ја ­Ёж.');

 writeln(out);

 writeln(out,'');

 writeln(out);

 PrintMap(Map,1,out);

 writeln(out);

 ReduceMap(Map,CurrentN,NodeCost);

1:

 PrintMap(Map,1,out);

 writeln(out);

 GetHeaviestZero(Map,i,j,q1,CurrentN);

 NonCutted:=NodeCost+q1;

 tmp1:=Map;

 tmp1[i][j]:=NoWay;

 tmp2:=Map;

 m1x:=GetPointNumX(i);

 m1y:=GetPointNumY(j);

 BinMap[m1x,m1y]:=1;

 BinMap[m1y,m1x]:=1;

 CutMatrix(tmp2,i,j,CurrentN);

 ReduceMap(tmp2,CurrentN,s1);

 Cutted:=NodeCost+s1;

 writeln(out,'‘',GetPointNumY(j),'.');

 writeln(out,' writeln(out,'----------------------------');

 writeln(out,'ЋжҐ­Є 㧫 = ',NodeCost:5:6);

 writeln(out,'ЋжҐ­Є {',m1x,',',m1y, '} = ',Cutted:5:6);

 writeln(out,'ЋжҐ­Є ­Ґ {',m1x,',',m1y,'} = ',NonCutted:5:6);

 writeln(out,'----------------------------');

 if (NonCutted<Cutted)and(CurrentN>1) then

begin

Inc(CurrentN);

writeln(out,'',GetPointNumY(j),'] Ґ­миҐ, ',#13#10,

         [',GetPointNumX(i),'-',GetPointNumY(j),'] ...');

Map:=tmp1;

BinMap[GetPointNumX(i),GetPointNumY(j)]:=0;

BinMap[GetPointNumY(j),GetPointNumX(i)]:=0;

NodeCost:=NonCutted;

end else

 if (NonCutted>Cutted) then

begin

writeln(out,'',GetPointNumY(j),'] Ґ­миҐ, ',#13#10,

 [',GetPointNumX(i),'-',GetPointNumY(j),'] ...');

writeln(out,' ',GetPointNumY(j),'.');

if not NoVisiblePoints then

line(round(Points[GetPointNumX(i)].x*2),round(Points[GetPointNumX(i)].y*2),

   round(Points[GetPointNumY(j)].x*2),round(Points[GetPointNumY(j)].y*2));

Map:=tmp2;

NodeCost:=Cutted;

end else

begin

writeln(out,' [',GetPointNumX(i),'-',GetPointNumY(j),'] ',#13#10,

         [',GetPointNumX(i),'-',GetPointNumY(j),']

 [',GetPointNumX(i),'-',GetPointNumY(j),'] ...');

writeln(out,' ',GetPointNumY(j),'.');

if not NoVisiblePoints then

line(round(Points[GetPointNumX(i)].x*2),round(Points[GetPointNumX(i)].y*2),

   round(Points[GetPointNumY(j)].x*2),round(Points[GetPointNumY(j)].y*2));

Map:=tmp2;

NodeCost:=Cutted;

end;

 writeln(out);

 ReduceMap(Map,CurrentN,s1);

 if CurrentN>1 then goto 1;

writeln(out,'',GetPointNumY(1),']. ‚лЎЁа Ґ ҐЈ®.');

  writeln(out);

writeln(out,'');

if not NoVisiblePoints then

line(round(Points[GetPointNumX(1)].x*2),round(Points[GetPointNumX(1)].y*2),

   round(Points[GetPointNumY(1)].x*2),round(Points[GetPointNumY(1)].y*2));

 if not NoVisiblePoints then

 readkey;

 if not NoVisiblePoints then

 CloseGraphicMode;

 writeln(out,'');

 PointToPointWay(BinMap,tmp);

 Writeln('‘''output.res'' ');

close(out);

END.

Входные данные из файла Z1

0 13 12 4

13 0 7 8

12 7 0 5

4 8 5 0

Результаты расчета ,записанные в файл OUTPUT.REZ

Решение задачи коммивояжера

методом ветвей и границ.

Исходная матрица расстояний:

0.0 1.0 2.0 3.0 4.0

1.0 * 13.0  12.0 4.0

2.0 13.0 * 7.0 8.0

3.0 12.0 7.0 * 5.0

4.0 4.0 8.0 5.0 *

0.0 1.0 2.0 3.0 4.0

1.0 * 7.0 8.0 0.0

2.0 6.0 * 0.0 1.0

3.0 7.0 0.0 * 0.0

4.0 0.0 2.0 1.0    *

Самый "тяжелый" нуль получен в строке 1, столбце 4.

Разбиваем множество решений и производим оценку:

----------------------------

Оценка узла = 22.000000

Оценка {1,4} = 29.000000

Оценка не {1,4} = 29.000000

Оценка множества ребер, содержащих [1-4]

и ребер, не содержащих [1-4] равны, поэтому выбирать можно любое.

Выберем путь [1-4] ...

Вычеркиваем строку 1 и столбец 4.

0.0 1.0 2.0 3.0

2.0 0.0 * 0.0

3.0 1.0 0.0 *

4.0 * 1.0 0.0

Самый "тяжелый" нуль получен в строке 3, столбце 2.

Разбиваем множество решений и производим оценку:

----------------------------

Оценка узла = 29.000000

Оценка {3,2} = 29.000000

Оценка не {3,2} = 31.000000

----------------------------

Оценка множества ребер, содержащих [3-2] меньше,

поэтому выбираем путь [3-2] ...

Вычеркиваем строку 3 и столбец 2.

0.0 1.0 3.0

2.0 0.0 *

0.0 1.0 3.0

2.0 0.0 *

4.0 * 0.0

Самый "тяжелый" нуль получен в строке 2, столбце 1.

Разбиваем множество решений и производим оценку:

----------------------------

Оценка узла = 29.000000

Оценка {2,1} = 29.000000

Оценка не {2,1} = 29.000000

----------------------------

Оценка множества ребер, содержащих [2-1]

и ребер, не содержащих [2-1] равны, поэтому выбирать можно любое.

Выберем путь [2-1] ...

Вычеркиваем строку 2 и столбец 1.

Остался единственный путь [4-3]. Выбираем его.

Алгоритм поиска оптимального пути успешно завершен.

Один из возможных поточечных обходов следующий:

1 - 2 - 3 - 4 - 1.

Варианты заданий.