unit jisuan;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, StdCtrls, Buttons, ExtCtrls,math;

type
  Tfrmjisan = class(TForm)
    Label3: TLabel;
    panel2: TPanel;
    BitBtn2: TBitBtn;
    StringGrid1: TStringGrid;
    BitBtn3: TBitBtn;
    BitBtn4: TBitBtn;
    BitBtn1: TBitBtn;
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmjisan: Tfrmjisan;

implementation

{$R *.dfm}
uses shuju;
function  find_r:Integer;
var i:integer;
begin
Result:=1;
for i:=1 to m do
  if i in rr then
     begin
       Result:=i;
       break;
     end;//從可選集合中選取關(guān)鍵行
if Result=0 then
  begin
    ShowMessage('程序出現(xiàn)初始數(shù)據(jù)錯(cuò)誤');
    Application.Terminate;//出現(xiàn)異常終止程序的運(yùn)行
  end;
end;
{--------------西北角法原理第一步，尋找待分配的供應(yīng)站---------------------}

function  find_s:Integer;
var i:integer;
begin
Result:=1;
for i:=1 to n do
  if i in ss then
     begin
       Result:=i;
       break;
     end;//從可選集合中選取關(guān)鍵列
if Result=0 then
  begin
    ShowMessage('程序出現(xiàn)初始數(shù)據(jù)錯(cuò)誤');
    Application.Terminate;//出現(xiàn)異常終止程序的運(yùn)行
  end;
end;
{--------------西北角法原理第一步，尋找待分配的需求站---------------------}

procedure  first;
var i,j:Integer;
begin
for i:=1 to long do
  for j:=1 to long do
    d[i,j]:=-1;//初始化檢驗(yàn)數(shù)
for i:=1 to m do
  for j:=1 to n do
    if x[i,j]>0 then
      d[i,j]:=0;//設(shè)置關(guān)鍵輸?shù)臋z驗(yàn)數(shù)為零
end;
{--------------對(duì)應(yīng)步近法求解的第一步-----------------------------------}

procedure  second;
var i,j:Integer;
    cishu:Integer;//累加while執(zhí)行的次數(shù)
    temp_u:array[1..long] of Boolean;
    //長(zhǎng)位long的boolean型變量數(shù)組，輔助判斷是否已求出所有的u
    temp_v:array[1..long] of Boolean;
    //長(zhǎng)位long的boolean型變量數(shù)組，輔助判斷是否已求出所有的v
    temp_all:boolean;//判斷是否求出所有的u和v的位勢(shì)
    label 1;//定義標(biāo)簽控制循環(huán)
begin
for i:=1 to long do
  begin
    temp_u[i]:=False;
    temp_v[i]:=False;
  end;//給局部變量賦初值為false表示沒(méi)有求出該點(diǎn)的位勢(shì)
for i:=1 to long do
  begin
    u[i]:=-1.11;
    v[i]:=-1.11;
  end;//初始化位勢(shì)值，此處無(wú)特別意義，只為防止浮點(diǎn)數(shù)運(yùn)算的出錯(cuò)
{------------初始化變量-----------------------------------------------}

1:v[1]:=0;
temp_v[1]:=True;//參考位勢(shì)點(diǎn)
temp_all:=False;//判斷是否求出所有的u和v的位勢(shì)
cishu:=0;
while (not temp_all) and  (cishu<(m+n)) do
  begin
    for i:=1 to m do
      if not temp_u[i] then
      begin
        for j:=1 to n do
          if temp_v[j] and (d[i,j]=0) then
             begin
               u[i]:=c[i,j]-v[j];
               temp_u[i]:=True;
               break;
             end;
      end;//根據(jù)v的位勢(shì),搜索求解u的位勢(shì)
    for j:=1 to n do
      if not temp_v[j] then
      begin
        for i:=1 to m do
          if temp_u[i] and (d[i,j]=0) then
            begin
               v[j]:=c[i,j]-u[i];
               temp_v[j]:=True;
               break;
             end;
      end;//根據(jù)u的位勢(shì),搜索求解v的位勢(shì)
    temp_all:=True;
    for i:=1 to m do
      if temp_u[i]=False  then
         temp_all:=False;//如果有任一行的位勢(shì)沒(méi)有求出，則ttemp_all為false
    for j:=1 to n do
       if temp_v[j]=False  then
         temp_all:=False;//如果有任一列的位勢(shì)沒(méi)有求出，則ttemp_all為false
    cishu:=cishu+1;
  end;//while語(yǔ)句的結(jié)束

if cishu=2*m*n then
   begin
     //showmessage('退化解');
     for i:=1 to m do
       if temp_u[i]=False then
         for j:=1 to n do
           if temp_v[j]=False then
              begin
                d[i,j]:=0;
                goto  1;
              end;
   end;
end;
{--------------對(duì)應(yīng)步近法求解的第二步-----------------------------------}

procedure  third;
var i,j:Integer;
begin
for i:=1 to m do
  for j:=1 to n do
    if d[i,j]=-1 then
       d[i,j]:=u[i]+v[j]-c[i,j];
  //計(jì)算非基變量的檢驗(yàn)數(shù)
end;
{--------------對(duì)應(yīng)步近法求解的第三步-----------------------------------}

procedure  four;
var i,j:Integer;
begin
for i:=1 to m do
  for j:=1 to n do
    biaoshi[i,j]:=#0;//初始化標(biāo)識(shí)符
for i:=1 to long do
  for j:=1 to long do
    if (x[i,j]=0) and (d[i,j]=0) then
        biaoshi[i,j]:='*';
//若運(yùn)輸矩陣和檢驗(yàn)數(shù)的某一格同時(shí)為零，則標(biāo)以*號(hào)
end;
{--------------對(duì)應(yīng)步近法求解的第四步-----------------------------------}

procedure five;
var i,j:Integer;
    temp:real; //最大值
begin
temp:=d[1,1]; //初始化最大值
r:=1;
s:=1;//記錄最大值的位置
for i:=1 to m do
  for j:=1 to n do
    if d[i,j]>temp then
      begin
        temp:=d[i,j];
        r:=i;
        s:=j;
      end;//尋找定位最大值
end;
{--------------對(duì)應(yīng)步近法求解的第五步-----------------------------------}

procedure seven;
var i,j:Integer;
    temp:boolean;//判斷是否找到閉回路
    temp_s:integer;//關(guān)鍵行
    temp_r:integer;//關(guān)鍵列
    biaoshishuliang:Integer;//輔助判斷看是否回到初始列
    label 1;//定義標(biāo)簽控制循環(huán)
begin
biaoshi[r,s]:='+';//標(biāo)明帶“+”的元素x[r,s]
temp_r:=r;//從第r行開(kāi)始找
temp_s:=s;
biaoshishuliang:=1;
1:for j:=1 to n do
    if (j<>temp_s) and (x[temp_r,j]>0) then //找大于零的元素
       begin
         temp:=False;
         for i:=1 to m do
           if i<>temp_r then //除去當(dāng)前行
           begin
             if  (x[i,j]>0) or (biaoshi[i,j]='*')  then
               begin
                 temp:=True;
                 Break;
               end;//判斷改列中是否有大于零或標(biāo)識(shí)為*的元素
           end;
         if (biaoshishuliang>1) and odd(biaoshishuliang) and (j=s) then
            temp:=true;//回到初始列，找到閉回路
         if temp then
           begin
              biaoshi[temp_r,j]:='-';
              temp_s:=j;
              biaoshishuliang:=biaoshishuliang+1;
              Break;
           end;
       end;//在r行中找出一個(gè)大于零的元素，在其相應(yīng)的列中至少有一個(gè)
            //大于零或標(biāo)以*號(hào)的元素
temp:=False;
for i:=1 to m do
  if biaoshi[i,s]='-' then
    begin
      temp:=True;
      Break;
    end;
if not temp then
  begin
    for i:=1 to m do
      if (i<>temp_r) and ((x[i,temp_s]>0) or (biaoshi[i,temp_s]='*')) then
         begin
           temp:=False;
           for j:=1 to n do
             if  (j<>temp_s) and (x[i,j]>0) then
               begin
                 temp:=True;
                 Break;
               end;
           if temp then
             begin
               biaoshi[i,temp_s]:='+';
               temp_r:=i;
               biaoshishuliang:=biaoshishuliang+1;
               break;
             end;
         end;//在r行中找出一個(gè)大于零的元素，在其相應(yīng)的列中至少有一個(gè)
            //大于零或標(biāo)以*號(hào)的元素
     goto 1;
  end;
end;
{--------------對(duì)應(yīng)步近法求解的第七步-----------------------------------}

procedure eight;
var i,j:Integer;
    temp:real; //最小值 
begin
temp:=0;
for i:=1 to m do
  for j:=1 to n do
    if biaoshi[i,j]='-' then
      begin
        temp:=abs(x[i,j]);
        break;
      end; //確定一個(gè)初始最小值
for i:=1 to m do
  for j:=1 to n do
    if (biaoshi[i,j]='-') and (abs(x[i,j])<temp) then
        temp:=abs(x[i,j]);//尋找最小值
for i:=1 to m do
  for j:=1 to n do
     begin
       if  biaoshi[i,j]='+' then
          x[i,j]:=x[i,j]+temp
       else if biaoshi[i,j]='-' then
          x[i,j]:=x[i,j]-temp;
     end;//更新運(yùn)輸矩陣
end;
{--------------對(duì)應(yīng)步近法求解的第八步-----------------------------------}


procedure Tfrmjisan.BitBtn2Click(Sender: TObject);
var i,j:Integer;
    temp:Integer;
    //臨時(shí)變量，輔助在供應(yīng)站和需求站種尋找最小的供需量
    sum1,sum2:integer;
begin 
sum1:=0;
sum2:=0;//初始化總供應(yīng)量和總需求量
for i:=1 to m do
 sum1:=sum1+a[i];//計(jì)算總供應(yīng)量
for j:=1 to n do
  sum2:=sum2+b[j];//計(jì)算總需求量
if sum1>sum2 then //對(duì)供大于需情況的處理
   begin
     ShowMessage('供大于需，需加入虛擬采購(gòu)站');
     n:=n+1;
     for i:=1 to m do
       c[i,n]:=0;
     b[n]:=sum1-sum2;
     with StringGrid1 do
       begin
         ColCount:=ColCount+1;//表格列數(shù)加一
         Width:=Width+DefaultColWidth;//根據(jù)需要調(diào)整表格寬度
         cells[ColCount-2,0]:='虛站點(diǎn)';
       end;
   end
else if sum1<sum2 then //對(duì)需大于供情況的處理
   begin
     ShowMessage('需大于供，需加入虛擬供應(yīng)站');
     m:=m+1;
     for j:=1 to n do
       c[m,j]:=0;
     a[m]:=sum2-sum1;
     with StringGrid1 do
       begin
         RowCount:=rowCount+1;//表格新增一行
         Height:=Height+DefaultRowHeight; //根據(jù)需要調(diào)整表格高度
         Cells[0,rowCount-2]:='虛站點(diǎn)';
       end;
   end;
with StringGrid1 do
  begin
    for i:=1 to m do
      Cells[ColCount-1,i]:=IntToStr(a[i]);
    for j:=1 to n do
        Cells[j,RowCount-1]:=IntToStr(b[j]);
    top:=(panel2.Height-Height) div 2-50;
    Left:=(panel2.Width-Width) div 2;//動(dòng)態(tài)調(diào)整位置
    Cells[ColCount-1,0]:='供應(yīng)量';
    Cells[0,RowCount-1]:='需求量';
    for i:=1 to m do
      cells[ColCount-1,i]:=IntToStr(a[i]);
    for j:=1 to n do
      cells[j,rowCount-1]:=IntToStr(b[j]);
  end;
rr:=[];
ss:=[];
for i:=1 to m  do
  rr:=rr+[i];//設(shè)置初始待分配的供應(yīng)站的下標(biāo)集合
for j:=1 to n do
  ss:=ss+[j];//設(shè)置初始待分配的需求站的下標(biāo)集合
while (ss<>[]) or (rr<>[]) do
  begin
    r:=find_r;
    s:=find_s;//完成原理的第一步
    temp:=min(a[r],b[s]);
    x[r,s]:=temp;
    a[r]:=a[r]-temp;
    b[s]:=b[s]-temp;//完成原理的第二步
    if a[r]=0 then rr:=rr-[r];
    if b[s]=0 then ss:=ss-[s];
  end;
for i:=1 to m do
   for j:=1 to n do
        StringGrid1.Cells[j,i]:=FloatToStr(x[i,j]);
BitBtn2.Enabled:=False;
BitBtn3.Enabled:=True;
end;
{----------求取并顯示最初可行的運(yùn)輸方案-------------------------------}

procedure Tfrmjisan.BitBtn3Click(Sender: TObject);
var i,j:Integer;
    cishu:Integer;//迭代次數(shù)
    label 1,2;//定義標(biāo)簽控制循環(huán)
begin
//BitBtn2Click(sender);//先求解可行方案，防止直接點(diǎn)擊該按鈕
cishu:=0;
1:cishu:=cishu+1;
first;//根據(jù)運(yùn)輸矩陣，求部分檢驗(yàn)數(shù)
second;//求所有行和所有列的為勢(shì)
third;//根據(jù)位勢(shì)求其它的檢驗(yàn)數(shù)
four;//表示有無(wú)退化情況的發(fā)生
five;//找出檢驗(yàn)數(shù)中的最大者，和此最大值
if d[r,s]<=0 then //對(duì)應(yīng)步進(jìn)法原理的第六步，判斷當(dāng)前解的最優(yōu)性
2: begin
    z:=0;//運(yùn)費(fèi)值
    for i:=1 to m do
      for j:=1 to n do
        begin
          StringGrid1.Cells[j,i]:=FloatToStr(x[i,j]);
           //顯示最優(yōu)運(yùn)輸方案
          z:=z+x[i,j]*c[i,j];//累加計(jì)算最小運(yùn)費(fèi)
        end;
     ShowMessage('最小運(yùn)費(fèi)是：'+FormatFloat('0.###',z));//顯示最小運(yùn)費(fèi)
  end //條件成立，當(dāng)前解為最優(yōu)解，顯示最優(yōu)解
else
  begin
    seven;//新解的確定
    eight;//更新運(yùn)輸矩陣
    if cishu>50 then
      begin
        ShowMessage('該運(yùn)輸問(wèn)題具有，多種最有運(yùn)輸方案');
        goto 2;//直接顯示一種最優(yōu)方案
      end;
    goto 1;
  end;//條件不成立，重新迭代計(jì)算

end;
{----程序的主體部分，調(diào)用各個(gè)自定義過(guò)程和函數(shù)，求解最有運(yùn)輸方案----}

procedure Tfrmjisan.BitBtn4Click(Sender: TObject);
begin
frmshuju.Show;
frmjisan.Hide;//返回到數(shù)據(jù)輸入窗口
end;

procedure Tfrmjisan.BitBtn1Click(Sender: TObject);
begin
frmjisan.Close;
frmjisan.Free;
frmshuju.Close;
frmshuju.Free;
Application.Terminate;
//終止程序的運(yùn)行
end;

procedure Tfrmjisan.FormShow(Sender: TObject);
var i,j:Integer;
begin
with StringGrid1 do
  begin
    RowCount:=m+2;
    ColCount:=n+2;//動(dòng)態(tài)設(shè)置行數(shù)和列數(shù)
    Width:=ColCount*(DefaultColWidth+2);
    Height:=RowCount*(DefaultRowHeight+2);//動(dòng)態(tài)調(diào)整寬度和高度
    top:=(panel2.Height-Height) div 2-50;//動(dòng)態(tài)調(diào)整位置
    Left:=(panel2.Width-Width) div 2;
    for i:=1 to m do
      Cells[0,i]:='A'+IntToStr(i);
    for j:=1 to n do
      Cells[j,0]:='B'+IntToStr(j);
    Cells[0,0]:='供\需';
    Cells[0,m+1]:='需求量';
    Cells[n+1,0]:='供應(yīng)量'; //設(shè)置表框
  end;//控制調(diào)整結(jié)果顯示界面
for i:=1 to StringGrid1.RowCount-1 do
  for j:=1 to StringGrid1.ColCount-1 do
    StringGrid1.Cells[j,i]:='';
BitBtn2.Enabled:=True;
BitBtn3.Enabled:=False;
end;
{------------------設(shè)置初始表格-------------------------------}
end.