Навигация
Главная
Поиск
Форум
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
Бип из системно... 62707
Организация зап... 59855
Invision Power ... 59476
Приложение «Про... 58750
Оператор выбора... 57865
Модуль Forms 57747
Подключение Mic... 57104
Создание отчето... 57052
ТЕХНОЛОГИИ ДОСТ... 53344
Программируемая... 51189
Пример работы с... 49220
Имитационное мо... 48813
21 ошибка прогр... 43574
Реклама
Сейчас на сайте
Гостей: 7
На сайте нет зарегистрированных пользователей

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

Выбор наилучших альтернатив с использованием методов оптимизации на Delp...
Информационная система - продуктовый магазин на Turbo Pascal (База данны...
Моделирование системы управления качеством производственного процесса на...

Реклама



Подписывайся на YouTube канал о программировании, что бы не пропустить новые видео!

ПОДПИСЫВАЙСЯ на канал о программировании

Просмотр темы
.:: 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...
Шаблон для новост...

Случайные загрузки
Cooltray
Проигрыватель Mp3
AboutSystem
Обучение Borland ...
Szwavepanel
AJAX и PHP. разра...
Панель статистики...
Советы по Delphi
Пользовательская...
Info
PHP/MySQL для нач...
Java 2 - Эффектив...
Создание меню на ...
Реализация ЭЦП по...
Трассировка прово...
CLR via C#
WinPopup
PBFoldder
mp3tag
3d Tank [Исходник...

Топ загрузок
Приложение Клие... 100333
Delphi 7 Enterp... 79882
Converter AMR<-... 20025
Borland C++Buil... 10826
GPSS World Stud... 9760
Borland Delphi ... 7853
Turbo Pascal fo... 6910
Visual Studio 2... 4926
Калькулятор [Ис... 4133
FreeSMS v1.3.1 3488
Случайные статьи
Если ГВС-канал свя...
ПОЛИМОРФНЫЕ АССОЦИ...
Средства отладки
Не можете найти фа...
5.1.2. Ввод термов
Автомобилей выкуп
номер заказа OrderID
Эмуляция директивы...
Формат NdefRecord
Кому адресована книга
Команда SELECT
Ссылки
Примеры кода
14.1. Структура да...
HR. Старайтесь исп...
Драйверы устройств
Нулевая последоват...
Магнитные выключатели
Аудиозапись с помо...
Диалоговое окно Re...
Какая функция бран...
13.5. Принципы
Аргументы шаблонов...
Дыpы в Win95/WinNT
Преобразование иде...
Статистика



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


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