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.