Задача коммивояжера. Метод ветвей и границ
Категория: Delphi/Pascal
2011-12-18 15:46:09
Имeется n городов (с указанной ценой пути из каждого i -ого в каждый j город),коммивояжеру необходимо посетить все города и вернуться в исходный, так чтобы цена всего пути была минимальной.
code: #delphi
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.
автор: kommunist
Поделиться: