unit1.pas

某单位需要完成N项任务

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Grids;

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    GroupBox1: TGroupBox;
    inputcost: TButton;
    Label2: TLabel;
    Edit1: TEdit;
    StringGrid1: TStringGrid;
    Label3: TLabel;
    operation: TButton;
    Memo1: TMemo;
    procedure inputcostClick(Sender: TObject);
    procedure StringGrid1KeyPress(Sender: TObject; var Key: Char);
    function  checkmatrix():boolean;
    procedure  clearcel();
    procedure assign1();
    procedure operationClick(Sender: TObject);
    procedure PageControl1Change(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
   // procedure test();
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Unit2, Unit4;

{$R *.dfm}
var n:integer;

procedure TForm1.inputcostClick(Sender: TObject);
var i,j:integer;
begin
  try
     n:=strtoint(edit1.text);
   except
     showmessage('输入格式错误，任务数为正整数，请重新输入！');
     edit1.SetFocus;
     exit;
   end;
  with stringgrid1 do
  begin
  ColCount:=n+1;
  rowCount:=n+1;
  clearcel;
  for j:=1 to n do
   cells[0,j]:='工人'+inttostr(j);
  for i:=1 to n do
   cells[i,0]:='任务'+inttostr(i);
   cells[0,0]:='工人\任务';
  end;
  stringgrid1.SetFocus;
  operation.Enabled:=true;
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
var
  i,j:integer;
  p:real;
begin
  with stringgrid1 do
  begin
  if key=chr(8) then cells[col,row]:=''
  else
  begin
   cells[col,row]:=cells[col,row]+key;
   try
     p:=strtofloat(cells[col,row]);
   except
     showmessage('输入格式错误，成本必须为正实数，请重新输入！');
   end;
   end;
  end;

end;

procedure tform1.clearcel();
var i,j:integer;
begin
  for i:=1 to n do
   for j:=1 to n do
     form1.stringgrid1.cells[i,j]:='';
end;


function tform1.checkmatrix():boolean;
 var
  i,j:integer;
begin
  checkmatrix:=true;
  for i:=1 to n do
   for j:=1 to n do
     if  form1.stringgrid1.cells[i,j]='' then
       begin
       checkmatrix:=false;exit;
       end;
end;





procedure TForm1.operationClick(Sender: TObject);

begin
  if checkmatrix=false then showmessage('成本矩阵未输入完全，请输入完整得成本矩阵！')
  else
  begin
   assign1;
  end;
end;

procedure TForm1.assign1();
var
  i,j,k,M,r,l,d,t:integer;
  B,C,W,F,U:array of array of real;
  S:array of array of integer;
  q,x:real;
begin
  M:=2*n+2;
  d:=M-2;
  t:=M-1;
  q:=1000000;//代表正无穷。
  //构造费用矩B和容量矩阵C
  setlength(B,M,M);
  setlength(C,M,M);
  setlength(F,M,M);
  for i:=0 to M-1 do
   for j:=0 to M-1 do
    begin
      if i=j then
       begin
        B[i,j]:=0;c[i,j]:=q;
       end
      else
       begin
        if i<n then
         begin
          if (j>n-1) and (j<2*n) then
           begin
            B[i,j]:=strtofloat(form1.stringgrid1.cells[j+1-n,i+1]);
            C[i,j]:=q;
           end
           else
            begin
               B[i,j]:=q;C[i,j]:=0;
            end;
          end
         else if i<M-1 then
            begin
             if (j<n) and (i=M-2) then
              begin
                B[i,j]:=0;C[i,j]:=1;
              end
              else if (j=M-1) and (i<M-2) then
                begin
                B[i,j]:=0;C[i,j]:=1;
                end
              else
               begin
                 B[i,j]:=q;C[i,j]:=0;
               end;
            end
         else
           begin
            B[i,j]:=q;C[i,j]:=0;
           end;
       end;
      F[i,j]:=0;
    end;
//计算网络得最小费用最大流
// 1/构造权矩阵
 setlength(W,M,M);
repeat
 for i:=0 to M-1 do
   for j:=0 to M-1 do
   begin
    if i=j then W[i,j]:=0
    else
     begin
       if C[i,j]>0 then
         begin
           if F[i,j]<C[i,j] then W[i,j]:=B[i,j]
           else W[i,j]:=q;
           if F[i,j]>0 then W[j,i]:=-B[i,j]
           else W[j,i]:=q;
         end
        else W[i,j]:=q;
     end;
   end;
// 2/计算最短路径
 setlength(S,M,M);
 setlength(U,M,M);
 for i:=0 to M-1 do
   for j:=0 to M-1 do
   begin
      U[i,j]:=W[i,j];
      S[i,j]:=j+1;
   end;
  for k:=0 to M-1 do
   for i:=0 to M-1 do
    for j:=0 to M-1 do
      if U[i,j]>U[i,k]+U[k,j] then
       begin
         U[i,j]:=U[i,k]+U[k,j];
         S[i,j]:=S[i,k];
       end;
//3判断增广链
 if U[d,t]=q then
 begin
  break;
 end
 else
 //调整
  begin
    l:=d;r:=S[d,t]-1;
    if C[l,r]>0 then x:=C[l,r]-F[l,r]
    else x:=F[r,l];
    repeat
      if r=t then break
      else
        begin
          l:=r;r:=S[r,t]-1;
          if (C[l,r]>0) and (x>(C[l,r]-F[l,r])) then
          x:=C[l,r]-F[l,r];
          if (C[l,r]=0) and (x>F[r,l]) then
          x:=F[r,l];
        end;
    until r=t;
    l:=d;r:=S[d,t]-1;
    repeat
      if C[l,r]>0 then F[l,r]:=F[l,r]+x
      else F[r,l]:=F[r,l]-x;
      if r=t then break
      else
        begin
          l:=r;r:=S[r,t]-1;
        end;
     until false;

  end;
  until false;
//输出指派结果
 setlength(W,n,n);//重用变量W来装载输出结果
 for i:=0 to n-1 do
   for k:=0 to n-1 do
     begin
       j:=n+k;
       W[i,k]:=F[i,j];
     end;
  form2:=Tform2.create(nil);

  //计算最优总成本
  x:=0;
  for i:=0 to n-1 do
    for k:=0 to n-1 do
     begin
        x:=x+W[i,k]*strtofloat(form1.StringGrid1.Cells[k+1,i+1]);
     end;
     form2.memo1.Lines.Add('最优总成本＝'+floattostr(x));
  //列出最优指派方案
  for i:=0 to n-1 do
   for k:=0 to n-1 do
     begin
       if W[i,k]=1 then
        begin
        form2.memo1.Lines.Add('工人'+inttostr(i+1)+'  指派: '+' 任务'+inttostr(k+1));
        break;
        end;
     end;
    form2.showmodal;

 end;




procedure TForm1.PageControl1Change(Sender: TObject);
begin
 if pagecontrol1.ActivePage=tabsheet2 then
    edit1.SetFocus;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  form4.show;
  form1.Release;

end;

end.