Имeется n городов (с указанной ценой пути из каждого i -ого в каждый j город),коммивояжеру необходимо посетить все города и вернуться в исходный, так чтобы цена всего пути была минимальной.
program vetvi;
const
maxmatrix = 1000;
maxsize = 200;
type
linear = array [1 .. 10000] of integer;
label skip;
var
matrix: array [1 .. 1000] of pointer;
n: integer;
sizeofm: word;
q, w, e, r: integer;
start_m: integer;
sm: ^linear;
bestx, besty: integer;
bz: integer;
ochered: array [1 .. 1000] of record id: integer;
ocenka: integer;
end;
nochered:
integer;
workm, workc: integer;
leftm, rightm: integer;
first, last: integer;
best:
integer;
bestmatr:
array [1 .. maxsize] of integer;
bestmatr1:
array [1 .. maxsize] of integer;
curr:
integer;
procedure swapo(a, b: integer);
begin
ochered[1000] := ochered[a];
ochered[a] := ochered[b];
ochered[b] := ochered[1000];
end;
procedure addochered(id, ocenka: integer);
var
curr: integer;
begin
inc(nochered);
ochered[nochered].id := id;
ochered[nochered].ocenka := ocenka;
{ Uravnoveshivanie ocheredi }
curr := nochered;
while true do
begin
if curr = 1 then
break;
if ochered[curr].ocenka < ochered[curr div 2].ocenka then
begin
swapo(curr, curr div 2);
curr := curr div 2;
end
else
break;
end;
end;
procedure getochered(var id, ocenka: integer);
var
curr: integer;
begin
id := ochered[1].id;
ocenka := ochered[1].ocenka;
ochered[1] := ochered[nochered];
dec(nochered);
curr := 1;
while true do
begin
if (curr * 2 + 1 > nochered) then
break;
if (ochered[curr * 2].ocenka < ochered[curr].ocenka) or
(ochered[curr * 2 + 1].ocenka[curr].ocenka) then
begin
if ochered[curr * 2].ocenka > ochered[curr * 2 + 1].ocenka then
begin
swapo(curr * 2 + 1, curr);
curr := curr * 2 + 1;
end
else
begin
swapo(curr * 2, curr);
curr := curr * 2;
end;
end
else
break;
end;
end;
function getid: integer;
var
q: integer;
qw: ^linear;
begin
if memavail < 10000 then
begin
q := ochered[nochered].id;
{ exit; }
end
else
begin
for q := 1 to maxmatrix do
if matrix[q] = nil then
break;
getmem(matrix[q], sizeofm);
end;
qw := matrix[q];
fillchar(qw^, sizeofm, 0);
getid := q;
end;
procedure freeid(id: integer);
begin
freemem(matrix[id], sizeofm);
matrix[id] := nil;
end;
function i(x, y: integer): integer;
begin
i := (y - 1) * n + x + 1;
end;
function simplize(id: integer): integer;
var
q, w: integer;
t: ^linear;
add: integer;
min: integer;
begin
t := matrix[id];
add := 0;
for q := 1 to n do
begin
min := maxint;
for w := 1 to n do
if t^[i(w, q)] < > -1 then
if min > t^[i(w, q)] then
min := t^[i(w, q)];
if min <> 0 then
for w := 1 to n do
if t^[i(w, q)] < > -1 then
dec(t^[i(w, q)], min);
if min > 32000 then
min := 0;
inc(add, min);
end;
for q := 1 to n do
begin
min := maxint;
for w := 1 to n do
if t^[i(q, w)] < > -1 then
if min > t^[i(q, w)] then
min := t^[i(q, w)];
if min <> 0 then
for w := 1 to n do
if t^[i(q, w)] < > -1 then
dec(t^[i(q, w)], min);
if min > 32000 then
min := 0;
inc(add, min);
end;
simplize := add;
end;
function bestziro(id: integer): integer;
var
t: ^linear;
q, w, e, x, y: integer;
min1, min2: integer;
l1, l2: array [1 .. maxsize] of integer;
begin
t := matrix[id];
fillchar(l1, sizeof(l1), 0);
fillchar(l2, sizeof(l2), 0);
for q := 1 to n do
begin
min1 := maxint;
min2 := maxint;
for w := 1 to n do
if t^[i(w, q)] < > -1 then
begin
if min2 > t^[i(w, q)] then
min2 := t^[i(w, q)];
if min1 > min2 then
begin
e := min1;
min1 := min2;
min2 := e;
end;
end;
if min1 <> 0 then
min2 := 0;
if min2 > 32000 then
min2 := 0;
l2[q] := min2;
end;
for q := 1 to n do
begin
min1 := maxint;
min2 := maxint;
for w := 1 to n do
if t^[i(q, w)] < > -1 then
begin
if min2 > t^[i(q, w)] then
min2 := t^[i(q, w)];
if min1 > min2 then
begin
e := min1;
min1 := min2;
min2 := e;
end;
end;
if min1 <> 0 then
min2 := 0;
if min2 > 32000 then
min2 := 0;
l1[q] := min2;
end;
bz := -32000;
bestx := 0;
besty := 0;
for y := n downto 1 do
for x := 1 to n do
if (t^[i(x, y)] = 0) then
if l1[x] + l2[y] > bz then
begin
bestx := x;
besty := y;
bz := l1[x] + l2[y];
end;
bestziro := bz;
end;
begin
assign(input, 'input.txt');
assign(output, 'vetvi.out');
reset(input);
rewrite(output);
nochered := 0;
read(n);
sizeofm := n * (n + 2) * 2 + 2;
start_m := getid;
sm := matrix[start_m];
for q := 1 to n do
for w := 1 to n do
read(sm^[i(w, q)]);
addochered(start_m, 0);
{ ;
bestziro(start_m); }
{ Sobstvenno reshenie }
best := maxint;
while true do
begin
if nochered = 0 then
break;
getochered(workm, workc);
{ process MATRIX }
inc(workc, simplize(workm));
if workc > best then
goto skip;
sm := matrix[workm];
if sm^[1] = n - 1 then
begin
best := workc;
for q := 1 to n do
begin
bestmatr[q] := sm^[i(q, n + 2)];
bestmatr1[q] := sm^[i(q, n + 1)];
end;
goto skip;
end;
q := bestziro(workm);
if q = -32000 then
goto skip;
{ Pravaia vetka }
if (bestx = 0) or (besty = 0) then
goto skip;
rightm := getid;
move(matrix[workm]^, matrix[rightm]^, sizeofm);
sm := matrix[rightm];
sm^[i(bestx, besty)] := -1;
addochered(rightm, workc + q);
{ Levaia vetka }
leftm := getid;
move(matrix[workm]^, matrix[leftm]^, sizeofm);
sm := matrix[leftm];
{ Dobavliaetsia rebro iz bestx v besty }
inc(sm^[1]);
sm^[i(bestx, n + 2)] := besty;
sm^[i(besty, n + 1)] := bestx;
first := bestx;
last := besty;
if sm^[1] < > n - 1 then
begin
while true do
begin
if sm^[i(last, n + 2)] = 0 then
break;
last := sm^[i(last, n + 2)];
end;
while true do
begin
if sm^[i(first, n + 1)] = 0 then
break;
first := sm^[i(first, n + 1)];
end;
sm^[i(last, first)] := -1;
sm^[i(first, last)] := -1;
sm^[i(besty, bestx)] := -1;
end;
for w := 1 to n do
begin
sm^[i(w, besty)] := -1;
sm^[i(bestx, w)] := -1;
end;
addochered(leftm, workc);
skip:
{ Free Matrix }
freeid(workm);
end;
{ freeid(start_m); }
if best = maxint then
begin
writeln('Путь не существует');
end
else
begin
writeln('Длина пути:', best);
for q := 1 to n do
if bestmatr[q] = 0 then
break;
e := q;
for curr := 1 to n do
if bestmatr[curr] = q then
break;
while true do
begin
write(curr, ' ');
curr := bestmatr1[curr];
if curr = 0 then
begin
writeln(e);
break;
end;
end;
end;
close(input);
close(output);
end.