Навигация
Главная
Поиск
Форум
FAQ's
Ссылки
Карта сайта
Чат программистов

Статьи
-Delphi
-C/C++
-Turbo Pascal
-Assembler
-Java/JS
-PHP
-Perl
-DHTML
-Prolog
-GPSS
-Сайтостроительство
-CMS: PHP Fusion
-Инвестирование

Файлы
-Для программистов
-Компонеты для Delphi
-Исходники на Delphi
-Исходники на C/C++
-Книги по Delphi
-Книги по С/С++
-Книги по JAVA/JS
-Книги по Basic/VB/.NET
-Книги по PHP/MySQL
-Книги по Assembler
-PHP Fusion MOD'ы
-by Kest
Professional Download System
Реклама
Услуги

Автоматическое добавление статей на сайты на Wordpress, Joomla, DLE
Заказать продвижение сайта
Программа для рисования блок-схем
Инженерный калькулятор онлайн
Таблица сложения онлайн
Популярные статьи
OpenGL и Delphi... 65535
Форум на вашем ... 65535
HACK F.A.Q 65535
Гостевая книга ... 65535
Содержание сайт... 65535
Вызов хранимых ... 65535
Эмулятор микроп... 65535
Бип из системно... 61865
Организация зап... 59253
Invision Power ... 59109
Приложение «Про... 58010
Модуль Forms 57411
Оператор выбора... 57274
Подключение Mic... 56714
Создание отчето... 56537
ТЕХНОЛОГИИ ДОСТ... 52754
Программируемая... 50436
Пример работы с... 48598
Имитационное мо... 48303
21 ошибка прогр... 43154
Реклама
Сейчас на сайте
Гостей: 11
На сайте нет зарегистрированных пользователей

Пользователей: 13,030
новичок: SLAVA_747
Новости
Реклама
Выполняем курсовые и лабораторные по разным языкам программирования
Подробнее - курсовые и лабораторные на заказ
Delphi, Turbo Pascal, Assembler, C, C++, C#, Visual Basic, Java, GPSS, Prolog, 3D MAX, Компас 3D
Заказать программу для Windows Mobile, Symbian

Лабораторная работа по динамическим спискам на Turbo Pascal (удаление ду...
Компьютерный магазин на Turbo Pascal (База данных) + Пояснительная записка
моделирование процесса поступления заявок в ЭВМ на GPSS + Пояснительная ...

Реклама

Просмотр темы
.:: CodingRUS ::. программирование по-русски на Delphi, C++, PHP, Prolog, GPSS | Программирование на Delphi | Синтаксис
Автор Транспортная задача
Evgen
Пользователь

Сообщений: 4
Зарегистрирован: 27.03.11
Опубликовано 22-10-2011 17:31
ВСЕМ привет. У меня возникла проблемка в написании программы на тему "Транспортная задача" . Мне нужно найти начальный опорный план методом min элементов. Пытаюсь сделать уже как неделю, того результата что надо не получается. HELP PLEASE
Послать приватное сообщение
Автор RE: Транспортная задача
Evgen
Пользователь

Сообщений: 4
Зарегистрирован: 27.03.11
Опубликовано 24-10-2011 08:11
неужели никто не знает ????
Послать приватное сообщение
Автор RE: Транспортная задача
Kest
Супер Администратор

Avatar пользователя

Сообщений: 226
Зарегистрирован: 01.01.70
Опубликовано 24-10-2011 16:43
Evgen написал:
неужели никто не знает ????


на паскале где то видел код

Program transportnaj_zadatsha;

Uses Crt;

Label l1;

Const N=6;

n1=7; n2=7;

Sa:longint=0;

Sb:longint=0;

Type predpr=Array [1..N] of longint;

rasp=Array [1..N,1..N] of longint;

Var A,B,alfa,betta,B_d,x:predpr;

c,p:rasp;

f,f0,x_min,Sp:longint;

Nt,x_p,r,r_min,ki,kj,Na,Nb,h,l,i,j:byte;

d:char;

u:Array[1..N*N] of byte;



Procedure Nul (var a:predpr); {обнуляет массив}

var i:byte;

Begin

for i:=1 to N do a[i]:=0;

End;



Procedure PrintS (x,y:byte; s:string; c:byte);

Begin {вывод строки s}

TextColor©;

GotoXY(x,y);

Write(s);

End;



Procedure Print (x,y:byte; n:byte; a:longint; c:byte);

Begin {вывод числа a}

TextColor©;

GotoXY(x,y); Write(' ':n);

GotoXY(x,y); Write(a);

End;



Procedure Rid (var x:longint; y:byte); {проседура ввода числа x}

var i:integer;

s:string;

c:char;

j,k:byte;

Begin

s:=''; i:=1;

TextColor(11);

Repeat

c:=ReadKey;

Case ord© of

48..57: begin s:=s+c;

Write©;

inc(i);

end;

8: if i>1 then begin dec(i);

Delete(s,i,1);

Write(chr(8),' ',chr(8));

end;

end;

j:=WhereX;

GotoXY(60,1); ClrEOL;

if i>y then begin

TextColor(4);

Write('Не более ');

for k:=1 to y-1 do Write('9');

TextColor(11);

end;

GotoXY(j,1);

Until (ord©=13) and (i<y+1);

val(s,x,i);

End;



Procedure goriz (a,b,c,d,e:char); {Процедуры goriz, wertic}

var i,j:byte; {и Tabl выводят таблицу}

Begin

Write(a);

for i:=1 to n2 do Write(b);

Write©;

for i:=1 to Nb do begin

for j:=1 to n1 do Write(b);

if i<>Nb then Write(d) else Write©;

end;

for i:=1 to 4 do Write(b);

Write(e);

End;



Procedure wertic;

var i:byte;

Begin

Write('¦',' ':n2,'¦');

for i:=1 to Nb-1 do Write(' ':n1,'¦');

WriteLn(' ':n1,'¦',' ' :4,'¦');

End;



Procedure Tabl;

Begin

ClrScr;

TextColor(1);

h:=6+Na*3;

l:=14+Nb*7;

GotoXY(1,3);

for i:=3 to h do wertic;

GotoXY(1,2);

goriz('+','-','-','-','+');

for i:=1 to Na+1 do begin

GotoXY(1,i*3+2);

if (i=1) or (i=Na+1)

then goriz('¦','-','+','+','¦')

else goriz('+','-','+','+','¦');

end;

GotoXY(1,h+1);

goriz('+','-','-','-','+');

TextColor(9);

for i:=1 to Na do begin

GotoXY(5,i*3+3);

Write('A',i);

end;

for i:=1 to Nb do begin

GotoXY(i*(n1+1)+n2-2,3);

Write('B',i);

end;

l:=Nb*(n1+1)+n2+3;

h:=Na*3+6;

PrintS(4,3,'\Bj',9);

PrintS(4,4,'Ai\',9);

PrintS(1,1,'Таблица N1',14);

PrintS(l,4,'alfa',9);

PrintS(3,h,'betta',9);

End;



Procedure W_W (var a:predpr; b:byte; c:char); {Ввод в таблицу}

var i,l,m:byte; {кол-ва продукции}

Begin {поставщ. и потреб.}

for i:=1 to b do begin

TextColor(3);

GotoXY(32,1);

ClrEOL;

Write(c,i,'= ');

Rid(a[i],n1);

TextColor(14);

Case c of

'A': GotoXY(n2-trunc(ln(a[i])/ln(10)),i*3+4);

'B': GotoXY(n2+i*(n1+1)-trunc(ln(a[i])/ln(10)),4);

end;

Write(a[i]);

end;

End;



Function FF:longint; {Вычисление стоимости плана}

var i,j:byte;

f:longint;

Begin

f:=0;

for i:=1 to Na do

for j:=1 to Nb do

if p[i,j]>0 then inc(f,c[i,j]*p[i,j]);

GotoXY(65,Nt+2);

TextColor(10);

Write('F',Nt,'=',f);

FF:=f;

End;



Function a_b:boolean; {Расчет потенциалов}

var k,i,j:byte; {alfa и betta}

Z_a,Z_b:predpr;

d:boolean;

Begin

Nul(Z_a); Nul(Z_b);

alfa[1]:=0; Z_a[1]:=1; k:=1;

Repeat

d:=1=1;

for i:=1 to Na do

if Z_a[i]=1 then

for j:=1 to Nb do

if (p[i,j]>-1) and (Z_b[j]=0) then begin

Z_b[j]:=1;

betta[j]:=c[i,j]-alfa[i];

inc(k);

d:=1=2;

end;

for i:=1 to Nb do

if Z_b[i]=1 then

for j:=1 to Na do

if (p[j,i]>-1) and (Z_a[j]=0) then begin

Z_a[j]:=1;

alfa[j]:=c[j,i]-betta[i];

inc(k);

d:=1=2;

end;

Until (k=Na+Nb) or d;

if d then begin

i:=1;

While Z_a[i]=1 do inc(i);

j:=1;

While Z_b[j]=0 do inc(j);

p[i,j]:=0;

Print((j+1)*(n1+1)+n2-8,i*3+4,1,p[i,j],7);

end;



a_b:=d;

End;



Procedure W_p; {Вывод плана распределения}

var i,j,h,l,k:byte;

c_max:longint;

Begin

k:=0;

for i:=1 to Na do begin

h:=i*3+4;

for j:=1 to Nb do begin

l:=j*(n1+1)+n2-5;

GotoXY(l,h);

Write(' ':n1);

if p[i,j]>0 then begin

inc(k);

Print(l-trunc(ln(p[i,j])/ln(10))+5,h,1,p[i,j],14);

end

else if p[i,j]=0 then begin

Print(l+n1-2,h,1,p[i,j],14);

inc(k);

end;

end;

end;



While a_b do inc(k);



if k>Na+Nb-1 then PrintS(40,1,'k > n+m-1',12);

End;



Function kkk(var ki,kj:byte):integer; {Расчет коэф. k}

var i,j:byte; {в свободных клетках}

k,k_min:integer;

b:boolean;

Begin

b:=1=1;

for i:=1 to Na do

for j:=1 to Nb do

if p[i,j]=-1 then begin

k:=c[i,j]-alfa[i]-betta[j];

if b then begin

b:=1=2;

ki:=i; kj:=j; k_min:=k;

end else

if k<k_min then begin

k_min:=k;

ki:=i; kj:=j;

end;

TextColor(6);

GotoXY(j*(n1+1)+n2-5,i*3+4);

Write('(',k,')');

end;

if k_min<0 then PrintS(kj*(n1+1)+n2,ki*3+4,'X',12);

kkk:=k_min;

End;



Procedure div_mod(c:byte; var a,b:byte); {Перевод}

Begin {одномерного массива}

b:=c mod Nb; a:=c div Nb +1; {в двумерный}

if b=0 then begin

b:=Nb; dec(a);

end;

End;



Procedure Rek(Xi,Yi:byte; var z:boolean; var c:byte);

var i,j:byte;

Begin {Рекурсивная процедура.}

z:=1=2; {Определяет контур перемещения}

Case c of

1: for i:=1 to Na do

if i<>Xi then

if p[i,Yi]>-1 then begin

if u[(i-1)*Nb+Yi]=0 then begin

u[(Xi-1)*Nb+Yi]:=(i-1)*Nb+Yi;

c:=2;

Rek(i,Yi,z,c);

if z then exit;

end;

end

else if (i=ki) and (Yi=kj) then begin

u[(Xi-1)*Nb+Yi]:=(ki-1)*Nb+kj;

z:=not z;

exit;

end;

2: for i:=1 to Nb do

if i<>Yi then

if p[Xi,i]>-1 then begin

if u[(Xi-1)*Nb+i]=0 then begin

u[(Xi-1)*Nb+Yi]:=(Xi-1)*Nb+i;

c:=1;

Rek(Xi,i,z,c);

if z then exit;

end;

end

else if (Xi=ki) and (i=kj) then begin

u[(Xi-1)*Nb+Yi]:=(ki-1)*Nb+kj;

z:=not z;

exit;

end;

end;

u[(Xi-1)*Nb+Yi]:=0;

c:=c mod 2 +1;

End;



Procedure kontur; {Определяет контур перемещения}

var i,j,k,mi,mj,l:byte;

z:boolean;

p_m:longint;

Begin

for i:=1 to N*N do u[i]:=0;

l:=1;

Rek(ki,kj,z,l);

i:=ki; j:=kj;

k:=u[(i-1)*Nb+j];

div_mod(k,i,j);

mi:=i; mj:=j; l:=1;

Repeat

inc(l);

k:=u[(i-1)*Nb+j];

div_mod(k,i,j);

if l mod 2=1 then

if p[i,j]<p[mi,mj] then begin

mi:=i; mj:=j;

end;

Until (i=ki) and (j=kj);



i:=ki; j:=kj; l:=0;

p_m:=p[mi,mj];

Repeat

if l mod 2=0 then begin

inc(p[i,j],p_m);

PrintS((n1+1)*j+n2-1,i*3+3,'(+)',12);

end else begin

dec(p[i,j],p_m);

PrintS((n1+1)*j+n2-1,i*3+3,'(-)',12);

end;

if l=0 then inc(p[i,j]);

k:=u[(i-1)*Nb+j];

div_mod(k,i,j);

inc(l);

Until (i=ki) and (j=kj);

p[mi,mj]:=-1;

End;



Procedure Pauza;

var d:char;

Begin

TextColor(6);

GotoXY(40,1);

Write('Нажмите любую клавишу');

d:=ReadKey;

GotoXY(40,1);

ClrEOL;

End;



BEGIN

Nul(alfa); Nul(betta);

Nt:=1;

ClrScr;

TextColor(10);

Repeat

Write('Введите количество поставщиков (2<=Na<=',N-1,') ');

ReadLn(Na);

Write('Введите количество потребителей (2<=Nb<=',N-1,') ');

ReadLn(Nb);

Until (Na>1) and (Na<=N-1) and (Nb>1) and (Nb<=N-1);

Tabl;



(******************* ввод начальных данных ******************)

PrintS(1,1,'Введите количество продукции:',3);

W_W(A,Na,'A');

W_W(B,Nb,'B');

TextColor(3);

GotoXY(1,1); ClrEOL;

Write('Введите стоимость перевозки');

for i:=1 to Na do

for j:=1 to Nb do begin

TextColor(3);

GotoXY(29,1); ClrEOL;

Write('A',i,' - B',j,' ');

Rid(c[i,j],5);

Print((n1+1)*j+n2-4,i*3+3,1,c[i,j],11);

end;

(**********************************************************)



GotoXY(1,1);

ClrEOL;

TextColor(14);

Write('Таблица N1');



for i:=1 to Na do Sa:=Sa+A[i];

for i:=1 to Nb do Sb:=Sb+B[i];

if Sa<>Sb then begin {если задача является открытой}

PrintS(20,1,'Открытая задача (Нажмите любую клавишу)',7);

d:=ReadKey;

if Sa>Sb then begin

inc(Nb);

B[Nb]:=Sa-Sb;

for i:=1 to Na do c[i,Nb]:=0;

end else begin

inc(Na);

A[Na]:=Sb-Sa;

for i:=1 to Nb do c[Na,i]:=0;

end;

Tabl;

for i:=1 to Na do

for j:=1 to Nb do Print((n1+1)*j+n2-4,i*3+3,1,c[i,j],11);

for i:=1 to Na do

Print(n2-trunc(ln(A[i])/ln(10)),i*3+4,1,A[i],14);

for i:=1 to Nb do

Print(n2+i*(n1+1)-trunc(ln(B[i])/ln(10)),4,1,B[i],14);

PrintS(20,1,'Открытая задача',7);

end

else PrintS(20,1,'Закрытая задача',7);



(************** cоставление опорного плана ****************)

for i:=1 to Nb do B_d[i]:=B[i];

for i:=1 to Na do begin

for j:=1 to Nb do x[j]:=j;

for j:=1 to Nb-1 do begin

x_min:=c[i,x[j]];

r_min:=j;

for r:= j+1 to Nb do

if (x_min>c[i,x[r]]) or

((x_min=c[i,x[r]]) and (B[x[r]]>b[x[r_min]])) then

begin

x_min :=c[i,x[r]];

r_min:=r;

end;

x_p:=x[r_min];

x[r_min]:=x[j];

x[j]:=x_p;

end;

Sp:=0;

for j:=1 to Nb do begin

p[i,x[j]]:=B_d[x[j]];

if p[i,x[j]]>A[i]-Sp then p[i,x[j]]:=A[i]-Sp;

inc(Sp,p[i,x[j]]);

dec(B_d[x[j]],p[i,x[j]]);

end;

end;

(***********************************************************)



for i:=1 to Na do

for j:=1 to Nb do if p[i,j]=0 then p[i,j]:=-1;

W_p;

f:=FF; f0:=F;



While a_b do;

for i:=1 to Na do Print(l+1,i*3+3,3,alfa[i],14);

for i:=1 to Nb do Print(i*(n1+1)+n2-4,h,6,betta[i],14);

Pauza;

(******* постепенное приближение плана к оптимальному ******)

While kkk(ki,kj)<0 do begin

kontur;

pauza;

for i:=1 to Na do

for j:=1 to Nb do PrintS((n1+1)*j+n2-1,i*3+3,' ',14);

inc(Nt);

GotoXY(1,1);

Write('Таблица N',Nt);

W_p;

f0:=f; f:=FF;

if a_b then Goto l1;

for i:=1 to Na do Print(l+1,i*3+3,3,alfa[i],14);

for i:=1 to Nb do Print(i*(n1+1)+n2-4,h,6,betta[i],14);

Pauza;

end;

(***********************************************************)



PrintS(40,1,'Решение оптимально',12);

PrintS(60,1,'(any key)',6);

for i:=1 to Na do

for j:=1 to Nb do if p[i,j]=-1 then begin

h:=i*3+4;

l:=j*(n1+1)+n2-5;

GotoXY(l,h);

Write(' ':n1);

end;

GotoXY(40,1);

l1: d:=ReadKey;

END.





Я знаю, что ничего не знаю, но многие не знают и этого
Изменил(а) Kest, 24-10-2011 16:43
259599576 http://codingrus.ru Послать приватное сообщение
Автор RE: Транспортная задача
Evgen
Пользователь

Сообщений: 4
Зарегистрирован: 27.03.11
Опубликовано 24-10-2011 19:08
Спасибо большое smiley Буду переделывать под себе , еще раз огромное спасибо
Послать приватное сообщение
Автор RE: Транспортная задача
bbpower
Пользователь

Сообщений: 3
Зарегистрирован: 16.02.15
Опубликовано 18-02-2015 16:34
да, спасибо за помощь


Спортивное питание по выгодным ценам
http://www.bbpower.com.ua/
http://www.bbpower.com.ua/ Послать приватное сообщение
Автор RE: Транспортная задача
margaritamoroz
Пользователь

Сообщений: 3
Зарегистрирован: 04.01.17
Опубликовано 04-01-2017 16:36
получилось?


Пластиковые окна https://royalgroup-ltd.kz/
https://royalgroup-ltd.kz/ Послать приватное сообщение
Перейти на форум:
Гость
Имя

Пароль



Вы не зарегистрированны?
Нажмите здесь для регистрации.

Забыли пароль?
Запросите новый здесь.
Поделиться ссылкой
Фолловь меня в Твиттере! • Смотрите канал о путешествияхКак приготовить мидии в тайланде?
Загрузки
Новые загрузки
iChat v.7.0 Final...
iComm v.6.1 - выв...
Visual Studio 200...
CodeGear RAD Stud...
Шаблон для новост...

Случайные загрузки
JanComp
ShadelLabel
Эффект лампы на р...
Измерение тактово...
Конвертирование и...
PHP глазами хакера
Последние загруж...
Tenis [Исходник н...
База для Allsubmi...
Animation Effect ...
Панель Наша Кнопка
Длинный заголовок...
PDJPack
DS_Group
UmEdit
MpegPlay
Visual Basic for ...
FilesInfo
PolyFlow
oTextrackBar

Топ загрузок
Приложение Клие... 100319
Delphi 7 Enterp... 79065
Converter AMR<-... 20023
Borland C++Buil... 10770
GPSS World Stud... 9521
Borland Delphi ... 7765
Turbo Pascal fo... 6899
Visual Studio 2... 4915
Калькулятор [Ис... 4078
FreeSMS v1.3.1 3486
Случайные статьи
Протоколы группово...
В случае атаки сис...
Исключения и дестр...
Динамический вызов...
tell(X)
Список файлов
for UNIX 2
STREAMS и ядро сис...
5.4.3. Ввод программ
Определение абстра...
Что поражает больш...
Потери памяти при ...
Использование созд...
Линии серий (рядов)
Каким должен быть ...
Машинно-независима...
Рекурсивные методы...
Отображение параме...
• Использование Wi...
Управляющий термин...
Куда цифровой сигн...
Требование синхрон...
Географические диа...
DEPART (ПОКИНУТЬ О...
Виртуальные машины...
Статистика



Друзья сайта
Программы, игры


Полезно
В какую объединенную сеть входит классовая сеть? Суммирование маршрутов Занимают ли таблицы память маршрутизатора?