unit1.pas

研究生算法作业分支界限法求解货郎担问题

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, RXCtrls, StdCtrls, Mask, ToolEdit, CurrEdit, ExtCtrls,
  Buttons, abclabel, DsFancyButton, RXSplit;

type
  myArray = Array of Extended;
  TActiveNode=record
   Parent:Integer;
   Owner:Integer;
   cost:Extended;
   TotalChild:Integer;
   gyMatrix:array of myArray;
   usenode:Array of Integer;
  end;
  TForm1 = class(TForm)
    Timer1: TTimer;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Panel1: TPanel;
    Panel2: TPanel;
    RxLabel1: TRxLabel;
    gmEdit: TRxCalcEdit;
    Label2: TLabel;
    MaxNumEdit: TEdit;
    CheckBox1: TCheckBox;
    StringGrid1: TStringGrid;
    Panel3: TPanel;
    Panel4: TPanel;
    ConfirmBtn: TDsFancyButton;
    HLDWTBtn: TDsFancyButton;
    AboutBtn: TDsFancyButton;
    Label1: TLabel;
    Panel5: TPanel;
    Panel6: TPanel;
    LoadBtn: TDsFancyButton;
    SaveBtn: TDsFancyButton;
    Label3: TLabel;
    abcMailToLabel1: TabcMailToLabel;
    Memo2: TMemo;
    Memo1: TMemo;
    RxSplitter1: TRxSplitter;
    RxSplitter2: TRxSplitter;
    procedure gmEditChange(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure ConfirmBtnClick(Sender: TObject);
    procedure HLDWTBtnClick(Sender: TObject);
    Procedure proce_b( var m:extended);
    procedure AboutBtnClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure PutInGrid;
    procedure SaveBtnClick(Sender: TObject);
    procedure hldwt;
    procedure ZipMatrix;
    Function FindMinCost:Integer;
    Function HaveUse(i,j:Integer):Boolean;
    Function HaveCircle(j:Integer):Boolean;
    Function UseLength(j:Integer):Integer;
  private
    a,b:Array of myArray;
    mygyMatrix,myTempMatrix:Array of Array of myArray;
    myUseNode,myTempNode: Array of myArray;
    endpos:Integer;
    U, MinCost,MaxNum:Extended;
    totalNode,totalActive:Integer;
    tempLines,myLines:array of TActiveNode;
    AutoChg:Boolean;
    myTotalLength:Integer;

    { Private declarations }
  public

    { Public declarations }
  end;
Const infinity = 1.0/0.0;
var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.gmEditChange(Sender: TObject);
begin
  if AutoChg and (not Timer1.Enabled) then
    Timer1.Enabled:=True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled:=False;
  AutoChg:=True;
  TotalNode:= Round(gmEdit.Value );
  if Checkbox1.Checked then
    myTotalLength:= TotalNode*TotalNode
  else
    myTotalLength:= TotalNode*TotalNode*TotalNode;
  if TotalNode < 4 then begin
    ShowMessage('规模要大于3');
    exit;
  end;
  PutinGrid;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  MaxNum:=Infinity;
  Timer1.Enabled:=False;
  memo2.Visible:=False;
  AutoChg:=True;
end;

procedure TForm1.ConfirmBtnClick(Sender: TObject);
var
  i,j:Integer;
begin
  try
    SetLength(a,TotalNode,TotalNode);
    SetLength(b,TotalNode,TotalNode);
    SetLength(myLines,myTotalLength);
    SetLength(tempLines,myTotalLength);
    SetLength(mygyMatrix,myTotalLength,TotalNode,TotalNode);
    SetLength(myTempMatrix,myTotalLength,TotalNode,TotalNode);
    SetLength(myUseNode,myTotalLength,TotalNode);
    SetLength(myTempNode,myTotalLength,TotalNode);

    for i:=0 to myTotalLength-1 do begin
      myLines[i].gyMatrix:=@mygyMatrix[i,0];       //+inttoWord(i*TotalNode*TotalNode);
      myLines[i].useNode:=@myUseNode[i,0];         //+i*sizeof(I)*TotalNode;
      TempLines[i].gyMatrix:=@myTempMatrix[i,0];  //+i*sizeof(i)*TotalNode*TotalNode;
      TempLines[i].useNode:=@myTempNode[i,0];     //+i*sizeof(I)*TotalNode;
    end;
  Except
    ShowMessage('规模太大，无法计算');
    exit;
  end;
  for i:=0 to TotalNode-1 do
    for j:=0 to TotalNode-1 do
      if StringGrid1.Cells[i+1,j+1]='INF' then
        a[i,j]:=Infinity
      else
        a[i,j]:=StrtoFloat(StringGrid1.cells[i+1,j+1]);
  MaxNumEdit.Enabled:=False;
  StringGrid1.Enabled:=False;
  gmEdit.Enabled:=False;
  HLDWTBtn.Enabled:=True;
  for i:=0 to TotalNode-1 do
    for j:=0 to TotalNode-1 do
      b[i,j]:=a[i,j];
  AutoChg:=True;
end;

procedure TForm1.HLDWTBtnClick(Sender: TObject);
begin
  hldwt;
end;

procedure TForm1.hldwt;
var
   i,j,k,l,m:Integer;
   ll,min:Extended;
   CanRun,haveFound:Boolean;
   RStr,path:String;
begin
  AutoChg:=True;
  for i:=0 to myTotalLength-1 do begin  //付初值
    myLines[i].Cost:= MaxNum;
    myLines[i].TotalChild:=TotalNode;
    myLines[i].parent:=-1;
    for j:=0 to totalNode-1 do
      myLines[i].usenode[j]:=0;         //useNode存节点序列
    for l:=0 to TotalNode-1 do
      for m:=0 to TotalNode-1 do
        myLines[i].gyMatrix[l,m]:=MaxNum;
    for l:=0 to TotalNode-1 do
      for m:=0 to TotalNode-1 do
        TempLines[i].gyMatrix[l,m]:=MaxNum;
  end;
  U:=MaxNum;                            //U 上界值

  proce_b(min);                         //对b矩阵作规约
  myLines[0].parent:=-1;
  myLines[0].owner:=0;
  myLines[0].TotalChild:= myLines[0].TotalChild-1;
  mylines[0].cost:=min;myLines[0].usenode[0]:=0;
  for l:=0 to TotalNode-1 do
    For m:=0 to TotalNode-1 do
      myLines[0].gyMatrix[l,m]:=b[l,m];
  endpos:=1;                           //顶点编号从0开始
  canRun:=True;
  While CanRun do begin
    ZipMatrix;              //更新活节点表
    j:=FindMinCost;         //在活节点表中 找到 当前扩展节点
    if HaveCircle(j) then begin
      U:=min;
      CanRun:=False;
      Break;
    end;
    if myLines[j].TotalChild=0 then
      Continue;
    HaveFound:=False;
    for i:=1 to TotalNode-1 do begin  //寻找 扩展节点 的后继节点
      if Not HaveUse(i,j) then begin
        for l:=0 to TotalNode-1 do
         For m:=0 to TotalNode-1 do
           b[l,m]:=myLines[j].gyMatrix[l,m]; //b:=myLines[j].gyMatrix;

        for k:=0 to TotalNode-1 do begin
          b[myLines[j].owner,k]:=maxNum;
          b[k,i]:=maxNum;
	  b[i,myLines[j].owner]:=MaxNum;
        end;
        proce_b(min);
        HaveFound:=True;
        myLines[EndPos].parent:=myLines[j].owner;
        myLines[EndPos].owner:=i;
        myLines[EndPos].TotalChild:= myLines[j].TotalChild-1;
        ll:=myLines[j].gyMatrix[myLines[j].Owner,i];
        mylines[EndPos].cost:=min+ll+myLines[j].cost;
        for l:=0 to TotalNode-1 do
          For m:=0 to TotalNode-1 do
            myLines[EndPos].gyMatrix[l,m]:=b[l,m];//myLines[EndPos].gyMatrix:=b;
        for l:=0 to TotalNode-1 do
          myLines[EndPos].usenode[l]:=myLines[j].useNode[l];
        for l:=1 to totalNode-1 do begin
          if myLines[j].usenode[l]=0 then begin //将新增加的节点 添加在队列的最后（第一个是0后面的应该非0）
            myLines[EndPos].usenode[l]:=i;
            Break;
          end;
        end;
        EndPos:=Endpos+1;
      end;
    end;
    myLines[j].TotalChild:=0;
    min:=MaxNum;
    for l:=0 to myTotalLength-1 do
      if myLines[l].cost>U then
        myLines[l].cost:=MaxNum;
  end;
  CanRun:=True;
  Memo1.Lines.clear;
  while canRun do begin
    min:=myLines[0].cost;
    j:=0;
    j:=FindMinCost;
    for l:=0 to TotalNode-1 do
      b[0,l]:=myLines[j].UseNode[l]; //b:=myLines[j].gyMatrix;
    RStr:='';
    if HaveCircle(j)  then  Begin  //判断是否是完整的一个圈
      for l:=0 to totalNode-1 do
        RStr:=RStr+ FloattoStr(b[0,l]+1)+ ' ,';
      RStr:=Rstr+inttostr(myLines[j].UseNode[0]+1);
      CanRun:=False;
    end
    else
      myLines[j].cost:=MaxNum;
    RStr:=RStr+'  其最小代价为：'+FloattoStr(minCost)+' ';
    MaxNumEdit.Enabled:=True;
    MaxNumEdit.Enabled:=True;
    StringGrid1.Enabled:=True;
    gmEdit.Enabled:=True;
    Memo1.Lines.Append(RStr);
  end;
end;

Procedure TForm1.proce_b( var m:extended);
var
  pi,pj:Integer;
  pk:Extended;
begin
  m:=0;
  for pi:=0 to TotalNode-1 do begin
    pk:=MaxNum;
    for pj:=0 to TotalNode-1 do
      if(b[pi,pj]<pk) then
        pk:=b[pi,pj];
    if((pk>0)And(pk<>MaxNum)) then begin
      m:=m+pk;
      for pj:=0 to TotalNode-1 do begin
        if(b[pi,pj]<>MaxNum) then
          b[pi,pj]:=b[pi,pj]-pk;
      end;
    end;
  end;
  for pj:=0 to TotalNode-1 do begin
    pk:=MaxNum;
    for pi:=0 to TotalNode-1 do
      if(b[pi,pj]<pk) then
        pk:=b[pi,pj];
    if((pk>0) And (pk<>MaxNum)) then begin
      m:=m+pk;
      for pi:=0 to TotalNode-1 do
        if(b[pi,pj]<>MaxNum) then
          b[pi,pj]:=b[pi,pj]-pk;
    end;
  end;
end;

procedure TForm1.AboutBtnClick(Sender: TObject);
begin
 ShowMessage('程序编写：孙晓'+#13+'软件硕士，GS0206263'+#13+'谢谢!!');
end;

procedure TForm1.LoadBtnClick(Sender: TObject);
var
  i,j,k,m:Integer;
  countNum:Boolean;
  myStr:String;
begin
  if OpenDialog1.Execute then
    Memo2.Lines.LoadFromFile(OpenDialog1.FileName );
  k:=Memo2.lines.Count;
  if k<3 then exit;
  CountNum:=True;
  i:=0;
  j:=0;
  myStr:=Copy(Memo2.Lines[1],1,length(memo2.Lines[1]));
  While CountNum do begin
    j:=j+1;
    if myStr[j]=';' then i:=i+1;
    if myStr[j]='*' then CountNum:=False;
  end;
  if k<>i then begin
    ShowMessage('矩阵输入数据有错');
    Exit;
  end;
  TotalNode:=k;
  if CheckBox1.Checked then
    myTotalLength:=TotalNode*TotalNode
  else
    myTotalLength:=TotalNode*TotalNode*TotalNode;
  StringGrid1.RowCount:=TotalNode+1;
  StringGrid1.ColCount:=TotalNode+1;
  for I:=0 to TotalNode do
    For j:=0 to TotalNode do begin
      if j=0 then
        StringGrid1.Cells[i,j]:=inttoStr(i);
      if i=0 then
        StringGrid1.Cells[i,j]:=inttoStr(j);
    end;
  for i:=1 to TotalNode do begin
    myStr:= Copy(Memo2.Lines[i-1],1,length(memo2.Lines[i-1]));
    CountNum:=True;
    j:=0;m:=0 ;
    for j:=1 to TotalNode do begin
      StringGrid1.Cells[i,j]:=Copy(myStr,1,POS(';',myStr)-1);
      myStr:=Copy(myStr,POS(';',myStr)+1,length(myStr)-POS(';',myStr));
    end;
  end;
  memo2.Visible:=True;
  StringGrid1.Cells[0,0]:='代价矩阵';
  StringGrid1.FixedCols:=1;
  StringGrid1.FixedRows:=1;
  StringGrid1.Enabled:=True;
  ConfirmBtn.Enabled:=True;
  AutoChg:=False;
  gmEdit.Value:=TotalNode;
end;

procedure TForm1.PutInGrid;
var
  i,j,k:Integer;
begin
  StringGrid1.RowCount:=TotalNode+1;
  StringGrid1.ColCount:=TotalNode+1;
  for i:=0 to TotalNode do
    For j:=0 to TotalNode do begin
      StringGrid1.Cells[i,j]:=MaxNumEdit.text;
      if (i=0) and(j=0) then
        StringGrid1.Cells[i,j]:='代价矩阵'
      else begin
        if i=0 then
          StringGrid1.Cells[i,j]:=inttostr(j)
        else
          if j=0 then
            StringGrid1.Cells[i,j]:=inttostr(i)
          else
            if i=j then
              StringGrid1.Cells[i,j]:=FloattoStr(MaxNum);
      end;
    end;
  StringGrid1.FixedCols:=1;
  StringGrid1.FixedRows:=1;
  StringGrid1.Enabled:=True;
  ConFirmBtn.Enabled:=True;
end;

procedure TForm1.SaveBtnClick(Sender: TObject);
var
  i,j,m:Integer;
  myStr:String;
  fileName:TFileName;
begin
  fileName:='';
  if SaveDialog1.Execute then
    Filename:=SaveDialog1.FileName;
  if FileName='' then
    Exit;
  i:=StringGrid1.ColCount;
  j:=StringGrid1.RowCount;
  if i<>j then begin
    ShowMessage('代价矩阵有错.');
    exit;
  end;
  Memo2.Lines.clear;
  m:=i;
  for i:=1 to m-1 do begin
    myStr:='';
    for j:=1 to m-1 do begin
      myStr:=myStr+StringGrid1.Cells[j,i]+';';
    end;
    myStr:=myStr+'*';
    memo2.Lines.Append (myStr);
  end;
  memo2.Lines.SaveToFile(FileName);
  memo2.Visible:=True;
end;

procedure TForm1.ZipMatrix;
var
  i,j,son,nn,l,m:Integer;
begin
  for j:=0 to myTotalLength-1 do begin
    if (myLines[j].TotalChild=0) and (not HaveCircle(j)) then 
      myLines[j].cost:=MaxNum; //孩子都生出来了，就把该父节点删除
  end;
  for i:=0 to myTotalLength-1 do begin
    TempLines[i].cost:=MaxNum;
    TempLines[i].TotalChild:=TotalNode;
  end;
  j:=0;
  for i:=0 to myTotalLength-1 do begin
    if myLines[i].cost < U then begin
      TempLines[j].Parent :=myLines[i].Parent ;
      TempLines[j].Owner:=myLines[i].Owner ;
      TempLines[j].cost:=myLines[i].cost;
      TempLines[j].TotalChild:=myLines[i].TotalChild;
      for l:=0 to TotalNode-1 do begin
        TempLines[j].usenode[l]:=myLines[i].useNode[l];
        for m:=0 to TotalNode-1 do
          TempLines[j].gyMatrix[l,m]:=myLines[i].gyMatrix[l,m];
      end;
      j:=j+1;
    end;
  end;
  endpos:=j;
  for i:=0 to myTotalLength-1 do begin
    myLines[i].cost:=MaxNum;
    myLines[i].Parent:=-1;
    myLines[i].TotalChild:=TotalNode;
  end;
  for i:=0 to EndPos+1 do begin
    myLines[i].Parent:=TempLines[i].Parent  ;
    myLines[i].Owner :=TempLines[i].Owner ;
    myLines[i].cost:=TempLines[i].cost;
    myLines[i].TotalChild:=TempLines[i].TotalChild;
    for l:=0 to TotalNode-1 do begin
      myLines[i].useNode[l]:=TempLines[i].usenode[l];
      for m:=0 to TotalNode-1 do
        myLines[i].gyMatrix[l,m]:=TempLines[i].gyMatrix[l,m];
    end;
  end;
end;

Function TForm1.FindMinCost:Integer;
var
  i,j,num:Integer;
  mm:Extended;
begin
  mm:=myLines[0].cost;
  j:=0;
  For i:=1 to myTotalLength-1 do begin
    if myLines[i].cost<mm then begin
      j:=i;
      mm:=myLines[i].cost;
    end;
  end;
  num:=0;
  for i:=0 to myTotalLength-1 do begin
    if myLines[i].cost = mm then
      Num:=Num+1;
  end;
  if Num>1 then begin
    Num:=UseLength(j);
    for i:=0 to myTotalLength-1 do begin
      if (myLines[i].cost=mm) and (UseLength(i)>Num) then begin
        j:=i;
        num:=Uselength(i);
      end;
    end;
  end;

  Result:=j;        //返回代价最小的 活节点 编号
  MinCost:=mm;
end;

Function TForm1.HaveUse(i,j:Integer):Boolean;
var
  l:Integer;
  Founded:Boolean;
begin
  for l:=0 to TotalNode-1 do
     b[0,l]:=myLines[j].useNode[l];     //b:=myLines[j].useNode;
  Founded:=False;
  for l:=0 to TotalNode-1 do begin
    if b[0,l]=i then
      Founded:=True;
  end;
  Result:=Founded;
end;

FunCtion TForm1.HaveCircle(j:Integer):Boolean;
var
  l,k:integer;
begin
  if myLines[j].totalChild=0 then begin
    for l:=0 to TotalNode-1 do
      b[0,l]:=myLines[j].UseNode[l];
    k:=0;
    for l:=1 to TotalNode-1 do begin
      if b[0,l]>0 then
        k:=k+1;
    end;
    if k=totalNode-1 then
      Result:=True
    else
      Result:=False;
  end
  else
    Result:=False;
end;

Function TForm1.UseLength(j:Integer):Integer;
var
  l,k:Integer;
begin
  k:=0;
  for l:=0 to TotalNode-1 do begin
    if myLines[j].useNode[l]>0 then
      k:=k+1;
  end;
  Result:=k;
end;

end.