unit1.pas

很好运筹学的DEOPHI原代码.包括动态规划,原始单纯形法,对策论,决策论等

unit unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Grids, Buttons,math;
const long=255;
type
  Tfrmshuju = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    Edit1: TEdit;
    BitBtn1: TBitBtn;
    RadioGroup1: TRadioGroup;
    Panel3: TPanel;
    Label3: TLabel;
    BitBtn2: TBitBtn;
    GroupBox1: TGroupBox;
    StringGrid1: TStringGrid;
    Label2: TLabel;
    BitBtn3: TBitBtn;
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure RadioGroup1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmshuju: Tfrmshuju;

implementation

{$R *.dfm}  
type  myset=set of 1..long;//自定义集合类型，集合元素类型为整型，
      //范围1..long。
type myarray=array[1..long,1..long] of real;
var  n:Integer;
     a0,a:myarray;
     leixing:string;
     P:array[1..long,1..long] of Integer;
     Q:array[1..long,1..long] of Integer;
     M:array[1..long,1..long] of Integer;
     JJ,LL,HH,LLL:myset;

procedure  bianhuan_max;
var i,j:integer;
    max:real;
begin
max:=a[1,1];
for i:=1 to n do
  for j:=1 to n do
    if a[i,j]>max then
      max:=a[i,j];
  //找出矩阵中的最大元素
max:=max+100;//确保这个元素比矩阵A的每一个元素都大的多
for i:=1 to n do
  for j:=1 to n do
    a[i,j]:=max-a[i,j];
 //用以个很大的元素减去矩阵A的每一个元素
end;
{--------------对目标函数是求最大化问题是的处理----------------}

procedure  flood;
var i,j:integer;
    min: real;
begin
for i:=1 to n do
  begin
    min:=a[i,1];
    for j:=2 to n do
      if min>a[i,j] then
         min:=a[i,j];//找出每行中的最小元素
    for j:=1 to n do
      a[i,j]:=a[i,j]-min;//减去这个最小元素
  end;
for j:=1 to n do
  begin
    min:=a[1,j];
    for i:=2 to n do
      if min>a[i,j] then
        min:=a[i,j];//找出每列中的最小元素
    for i:=1 to n do
      a[i,j]:=a[i,j]-min;//减去这个最小元素
  end;
for i:=1 to n do
  for j:=1 to n do
    if a[i,j]=0 then
      M[i,j]:=1  //表示A[I,J]为零
    else
      M[i,j]:=0; //非零
  //标识0元素,对应原理第二步
for i:=1 to long do
  for j:=1 to long do
    begin
      q[i,j]:=0;//取0表示未分配
      p[i,j]:=0;
    end;
end;
{----------变换效率矩阵，并标识0元素-------------------------------}

procedure  feipei;
var i,j:Integer;
    ling:array[1..long] of integer;//存放各行0元素的个数
    temp:integer;
    r,s:Integer;
    ss:array[1..long,1..long] of Integer;
begin
temp:=0;
r:=1;s:=1;//初始化 
for i:=1 to n do
  begin
    ling[i]:=0;
    for j:=1 to n do
       if M[i,j]=1 then
          ling[i]:=ling[i]+1;
  end;//找出各行的0元素的个数
for i:=1 to  n do
  if ling[i]>0 then
     begin
       temp:=ling[i];//初始化最小0元素的个数
       r:=i;
       Break;
     end;
for i:=r+1 to n do
  if (ling[i]>0) and (temp>ling[i]) then
     begin
       temp:=ling[i];
       r:=i;
     end;//找0元素最少的行
for j:=1 to n do
  if M[r,j]=1 then
    begin
     s:=j;
     break;
    end;//在0元素最少的行中选取一个0元素
//第一步完成
q[r,s]:=1;
for i:=1 to long do
 for j:=1 to long do
   ss[i,j]:=0;
for i:=1 to n do
  if (i<>r) and (m[i,s]=1) then
    ss[i,s]:=1; //标识关键列的0元素
for j:=1 to n do
  if (j<>s) and (M[r,j]=1) then
    ss[r,j]:=1;//标识关键行的0元素
for i:=1 to n do
  for j:=1 to n do
     if ss[i,j]=1 then
        begin
          p[i,j]:=1;//记录所有非关键的0元素
          M[i,j]:=0;//更新等待分配的0元素的集合
        end;
M[r,s]:=0;//更新等待分配的0元素的集合
end;
{-----------------分配-------------------------}

function five_panduan:boolean;
var i,j:Integer;
begin
 Result:=True;
 for i:=1 to n do
   for j:=1 to n do
     if M[i,j]=1 then
       begin
         Result:=False;
         Exit;
       end;
end;
{-----------------判断是否所有0元素全被分派完毕------------------}

function six_panduan:boolean;
var i,j:Integer;
    geshu:Integer;
begin
geshu:=0;
for i:=1 to n do
  for j:=1 to n do
    if q[i,j]=1 then
      geshu:=geshu+1;//计算独立0元素的个数
if geshu=n then
  Result:=True
else Result:=False;
end;
{------------判断独立0元素的个数是否等于n个----------------}

procedure dagou;
var ling_r,gou_r_1,gou_r_2,gou_s:myset;
     i,j:integer;
     biaoshi:array[1..long,1..long] of Integer;
     min:real;zhi:real;
     label 1,2;
begin
flood;
while not five_panduan do feipei;
2:ling_r:=[];
  gou_r_1:=[];
  gou_r_2:=[];
  gou_s:=[];
  while  six_panduan do
    begin
     zhi:=0;
     for i:=1 to n do
         for j:= 1 to n do
           begin
            frmshuju.StringGrid1.Cells[j-1,i-1]:=IntToStr(q[i,j]);
            zhi:=zhi+a0[i,j]*q[i,j];//计算目标函数值
           end;
     frmshuju.Label2.Caption:='求得'
       +FormatFloat('值为：0.######',zhi)+'  最优分配方案如下表所示';
     frmshuju.GroupBox1.Caption:='分配矩阵';//显示最优分配方案和最优分配结果
   //显示运算结果
     frmshuju.BitBtn3.Enabled:=False;
     exit;
    end;
  for i:=1 to n do
    for j:=1 to n do
     if q[i,j]=1 then ling_r:=ling_r+[i];
  gou_r_1:=[1..n]-ling_r;
1:for i:=1 to n do
    if i in gou_r_1 then
       for j:=1 to n do
         if a[i,j]=0 then gou_s:=gou_s+[j];
  gou_r_2:=gou_r_1;
  for j:=1 to n do
    if j in gou_s then
       for i:=1 to n do
         if q[i,j]=1 then  gou_r_2:=gou_r_2+[i];
  if gou_r_1<>gou_r_2 then
     begin
      gou_r_1:=gou_r_2;
      goto  1;
     end;
   if six_panduan then
    begin
       zhi:=0;
       for i:=1 to n do
         for j:= 1 to n do
           begin
            frmshuju.StringGrid1.Cells[j-1,i-1]:=IntToStr(q[i,j]);
            zhi:=zhi+a0[i,j]*q[i,j];//计算目标函数值
           end;
     frmshuju.Label2.Caption:='求得'
       +FormatFloat('值为：0.######',(zhi))+'  最优分配方案如下表所示';
     frmshuju.GroupBox1.Caption:='分配矩阵';//显示最优分配方案和最优分配结果
   //显示运算结果 
     end
  else
     begin
       for i:=1 to n do
         for j:=1 to n do
          if (i in gou_r_1) and not (j in gou_s) then
            biaoshi[i,j]:=-1
          else if not (i in gou_r_1) and (j in gou_s) then
            biaoshi[i,j]:=1
          else biaoshi[i,j]:=0;
       min:=10000000;
       for i:=1 to n do
         for j:=1 to n do
           if (biaoshi[i,j]=-1) and (min>a[i,j]) then
             min:=a[i,j];
       for i:=1 to n do
         for j:=1 to n do
           a[i,j]:=a[i,j]+biaoshi[i,j]*min;
       for i:=1 to n do
         for j:=1 to n do
           begin
            q[i,j]:=0;
            if a[i,j]=0 then m[i,j]:=1;
           end;
       while not five_panduan do  feipei;
       goto 2;
     end;
end;

procedure seven;
var i,j:Integer;
  rr,ss:set of 1..long;
begin
LL:=[];
JJ:=[];
rr:=[];
ss:=[];//定义四个下标集合
for i:=1 to n do
  for j:=1 to n do
    begin
      if q[i,j]=1 then
        rr:=rr+[i]; //有关键0元素的行（已经分配过的行）
      if p[i,j]=1 then
        ss:=ss+[j];//有关键0元素的列（已经分配过的列）
    end;
for i:=1 to n do
  for j:=1 to n do
    begin
      if not (i in rr) and (a[i,j]=0) then
         ll:=ll+[i];//还没有分配的行标集合
      if (p[i,j]=1) and (a[i,j]=0) then
         JJ:=JJ+[j];//存在没有被分配的0元素的列
    end;
end;
{------------对应原理第七步----------------}

procedure eight;
var i,j:Integer;
begin
HH:=[];
LLL:=[];
for i:=1 to n do
    for j:=1 to n do
       if (i in LL) and (j in JJ) and  (a[i,j]=0) then
          HH:=HH+[j];
LLL:=LL;
for i:=1 to n do
  for j:=1 to n do
    if (j in HH) and (a[i,j]=0)  then
      LLL:=LLL+[i];
end;
{------------对应原理的第八步，行和列的标定----------------------}

procedure ten_eleven;
var i,j:Integer;
    k1:array[1..long,1..long] of Integer;
    min:real;
begin
min:=0;
for i:=1 to long do
  for j:=1 to long do
   k1[i,j]:=-1; //初始化表示集合
for i:=1 to n do
  for j:=1 to n do
    begin
      if a[i,j]=0 then
         k1[i,j]:=1;
      if not (i in LL) and (j in HH) then
            k1[i,j]:=0;
    end;
for i:=1 to n do
  for j:=1 to n do
      if  k1[i,j]=-1  then
        begin
          min:=a[i,j];
          break;
        end;
for i:=1 to n do
  for j:=1 to n do
      if  (k1[i,j]=-1) and (min>a[i,j]) then
          min:=a[i,j];
for i:=1 to n do
  for j:=1 to n do
    if k1[i,j]=1 then
        a[i,j]:=a[i,j]
    else if  k1[i,j]=0 then
        a[i,j]:=a[i,j]+min
    else a[i,j]:=a[i,j]-min;
end;
{------------对应原理的第十步和第十一步，更新效率矩阵-----------------}

procedure Tfrmshuju.BitBtn2Click(Sender: TObject);
var i,j:Integer;
begin
for i:=0 to StringGrid1.RowCount-1 do
  for j:=0 to StringGrid1.ColCount-1 do
    StringGrid1.Cells[j,i]:='';
GroupBox1.Caption:='效率矩阵';
BitBtn3.Enabled:=True;
Label2.Caption:='请在下表重新输入效率矩阵的各元素';
StringGrid1.SetFocus;
end;

procedure Tfrmshuju.BitBtn1Click(Sender: TObject);
begin
Try
  n:=StrToInt(edit1.Text);
except
  ShowMessage('输入的人员（任务）数量必须是整数');
  //出错控制
end;
with StringGrid1 do
  begin
    ColCount:=n;
    RowCount:=n;
    Width:=ColCount*(DefaultColWidth+2);
    Height:=RowCount*(DefaultRowHeight+2);//控制文本框的大小
    top:=(GroupBox1.Height-Height) div 2+20;
    Left:=(GroupBox1.Width-Width) div 2;//控制文本框的位置
  end;
Label2.Top :=StringGrid1.Top-Label2.Height-5;
 //控制标签的位置
Label2.Caption:='请在下表输入效率矩阵的各元素';
leixing:=RadioGroup1.Items[RadioGroup1.Itemindex];
  //返回目标函数类型
GroupBox1.Caption:='效率矩阵';
BitBtn2Click(sender);
StringGrid1.SetFocus;
end;


procedure Tfrmshuju.RadioGroup1Click(Sender: TObject);
begin
leixing:=RadioGroup1.Items[RadioGroup1.Itemindex];
 //返回目标函数的类型
end;

procedure Tfrmshuju.FormActivate(Sender: TObject);
begin
Label2.Caption:='';  
end;

procedure Tfrmshuju.BitBtn3Click(Sender: TObject);
var i,j:integer;
begin
for i:=1 to long do
  for j:=1 to long do
    begin
      a0[i,j]:=0;
      a[i,j]:=0;
    end;//初始化效率矩阵的各元素
for i:=1 to n do
  for j:=1 to n do
    begin
      if StringGrid1.Cells[j-1,i-1]<>'' then
         a[i,j]:=StrToFloat(StringGrid1.Cells[j-1,i-1]);
      a0[i,j]:=a[i,j];//用a0保留原始效率矩阵的值
    end;
 //读取效率矩阵数据
if leixing='Max' then
   bianhuan_max;//对求最大化问题时，对效率矩阵先予以变换
dagou;
end;

end.