Смекни!
smekni.com

Решение транспортной задачи 3 (стр. 3 из 3)

ch: array [1..6] of char;

spl, dmd: array [1..100] of real;

u,v: array [1..100] of real;

sspl,sdmd:real;

cycle,x: array [1..100, 1..100] of string;

xnb: array [1..100, 1..100] of real;

rw1,bn,ed,t,it,jt,it0,jt0,cl,rw:integer;

way:string;

ways: array [1..100] of string;

procedure search(q:string);

var i,j:integer;

begin

j:=jt; i:=it;

if q='up' then

for i:=1 to it-1 do

if not(x[i,j]='------------') then begin way:='up'; it:=i; break;end;

if q='right' then

for j:=cl downto jt+1 do

if not(x[i,j]='------------') then begin way:='right'; jt:=j; break;end;

if q='down' then

for i:=rw downto it+1 do

if not(x[i,j]='------------') then begin way:='down'; it:=i; break;end;

if q='left' then

for j:=1 to jt-1 do

if not(x[i,j]='------------') then begin way:='left'; jt:=j; break;end;

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

var

z,ind,i,j: integer;

ci,ri: byte;

s: string;

cd:integer;

bl,bln: boolean;

min,max,tmp,r:real;

zikl:integer;

uzli: array [1..100,1..2] of integer;

begin

if(not read_data()) then exit;

balans();

First_resh();

repeat

find_uv();

it:=1; jt:=1;

xnbmax(max,it,jt);

it0:=it; jt0:=jt;

if max<=0 then break;

x[it,jt]:='X';

it:=-1; jt:=-1;

for i:=1 to 4 do begin

way:='non';

it:=it0;jt:=jt0;

if(i=1) then search('up');

if(i=2) then search('down');

if(i=3) then search('left');

if(i=4) then search('right');

if(way='non') then continue;

zikl:=1;

ways[1]:='first';

uzli[1][1]:=it;

uzli[1][2]:=jt;

repeat

it:=uzli[zikl][1]; jt:=uzli[zikl][2];

s:=way;

if(ways[zikl]='first') then begin

if((way='up')or(way='down')) then begin way:='none'; search('left'); end

else begin way:='none'; search('up'); end;

if(way='none') then begin ways[zikl]:='second'; way:=s; end

else begin

ways[zikl]:='second';

zikl:=zikl+1;

uzli[zikl][1]:=it;

uzli[zikl][2]:=jt;

ways[zikl]:='first';

end;

end;

if(ways[zikl]='second') then begin

if((way='up')or(way='down')) then begin way:='none'; search('right'); end

else begin way:='none'; search('down'); end;

if(way='none') then ways[zikl]:='end'

else begin

ways[zikl]:='end';

zikl:=zikl+1;

uzli[zikl][1]:=it;

uzli[zikl][2]:=jt;

ways[zikl]:='first';

end;

end;

if(ways[zikl]='end') then begin

if((s='up')or(s='down')) then way:='right'

else way:='down';

if(zikl=1) then break

else zikl:=zikl-1;

end;

until (it=it0) and (jt=jt0);

if((it=it0)and(jt=jt0)) then break;

end;

min:=32000;

if(way='non') then min:=0

else

for i:=1 to zikl-1 do

if((i mod 2)=1) then begin

tmp:=strtofloat(x[uzli[i][1],uzli[i][2]]);

if(tmp<min) then min:=tmp;

end;

x[it0][jt0]:=floattostr(min);

bln:=false;

if(way<>'non') then

for i:=1 to zikl-1 do begin

tmp:=strtofloat(x[uzli[i][1],uzli[i][2]]);

if((i mod 2)=0) then begin tmp:=tmp+min; cycle[uzli[i][1],uzli[i][2]]:='+'; end

else begin tmp:=tmp-min; cycle[uzli[i][1],uzli[i][2]]:='-'; end;

x[uzli[i][1],uzli[i][2]]:=floattostr(tmp);

if(((i mod 2)=1)and(tmp=0)and(not bln)) then begin

x[uzli[i][1],uzli[i][2]]:='------------';

bln:=true;

end

end;

until false;

form3.Visible:=true;

print_tabl();

for i:=1 to rw1 do begin

s:=inttostr(i)+'-ая фабрика поставила товар в '; tmp:=0;

for j:=1 to cl do

if not (x[i,j]='------------') then begin s:=s+inttostr(j)+'-й '; tmp:=tmp+1;

r:=r+strtofloat(x[i,j])*c[i,j];

end;

if tmp>1 then s:=s+'склады ' else s:=s+'склад ';

s:=s+' ('+inttostr(i)+'-й маршрут).';

form1.Memo1.Lines.Append(s);

end;

tmp:=0;

if rw1<rw then begin

for j:=1 to cl do if not (x[rw,j]='------------')

then tmp:=tmp+strtofloat(x[rw,j]);

form1.Memo1.Lines.Append('Не доставлено '+floattostr(tmp)+' партий товара.');

end;

s:='Расходы составят '+floattostr(r)+' у.е.';

form1.Memo1.Lines.Append(s);

form1.Memo1.Lines.Append('--------------------------------------------------------------------------');

end;

procedure TForm1.Button3Click(Sender: TObject);

var i,j:integer;

s:string;

begin

if (form1.prdl.text='')or(form1.spr.text='') then begin beep;

MessageDLG('Проверьте правильность введенных данных!', mtError, [mbOK], 0);

exit;end;

val(form1.prdl.text,cl,t);

val(form1.spr.text,rw,t);

if (cl>7)or(rw>7) then begin beep;

MessageDLG('Нельзя вводить такую большую размерность!', mtError, [mbOK], 0);

exit;end;

form1.spros.colcount:=cl;

form1.predl.rowcount:=rw;

form1.bitbtn1.Enabled:=true;

label3.Enabled:=true;

label4.Enabled:=true;

label5.Enabled:=true;

label6.Enabled:=true;

label8.Enabled:=true;

Button2.Enabled:=true;

form1.predl.Enabled:=true;

form1.spros.Enabled:=true;

form1.tab1.Enabled:=true;

form1.Memo1.Enabled:=true;

// Очистка таблиц

for t:=0 to 100 do

for i:=0 to 100 do begin

form1.tab1.Cells[i,t]:='';

form3.sg1.Cells[i,t]:='';

end;

for t:=1 to cl do begin

str(t,s);

form1.tab1.Cells[t,0]:=s;

form3.sg1.Cells[t,0]:=s;

end;

ch[1]:='A'; ch[2]:='Б'; ch[3]:='В';

ch[4]:='Г'; ch[5]:='Д'; ch[6]:='Е';

for t:=0 to rw do begin

form1.tab1.Cells[0,t]:=ch[t];

form3.sg1.Cells[0,t]:=ch[t];

end;

form1.tab1.Cells[0,0]:='';

form3.sg1.Cells[0,0]:='';

end;

procedure TForm1.Button2Click(Sender: TObject);

var i,j:integer;

begin

c[1,1]:=20; c[1,2]:=40; c[1,3]:=15; c[1,4]:=30;

c[2,1]:=10; c[2,2]:=25; c[2,3]:=25; c[2,4]:=35;

c[3,1]:=15; c[3,2]:=45; c[3,3]:=30; c[3,4]:=20;

for t:=1 to cl do

for i:=1 to rw do form1.tab1.Cells[t,i]:=floattostr(c[i,t]);

spl[1]:=60; spl[2]:=100; spl[3]:=80;

dmd[1]:=70; dmd[2]:=50; dmd[3]:=90; dmd[4]:=30;

for t:=1 to rw do form1.predl.Cells[0,t-1]:=floattostr(spl[t]);

for t:=1 to cl do form1.spros.Cells[t-1,0]:=floattostr(dmd[t]);

end;

function TForm1.read_data():bool;

var i,j: integer;

begin

try

for i:=1 to rw do

for j:=1 to cl do

c[i,j]:=strtofloat(form1.tab1.Cells[j,i]);

sspl:=0;

for i:=1 to rw do begin

spl[i]:=strtofloat(form1.predl.Cells[0,i-1]);

sspl:=sspl+spl[i];

end;

sdmd:=0;

for i:=1 to cl do begin

dmd[i]:=strtofloat(form1.spros.Cells[i-1,0]);

sdmd:=sdmd+dmd[i];

end;

read_data:=true;

except on EConvertError do

begin

MessageDLG('Проверьте правильность введенных данных!', mtError, [mbOK], 0);

read_data:=false;

exit;

end;

end;

end;

procedure TForm1.balans();

var i,j: integer;

begin

rw1:=rw;

if sspl>sdmd then begin

showmessage('Задача не сбалансирована! Добавляем столбец.');

cl:=cl+1;

for i:=1 to rw do begin form1.tab1.Cells[cl,i]:='0'; x[i,cl]:='0'; end;

form1.tab1.Cells[cl,0]:=inttostr(cl);

form3.sg1.Cells[cl,0]:=inttostr(cl);

dmd[cl]:=sspl-sdmd;

form1.spros.colcount:=cl;

form1.spros.cells[cl-1,0]:=floattostr(dmd[cl]);

end;

if sspl<sdmd then begin

showmessage('Задача не сбалансирована! Добавляем строку.');

rw1:=rw;

rw:=rw+1;

for i:=1 to cl do begin form1.tab1.Cells[i,rw]:='0'; x[rw,i]:='0'; end;

form1.tab1.Cells[0,rw]:=ch[rw];

form3.sg1.Cells[0,rw]:=ch[rw];

spl[rw]:=sdmd-sspl;

form1.predl.rowcount:=rw;

form1.predl.cells[0,rw-1]:=floattostr(spl[rw]);

end;

end;

procedure TForm1.First_resh();

var

ci,ri: byte;

i,j: integer;

tmp:real;

begin

for i:=1 to rw+1 do

for j:=1 to cl+1 do x[i,j]:='------------';

ri:=1; ci:=1;

while ((ri<=rw) and (ci<=cl)) do begin

if spl[ri]<dmd[ci] then tmp:=spl[ri] else tmp:=dmd[ci];

x[ri,ci]:=floattostr(tmp);

spl[ri]:=spl[ri]-tmp;

dmd[ci]:=dmd[ci]-tmp;

if spl[ri]=0 then ri:=ri+1;

if dmd[ci]=0 then ci:=ci+1;

end;

end;

procedure TForm1.find_uv();

var

vc,uc: array [1..100] of integer;

ind,i,j: integer;

begin

for i:=1 to cl do begin v[i]:=0; vc[i]:=0; end;

for i:=2 to rw do begin u[i]:=0; uc[i]:=0; end;

u[1]:=0; uc[1]:=1;

for t:=1 to rw do

for ind:=1 to rw do begin

//цикл для V

for i:=1 to cl do

if(not(x[ind,i]='------------'))and(uc[ind]=1) then begin

v[i]:=c[ind,i]-u[ind];

vc[i]:=1;

end;

if not (ind=rw) then

for j:=1 to cl do

if(not(x[ind+1,j]='------------'))and(vc[j]=1) then begin

u[ind+1]:=c[ind+1,j]-v[j];

uc[ind+1]:=1;

end;

end;

for i:=1 to rw do

for j:=1 to cl do begin

if (x[i,j]='------------') then xnb[i,j]:=u[i]+v[j]-c[i,j]

else xnb[i,j]:=0;

end;

end;

procedure TForm1.xnbmax(var max:real;var xi,yi:integer);

var

i,j:integer;

begin

max:=0; xi:=1; yi:=1;

for i:=1 to rw do

for j:=1 to cl do begin

if (max<xnb[i,j]) and (x[i,j]='------------') then begin

max:=xnb[i,j];

xi:=i; yi:=j;

end

end;

end;

procedure TForm1.print_tabl();

var

i,j: integer;

begin

for i:=1 to rw do

for j:=1 to cl do

form3.sg1.Cells[j,i]:=x[i,j];

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

form2.Visible:=true;

end;

end.