Лабораторная работа №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.

 

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

№1	х	10	20	25	40	40	60	70	60	90	30	40	80	75	60	110
	у	130	140	125	140	120	140	130	110	120	60	55	90	45	20	45

№2	х	40	70	90	80	10	15	20	10	95	90	70	60	10	30	5	20
	у	140	120	120	110	90	80	70	60	70	60	60	55	45	45	30	10

№3	х	130	120	110	110	30	5	20	45	60	75	80	30	80	70	90	80
	у	25	15	30	45	40	30	15	20	90	95	90	60	140	130	120	110

№4	х	20	10	40	70	70	120	110	120	5	10	35	65	120	110	105	130	40	80	60
	у	70	60	55	95	85	80	70	60	30	20	20	40	40	30	20	25	120	140	110

№5	х	20	35	60	75	95	90	70	40	10	30	40	140	130	110	130	105	120
	у	10	20	45	45	40	110	130	120	45	60	53	120	110	50	45	20	15

№6	х	30	40	60	95	85	75	70	65	110	120	10	20	15	30	40	60	70
	у	60	50	90	60	65	45	30	5	10	15	90	95	80	80	120	140	130

№7	х	80	90	110	110	120	10	25	20	40	15	10	20	75	95	70	60	85	90
	у	110	120	130	140	120	125	130	125	120	90	80	95	45	40	30	30	5	5

№8	х	40	20	25	10	65	80	95	110	130	120	60	55	65	50	70
	у	70	75	70	60	10	15	20	50	45	55	90	85	80	95	85

№9	х	10	30	20	5	20	10	110	125	140	140	140	120	25	40	60	20	10
	у	45	45	40	30	25	15	60	65	80	140	120	120	125	140	140	130	125

№10	х	120	110	115	25	30	40	40	15	30	40	35	140	120	105	110	125
	у	125	130	120	120	140	140	140	90	85	95	90	55	60	60	70	65

№11	х	40	50	60	110	120	130	103	110	10	20	25	40	10	30	25	20	30
	у	35	40	45	10	15	25	20	30	130	140	125	140	60	55	50	60	65

№ 12	х	30	40	25	110	130	120	125	110	130	120	110	135	10	20	25	40	40	20
	у	45	50	40	140	130	135	140	45	45	40	30	30	130	135	125	140	125	145

№13	х	15	30	40	20	40	10	25	30	30	95	80	90	70	5	10	20	20	35
	у	80	80	90	70	75	135	140	125	140	90	90	80	85	30	15	25	10	20

№ 14	х	45	45	40	40	30	25	15	10	20	110	110	130	120	90	110	110	120	130
	у	10	30	20	35	5	130	120	110	125	70	85	95	80	120	140	130	120	120

№15	х	55	60	60	70	70	70	70	90	90	120	130	140	130	5	20	20	10	5
	у	40	30	10	40	20	95	85	80	60	120	130	140	110	30	25	10	15	30

№ 16	х	120	140	110	125	105	60	65	80	90	40	40	60	80	70	60	110	105	110	120	130	130
	у	80	80	70	70	60	20	5	10	20	140	120	140	140	130	110	30	20	10	5	25	45

№17	х	70	70	60	60	80	70	80	90	90	85	5	15	10	20	110	120	115	120
	у	125	110	105	120	140	130	90	95	80	70	20	20	150	25	50	60	60	65

№18	х	130	140	125	140	120	15	20	30	40	20	40	60	70	70	80	85	10	30	20	35	30
	у		20	25	40	40	80	80	80	90	70	70	90	95	100	90	95	45	45	50	50	55

№19	х	60	55	60	70	70	70	60	55	70	80	15	20	10	30	120	130	110	120
	у	120	140	110	125	130	80	70	60	60	80	10	35	20	5	40	45	30	40

№20	х	15	30	40	20	40	10	30	20	35	40	110	110	120	130	120	130	125	130
	у	70	60	80	75	75	40	45	40	45	50	140	130	120	110	10	25	15	20

№21	х	45	40	45	40	70	60	65	80	90	20	25	40	40	60	20	140	140	130	130
	у	60	65	70	80	30	20	5	10	20	140	125	140	120	140	140	120	140	130	120

№22	х	5	5	10	5	15	70	80	75	60	100	105	110	120	125	125	120	130
	у	5	10	15	20	20	10	15	15	20	90	100	85	90	105	105	60	65

№23	х	120	140	105	125	30	40	60	40	10	20	110	115	120	130	65	60	70	65	70
	у	60	55	60	70	60	55	90	70	60	70	105	110	100	115	5	20	15	25	30

№24	х	30	20	35	5	20	10	20	35	110	120	115	125	140	95	90	80	70	60
	у	45	40	40	3	25	15	10	20	60	50	65	60	50	90	80	90	95	55

№25	х	55	50	70	65	70	10	20	15	30	40	20	40	100	130	120	140	80	90	60
	у	140	130	120	135	130	90	90	80	80	80	70	70	80	90	90	95	10	20	20