CodeNet / Приложения / Алгоритмы / Математика

Задача коммивояжёра


 Msg  : 8 из  2602 -1 *37
 From : Michail Svarichevsky           2:452/64         Срд 13 Сен 00 01:37
 To   : Lvov  Igor                                      Срд 13 Сен 00 16:30
 Subj : Задача коммивояжёра!

Как поживаете, Lvov ? 

 Я заметил, что в  Вторник Сентябрь 12 2000,  Lvov Igor писал: 

 LI>      Добрый дядя рассказал студентам  о таких людях, которым нужно  за 
 LI> минимальные деньги  посетить n городов, чтобы  начать и закончить своё 
 LI> путешествие в  одном и том же городе.  Есть матрица стоимости и  всё 
 LI> остальное... 
 LI>      Буду рад всем откликам, понимаю  Паскаль и Русский языки. 

Все очень просто. Эта  задача не имеет решения :)...  кроме переборного - т.е 
рекурсию в руки и вперед.  Конечно можно оптимизировать(сначала  выбирать те 
ребра, которые подешевле).  Есть еще метод ветвей и  границ,но он довольно сложен  
- у меня 299 строк(может  у кого и меньше), и  генетические алгоритмы, но они  не 
точны. 
Вот тебе метод ветвей  и границ: 

PS. Привет твоей Оксане!  :) 
--- Тут начинается файл  vetvi.pas --- 
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<ochered[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. 
--- А здесь vetvi.pas  кончается --- 

С уважением, Сваричевский  Михаил 

--- GoldED/W32 3.0.1-asa9  SR3 
 * Origin: Fido,C++Builder,QuakeI-Rulez,QuakeII,III  - half Rulez! (2:452/64)

Оставить комментарий

Это слишком упрощенная задача!
Я делал - н посылок развести в н адресов по оптимальному маршруту, учитывая, что при движении дороги погут менять свой вес. Задается точка начала пути.
А вообще, кому впадло разбираться в чужом коде, скажу, что алгоритм, который правда немного усовершенствовать пришлось, наз. Алгоритм Флойда

Кому надo прога - my_garbage@ukr.net

Ваш аккаунт

Последние темы форума

Почтовая рассылка

Задача коммивояжёра

Оставить комментарий

Комментарии

Комментарий: можно использовать BB-коды Максимальная длина комментария - 4000 символов.	CodeNet ВКонтакте Facebook Twitter Google Яндекс Чтобы оставить комментарий, необходимо авторизоваться. Можно ввести логин и пароль, или авторизоваться через социальные сети.