Навигация
Главная
Поиск
Форум
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
Бип из системно... 65174
Организация зап... 60862
Приложение «Про... 60768
Invision Power ... 60476
Оператор выбора... 59561
Модуль Forms 58541
Подключение Mic... 58523
Создание отчето... 58027
ТЕХНОЛОГИИ ДОСТ... 54287
Программируемая... 52755
Пример работы с... 50841
Имитационное мо... 49731
21 ошибка прогр... 44674
Реклама
Сейчас на сайте
Гостей: 15
На сайте нет зарегистрированных пользователей

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

Моделирование работы ЭВМ на GPSS + Пояснительная записка
Игра 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...
Шаблон для новост...

Случайные загрузки
iChat v.7.0 Final...
Delphi 2005 для W...
Как программирова...
Win-Prolog 3.618
WinPopup
Пользовательская...
Delphi World 6.0
AdBlaster v2.5 - ...
CoolControls v3.0...
ICQ
JBlabel3D
Библия хакера 2. ...
Язык программиров...
Delphi. Разработк...
Советы от Даниилы...
Добавление к ссы...
Java Server Pages...
PolyFlow
AlnComponents
Пример работы с б...

Топ загрузок
Приложение Клие... 100346
Delphi 7 Enterp... 80952
Converter AMR<-... 20031
Borland C++Buil... 10886
GPSS World Stud... 9994
Borland Delphi ... 7929
Turbo Pascal fo... 6930
Visual Studio 2... 4937
Калькулятор [Ис... 4187
FreeSMS v1.3.1 3494
Случайные статьи
Шаблоны классов
Запросы
Другие реализации ...
Разделяемая память.
НАСЛЕДОВАНИЕ
решения для выделе...
Создание поставщик...
Работа с веб-серве...
Использование комб...
Режимы фокусировки
Внедрение решения
Будьте на виду сле...
Использование Comp...
Поддерживаемые ком...
Получение цифровог...
Программа сертифик...
Язык С: преобразов...
Выбор формата файл...
Обработка страничн...
Задачи, использующ...
RAID уровня 0
Применение туннель...
3.5. Пример: упо...
Простые свойства
Настройка комбинир...
Статистика



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


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