jisuan.~pas

运输问题-西北角法的源程序

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;//从可选集合中选取关键行
if Result=0 then
  begin
    ShowMessage('程序出现初始数据错误');
    Application.Terminate;//出现异常终止程序的运行
  end;
end;
{--------------西北角法原理第一步，寻找待分配的供应站---------------------}

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;//从可选集合中选取关键列
if Result=0 then
  begin
    ShowMessage('程序出现初始数据错误');
    Application.Terminate;//出现异常终止程序的运行
  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;//初始化检验数
for i:=1 to m do
  for j:=1 to n do
    if x[i,j]>0 then
      d[i,j]:=0;//设置关键输的检验数为零
end;
{--------------对应步近法求解的第一步-----------------------------------}

procedure  second;
var i,j:Integer;
    cishu:Integer;//累加while执行的次数
    temp_u:array[1..long] of Boolean;
    //长位long的boolean型变量数组，辅助判断是否已求出所有的u
    temp_v:array[1..long] of Boolean;
    //长位long的boolean型变量数组，辅助判断是否已求出所有的v
    temp_all:boolean;//判断是否求出所有的u和v的位势
    label 1;//定义标签控制循环
begin
for i:=1 to long do
  begin
    temp_u[i]:=False;
    temp_v[i]:=False;
  end;//给局部变量赋初值为false表示没有求出该点的位势
for i:=1 to long do
  begin
    u[i]:=-1.11;
    v[i]:=-1.11;
  end;//初始化位势值，此处无特别意义，只为防止浮点数运算的出错
{------------初始化变量-----------------------------------------------}

1:v[1]:=0;
temp_v[1]:=True;//参考位势点
temp_all:=False;//判断是否求出所有的u和v的位势
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;//根据v的位势,搜索求解u的位势
    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;//根据u的位势,搜索求解v的位势
    temp_all:=True;
    for i:=1 to m do
      if temp_u[i]=False  then
         temp_all:=False;//如果有任一行的位势没有求出，则ttemp_all为false
    for j:=1 to n do
       if temp_v[j]=False  then
         temp_all:=False;//如果有任一列的位势没有求出，则ttemp_all为false
    cishu:=cishu+1;
  end;//while语句的结束

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;
{--------------对应步近法求解的第二步-----------------------------------}

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];
  //计算非基变量的检验数
end;
{--------------对应步近法求解的第三步-----------------------------------}

procedure  four;
var i,j:Integer;
begin
for i:=1 to m do
  for j:=1 to n do
    biaoshi[i,j]:=#0;//初始化标识符
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]:='*';
//若运输矩阵和检验数的某一格同时为零，则标以*号
end;
{--------------对应步近法求解的第四步-----------------------------------}

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;
{--------------对应步近法求解的第五步-----------------------------------}

procedure seven;
var i,j:Integer;
    temp:boolean;//判断是否找到闭回路
    temp_s:integer;//关键行
    temp_r:integer;//关键列
    biaoshishuliang:Integer;//辅助判断看是否回到初始列
    label 1;//定义标签控制循环
begin
biaoshi[r,s]:='+';//标明带“+”的元素x[r,s]
temp_r:=r;//从第r行开始找
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 //除去当前行
           begin
             if  (x[i,j]>0) or (biaoshi[i,j]='*')  then
               begin
                 temp:=True;
                 Break;
               end;//判断改列中是否有大于零或标识为*的元素
           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行中找出一个大于零的元素，在其相应的列中至少有一个
            //大于零或标以*号的元素
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行中找出一个大于零的元素，在其相应的列中至少有一个
            //大于零或标以*号的元素
     goto 1;
  end;
end;
{--------------对应步近法求解的第七步-----------------------------------}

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; //确定一个初始最小值
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;//更新运输矩阵
end;
{--------------对应步近法求解的第八步-----------------------------------}


procedure Tfrmjisan.BitBtn2Click(Sender: TObject);
var i,j:Integer;
    temp:Integer;
    //临时变量，辅助在供应站和需求站种寻找最小的供需量
    sum1,sum2:integer;
begin 
sum1:=0;
sum2:=0;//初始化总供应量和总需求量
for i:=1 to m do
 sum1:=sum1+a[i];//计算总供应量
for j:=1 to n do
  sum2:=sum2+b[j];//计算总需求量
if sum1>sum2 then //对供大于需情况的处理
   begin
     ShowMessage('供大于需，需加入虚拟采购站');
     n:=n+1;
     for i:=1 to m do
       c[i,n]:=0;
     b[n]:=sum1-sum2;
     with StringGrid1 do
       begin
         ColCount:=ColCount+1;//表格列数加一
         Width:=Width+DefaultColWidth;//根据需要调整表格宽度
         cells[ColCount-2,0]:='虚站点';
       end;
   end
else if sum1<sum2 then //对需大于供情况的处理
   begin
     ShowMessage('需大于供，需加入虚拟供应站');
     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; //根据需要调整表格高度
         Cells[0,rowCount-2]:='虚站点';
       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;//动态调整位置
    Cells[ColCount-1,0]:='供应量';
    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];//设置初始待分配的供应站的下标集合
for j:=1 to n do
  ss:=ss+[j];//设置初始待分配的需求站的下标集合
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;
{----------求取并显示最初可行的运输方案-------------------------------}

procedure Tfrmjisan.BitBtn3Click(Sender: TObject);
var i,j:Integer;
    cishu:Integer;//迭代次数
    label 1,2;//定义标签控制循环
begin
//BitBtn2Click(sender);//先求解可行方案，防止直接点击该按钮
cishu:=0;
1:cishu:=cishu+1;
first;//根据运输矩阵，求部分检验数
second;//求所有行和所有列的为势
third;//根据位势求其它的检验数
four;//表示有无退化情况的发生
five;//找出检验数中的最大者，和此最大值
if d[r,s]<=0 then //对应步进法原理的第六步，判断当前解的最优性
2: begin
    z:=0;//运费值
    for i:=1 to m do
      for j:=1 to n do
        begin
          StringGrid1.Cells[j,i]:=FloatToStr(x[i,j]);
           //显示最优运输方案
          z:=z+x[i,j]*c[i,j];//累加计算最小运费
        end;
     ShowMessage('最小运费是：'+FormatFloat('0.###',z));//显示最小运费
  end //条件成立，当前解为最优解，显示最优解
else
  begin
    seven;//新解的确定
    eight;//更新运输矩阵
    if cishu>50 then
      begin
        ShowMessage('该运输问题具有，多种最有运输方案');
        goto 2;//直接显示一种最优方案
      end;
    goto 1;
  end;//条件不成立，重新迭代计算

end;
{----程序的主体部分，调用各个自定义过程和函数，求解最有运输方案----}

procedure Tfrmjisan.BitBtn4Click(Sender: TObject);
begin
frmshuju.Show;
frmjisan.Hide;//返回到数据输入窗口
end;

procedure Tfrmjisan.BitBtn1Click(Sender: TObject);
begin
Application.Terminate;
//终止程序的运行
end;

procedure Tfrmjisan.FormShow(Sender: TObject);
var i,j:Integer;
begin
with StringGrid1 do
  begin
    RowCount:=m+2;
    ColCount:=n+2;//动态设置行数和列数
    Width:=ColCount*(DefaultColWidth+2);
    Height:=RowCount*(DefaultRowHeight+2);//动态调整宽度和高度
    top:=(panel2.Height-Height) div 2-50;//动态调整位置
    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]:='供应量'; //设置表框
  end;//控制调整结果显示界面
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;
{------------------设置初始表格-------------------------------}
end.