Навигация
Главная
Поиск
Форум
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
Invision Power ... 65535
Содержание сайт... 65535
Организация зап... 65535
Вызов хранимых ... 65535
Программируемая... 65535
Эмулятор микроп... 65535
Подключение Mic... 65535
Создание потоко... 65535
Приложение «Про... 65535
Оператор выбора... 65535
Модуль Forms 62835
Создание отчето... 62829
ТЕХНОЛОГИИ ДОСТ... 59364
Пример работы с... 58090
Имитационное мо... 54759
Реклама
Сейчас на сайте
Гостей: 12
На сайте нет зарегистрированных пользователей

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

Игра Sokoban на Delphi + Блок схемы
Лабораторная работа по динамическим спискам на 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...
Шаблон для новост...

Случайные загрузки
ActiveX в Delphi
Введение в станда...
SearchAndReplace
Упорядоченный дин...
Billenium Effects...
Delphi. Учимся на...
CoolControls v3.0...
Иллюстрированный ...
PDJXPPack
HTMLredaktor
Распознавание иде...
SynEdit
Degisy Data Acces...
Java в примерах -...
Пятнашки и крести...
Игра PackMan
C++ Builder 6 СПР...
БД сеть компьютер...
Библия хакера 2. ...
IpEditAdress

Топ загрузок
Приложение Клие... 100422
Delphi 7 Enterp... 84987
Converter AMR<-... 20062
GPSS World Stud... 11987
Borland C++Buil... 11408
Borland Delphi ... 8388
Turbo Pascal fo... 7008
Visual Studio 2... 4985
Калькулятор [Ис... 4631
FreeSMS v1.3.1 3530
Случайные статьи
Язык Ada и военный...
Обновленные источн...
Параметры группово...
Логическое выражение
Идею можно распрос...
Объединенные связи...
Разработка многопо...
СОЗДАНИЕ SPLASH-ФО...
5.4.3. Ввод программ
Где купить кухню в...
Уборка в Сочи
Дополнение структу...
Понятие свойства. ...
Масла Meguin
ADO.NET как базовы...
В чем сложность ст...
Комментарии
Обычный режим UNICAST
Блок try–finally
Что такое резидент...
Множество данных м...
Конструкторы
Поиск и устранение...
Unit expected
Диалоговое окно Re...
Статистика



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


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