Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

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

Показать новые сообщения »

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

Подписчиков: 11650
Последний выпуск: 19.06.2015

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


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)

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

Комментарий:
можно использовать BB-коды
Максимальная длина комментария - 4000 символов.
 

Комментарии

1.
48K
03 мая 2009 года
aleksanr
4 / / 03.05.2009
Мне нравитсяМне не нравится
3 мая 2009, 13:37:21
Здраствуйте. А можете выложить код на языке с++ для реализации этой задачи? Заранее благодарен.
2.
48K
03 мая 2009 года
aleksanr
4 / / 03.05.2009
Мне нравитсяМне не нравится
3 мая 2009, 13:36:17
Здраствуйте.А можете выложить реализацию этой программы на языке с++? Заранее спасибо.
3.
Аноним
Мне нравитсяМне не нравится
8 мая 2006, 10:40:36
задача то хороша, но на програмном языке плохо для новичков понимаетса алгоритм!
4.
Аноним
Мне нравитсяМне не нравится
8 марта 2006, 14:29:16
Все конечно замечательно, но как должны выглядеть входной и выходной файлы?
5.
Аноним
Мне нравитсяМне не нравится
15 июня 2005, 11:36:11
К СОЖАЛЕНИЮ, ИНТЕРЕСНАЯ ПРОГА ПОМЕРЛА ПОСЛЕ ФОРМАТИРОВАНИЯ МОЕГО ВИНТА :(
6.
Аноним
Мне нравитсяМне не нравится
12 апреля 2005, 14:02:01
К солжадению интересная прога померла после форматирования моего винта :(
7.
Аноним
Мне нравитсяМне не нравится
27 октября 2004, 08:18:13
Где можно взять input.txt и vetvi.out
8.
Аноним
Мне нравитсяМне не нравится
10 августа 2004, 15:09:17
Это слишком упрощенная задача!
Я делал - н посылок развести в н адресов по оптимальному маршруту, учитывая, что при движении дороги погут менять свой вес. Задается точка начала пути.
А вообще, кому впадло разбираться в чужом коде, скажу, что алгоритм, который правда немного усовершенствовать пришлось, наз. Алгоритм Флойда

Кому надo прога - my_garbage@ukr.net
Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог