lstepu.pas

运筹学演示程序之运输问题

unit LstepU;

interface
uses
  Windows,Messages,SysUtils,Classes,StdCtrls,Controls,Forms,
  Grids,Dialogs,ExtCtrls,BasicU;

const
   size=300;
var
   stack:array[1..size,1..4] of integer;
procedure large_init(pc,sc:byte;var amount:matrix);
function large_step(pc,sc:byte;produce,sale:array of real;
      cost:matrix;var amount:matrix;var i1:Timage;var i2:Timage;
      var lab:tlabel):real;

implementation

PROCEDURE large_init(pc,sc:byte;var amount:matrix);
var tuihua,getpoint:boolean;
    i,j,c,x,y:byte;
    u,v : array of real;
    ub,vb : array of boolean;
  procedure check_u_v;
  var i,j:byte;
      notgetone:boolean;
  begin
    for i:=0 to pc-1 do ub[i]:=false;
    for j:=0 to sc-1 do vb[j]:=false;
    for i:=0 to pc-1 do u[i]:=-1;
    for j:=0 to sc-1 do v[j]:=-1;
    if (random(2)=1) then
    begin
      i:=random(pc);
      ub[i]:=true;
      u[i]:=0;
    end
    else
    begin
      j:=random(sc);
      vb[j]:=true;
      v[j]:=0;
    end;
    repeat
      notgetone:=true;
      for j:=0 to sc-1 do
        if (vb[j]) then
          for i:=0 to pc-1 do
            if ((not ub[i])and(amount[i,j]>=0)) then
            begin
              u[i]:=amount[i,j]-v[j];
              ub[i]:=true;
              notgetone:=false;
            end;
      for i:=0 to pc-1 do
        if (ub[i]) then
          for j:=0 to sc-1 do
            if ((not vb[j])and(amount[i,j]>=0)) then
            begin
              v[j]:=amount[i,j]-u[i];
              vb[j]:=true;
              notgetone:=false;
            end;
    until notgetone;
  end;
BEGIN
  setlength(u,pc);
  setlength(v,sc);
  setlength(ub,pc);
  setlength(vb,sc);
  c:=0;
  for i:=0 to pc-1 do
    for j:=0 to sc-1 do
      begin
        if (amount[i,j]=0) then amount[i,j]:=-1 //设置-1以作为区别
        else c:=c+1;
      end;
  tuihua:=false;
  if (c<(pc+sc-1)) then tuihua:=true;
  if (tuihua) then
  begin
   repeat
    check_u_v;
    getpoint:=false;
    i:=0;  j:=0;  x:=0;  y:=0;
    while ((i<=pc-1)and(ub[i])) do i:=i+1;
    if (ub[i]) then
      while ((j<=sc-1)and(vb[j])) do j:=j+1;
    if (not ub[i]) then
    begin
      for j:=0 to sc-1 do
        if (vb[j]) then
        begin
          x:=i; y:=j;
          getpoint:=true;
        end;
    end
    else if (not vb[j]) then
    begin
      for i:=0 to pc-1 do
        if (ub[i]) then
        begin
          x:=i; y:=j;
          getpoint:=true;
        end;
    end;
    if (not getpoint) then
    begin
      repeat
        i:=random(pc);
        j:=random(sc);
      until (((ub[i])and(not vb[j]))or((not ub[i])and(vb[j])));
      x:=i;   y:=j;
    end;
    if (amount[x,y]<0) then
    begin
      amount[x,y]:=0;
      c:=c+1;
    end
    else
    begin
      messagedlg('位势法初始化失败，请重试。',mterror,[mbok],0);
      exit;
    end;
   until (c>=(pc+sc-1));
  end;
END;

FUNCTION large_step(pc,sc:byte;produce,sale:array of real;
      cost:matrix;var amount:matrix;var i1:Timage;var i2:Timage;
      var lab:tlabel):real;
var
  u,v : array of real;
  ub,vb : array of boolean;
  x,y:byte;
  test : matrix;
  do_fail:boolean;
  all_done:boolean;
  counter:integer;
  rc:real;
  function u_v_counted:boolean;
  var d:boolean;i:byte;
  begin
    d:=true;
    for i:=0 to pc-1 do if (not ub[i]) then d:=false;
    for i:=0 to sc-1 do if (not vb[i]) then d:=false;
    result:=d;
  end;
  procedure check_u_v;
  var i,j:byte;
  begin
    for i:=0 to pc-1 do ub[i]:=false;
    for j:=0 to sc-1 do vb[j]:=false;
    if (random(2)=1) then
    begin
      i:=random(pc);
      ub[i]:=true;
      u[i]:=0;
    end
    else
    begin
      i:=random(sc);
      vb[i]:=true;
      v[i]:=0;
    end;
    repeat
      for j:=0 to sc-1 do
        if (vb[j]) then
          for i:=0 to pc-1 do
            if ((not ub[i])and(amount[i,j]>=0)) then
            begin
              u[i]:=cost[i,j]-v[j];
              ub[i]:=true;
            end;
      for i:=0 to pc-1 do
        if (ub[i]) then
          for j:=0 to sc-1 do
            if ((not vb[j])and(amount[i,j]>=0)) then
            begin
              v[j]:=cost[i,j]-u[i];
              vb[j]:=true;
            end;
    until u_v_counted;
  end;
  procedure do_test;
  var i,j:byte;
  begin
    for i:=0 to pc-1 do
      for j:=0 to sc-1 do
        test[i,j]:=u[i]+v[j];
  end;
  function find_x_y(var x:byte;var y:byte):boolean;
  var i,j:byte; min,k:real; g:boolean;
  begin
    min:=0; g:=false;
    for i:=0 to pc-1 do
      for j:=0 to sc-1 do
      begin
        k:=cost[i,j]-test[i,j];
        if (k<min) then
        begin
          min:=k;
          x:=i;
          y:=j;
          g:=true;
        end;
      end;
    result:=g;
  end;
  function north(var x:byte;var y:byte):boolean;
  var i:byte;  get:boolean;
  begin
    if (x<=0) then
    begin
      result:=false;
      exit;
    end;
    i:=x-1;
    get:=false;
    while ((i>0)and(amount[i,y]<0)) do
      i:=i-1;
    if(amount[i,y]>=0) then
    begin
      x:=i;
      get:=true;
    end;
    result:=get;
  end;
  function south(var x:byte;var y:byte):boolean;
  var i:byte;  get:boolean;
  begin
    if (x>=(pc-1)) then
    begin
      result:=false;
      exit;
    end;
    i:=x;
    get:=false;
    repeat
      i:=i+1;
    until ((i>=(pc-1))or(amount[i,y]>=0));
    if ((i<pc)and(amount[i,y]>=0)) then
    begin
      x:=i;
      get:=true;
    end;
    result:=get;
  end;
  function east(var x:byte;var y:byte):boolean;
  var i:byte;  get:boolean;
  begin
    if (y>=(sc-1)) then
    begin
      result:=false;
      exit;
    end;
    i:=y;
    get:=false;
    repeat
      i:=i+1;
    until ((i>=(sc-1))or(amount[x,i]>=0));
    if ((i<sc)and(amount[x,i]>=0)) then
    begin
      y:=i;
      get:=true;
    end;
    result:=get;
  end;
  function west(var x:byte;var y:byte):boolean;
  var i:byte;  get:boolean;
  begin
    if (y<=0) then
    begin
      result:=false;
      exit;
    end;
    i:=y-1;
    get:=false;
    while((i>0)and(amount[x,i]<0)) do
      i:=i-1;
    if (amount[x,i]>=0) then
    begin
      y:=i;
      get:=true;
    end;
    result:=get;
  end;
  function turn_right(var m:byte;var n:byte;var base:byte):boolean;
  var get:boolean;
  begin
    base:=base+1;
    if(base>4)then base:=1;
    case base of
      2: get:=east(m,n);
      3: get:=south(m,n);
      4: get:=west(m,n);
      else get:=north(m,n);
    end;
    result:=get;
  end;
  function turn_left(var m:byte;var n:byte;var base:byte):boolean;
  var get:boolean;
  begin
    base:=base-1;
    if(base<1)then base:=4;
    case base of
      2: get:=east(m,n);
      3: get:=south(m,n);
      4: get:=west(m,n);
      else get:=north(m,n);
    end;
    result:=get;
  end;
  function push_stack(x,y:byte;dr,dir:byte):boolean;
  var i:integer;
  begin
    i:=0;
    repeat
      i:=i+1;
    until (i>=size)or(stack[i,1]=-1);
    if (stack[i,1]<>-1) then result:=false
    else
    begin
      stack[i,1]:=x;
      stack[i,2]:=y;
      stack[i,3]:=dr;
      stack[i,4]:=dir;
      result:=true;
    end;
  end;
  function pop_stack(var x:byte;var y:byte;
                  var dr:byte;var dir:byte):boolean;
  var i:integer;
  begin
    i:=0;
    repeat
      i:=i+1;
    until (i>=size)or(stack[i,1]=-1);
    if (stack[i,1]=-1) then
    begin
      i:=i-1;
      if (i>1) then
      begin
        x:=stack[i,1];
        y:=stack[i,2];
        dr:=stack[i-1,4];
        dir:=stack[i,4];
        stack[i,1]:=-1;
        result:=true;
      end
      else if(stack[1,1]<>-1) then begin
        x:=stack[1,1];
        y:=stack[1,2];
        dir:=stack[1,4]-1;
        if (dir<1) then dir:=4;
        dr:=dir;
        stack[1,1]:=-1;
        result:=true;
      end
      else result:=true;
    end
    else result:=false;
  end;
  function in_stack(x,y:byte):byte;
  var i,j:integer;
  begin
    j:=0;
    for i:=1 to size do
      if((stack[i,1]=x)and(stack[i,2]=y)) then
        j:=i;
    result:=j;
  end;
  procedure cl_stack(j:byte);
  var i:integer;
  begin
    for i:=j to size do
      stack[i,1]:=-1;
  end;
  function opp(dr,dir:byte):boolean;
  var i:byte;
  begin
    i:=dr+2;
    if (i>4) then i:=i mod 4;
    if (i=dir)then
       result:=true
    else
       result:=false;
  end;
  function left_to(dir,dr:byte):boolean;
  var i:byte;
  begin                   // dr 向左转过90度后与 dir 方向相反。
    i:=dr+1;
    if (i>4) then i:=i mod 4;
    if (i=dir) then result:=true
    else result:=false;
  end;
  function getlength:byte;
  var i:integer;
  begin
    i:=1;
    while ((stack[i,1]<>-1)and(i<=size)) do
      i:=i+1;
    if (stack[i,1]=-1) then i:=i-1;
    result:=i;
  end;
  function build_path(old_x,old_y:byte):boolean;
  var x,y:byte;  i:integer;
      m,n:byte;  get,rs:boolean;
      dr,dir:byte;
      fail:boolean;
  begin
    fail:=false;
    for i:=1 to size do stack[i,1]:=-1;
    amount[old_x,old_y]:=0;
    m:=old_x;  n:=old_y;
    dir:=1;  get:=true;  rs:=false;
    repeat
      x:=m; y:=n;
      if (get) then
      begin
        dr:=dir;
        if (not turn_right(x,y,dr)) then
        repeat
          get:=turn_left(x,y,dr);
        until ((get)or(left_to(dir,dr)));
      end else begin
        while ((not get)and(not left_to(dir,dr))) do
          get:=turn_left(x,y,dr);
      end;
      if (not get) then
      begin
        fail:=not pop_stack(m,n,dir,dr);
      end
      else
      begin
        push_stack(m,n,dir,dr);
        m:=x;  n:=y;  dir:=dr;
        if ((x=old_x)and(y=old_y)and(getlength>1)) then
          rs:=true;
      end;
    until ((rs)or(fail));
    result:=not fail;
  end;
  procedure settle_stack;
  var i,j,k:byte; get:boolean;
  begin
    repeat
      j:=getlength;
      get:=false;
      for i:=2 to j-1 do
        if((stack[i,1]=stack[i+1,1])and(stack[i,1]=stack[i-1,1])) then
        begin
          get:=true;
          for k:=i to j-1 do
            stack[k]:=stack[k+1];
          stack[j,1]:=-1;
          break;
        end;
      j:=getlength;
      for i:=2 to j-1 do
        if((stack[i,2]=stack[i+1,2])and(stack[i,2]=stack[i-1,2])) then
        begin
          get:=true;
          for k:=i to j-1 do
            stack[k]:=stack[k+1];
          stack[j,1]:=-1;
          break;
        end;
    until (not get);
    j:=getlength;
    if ((j>2)and(stack[j-1,1]=stack[j,1])and(stack[1,1]=stack[j,1])) then
      stack[j,1]:=-1;
    j:=getlength;
    if ((j>2)and(stack[j-1,2]=stack[j,2])and(stack[1,2]=stack[j,2])) then
      stack[j,1]:=-1;
  end;
  function get_x:real;
  var st:array of boolean;
      i,j:byte; temp:boolean;
      min:real;
  begin
    j:=getlength;
    setlength(st,j);
    temp:=false;
    for i:=0 to j-1 do
    begin
      st[i]:=temp;
      temp:=not temp;
    end;
    min:=-1;
    for i:=0 to j-1 do
      if (st[i]) then
      begin
        if (min=-1) then min:=amount[stack[i+1,1],stack[i+1,2]]
        else if (min>amount[stack[i+1,1],stack[i+1,2]]) then
          min:=amount[stack[i+1,1],stack[i+1,2]];
      end;
    result:=min;
  end;
  function get_result(x:real):real;
  var i,j,counter:byte;
      dot1,dot2:real;
      i1,i2:byte;
      am,rs:real;
      temp:boolean;
  begin
    j:=getlength;
    counter:=0;
    temp:=false;
    for i:=1 to j do
    begin
      am:=amount[stack[i,1],stack[i,2]];
      if (temp) then
      begin
        if (am=x) then
        begin
          amount[stack[i,1],stack[i,2]]:=-1;
          counter:=counter+1;
        end
        else
          amount[stack[i,1],stack[i,2]]:=am-x;
      end else begin
        amount[stack[i,1],stack[i,2]]:=am+x;
      end;
      temp:=not temp;
    end;
    if (counter>1) then         //出现退化
    begin
     repeat
      i1:=0; i2:=0;
      dot1:=0; dot2:=0;
      for i:=1 to j do
      if (amount[stack[i,1],stack[i,2]]=-1) then
      begin
        if (i1=0) then begin
          i1:=i;
          dot1:=cost[stack[i,1],stack[i,2]];
        end else begin
          i2:=i;
          dot2:=cost[stack[i,1],stack[i,2]];
        end;
      end;
      if(dot2<dot1)then
        amount[stack[i2,1],stack[i2,2]]:=0
      else
        amount[stack[i1,1],stack[i1,2]]:=0;
      counter:=counter-1;
     until (counter<=1);
    end;
    rs:=0;
    for i:=0 to pc-1 do
     for j:=0 to sc-1 do
       if (amount[i,j]>0) then
         rs:=rs+amount[i,j]*cost[i,j];
    result:=rs;
  end;
  function get_rc:real;
  var i,j:byte;
      rs:real;
  begin
    rs:=0;
    for i:=0 to pc-1 do
     for j:=0 to sc-1 do
       if (amount[i,j]>0) then
         rs:=rs+amount[i,j]*cost[i,j];
    result:=rs;
  end;
BEGIN
  all_done:=false;
  counter:=0;
  rc:=-1;
  repeat
  repeat
  do_fail:=false;
  setlength(test,pc,sc);
  setlength(u,pc);
  setlength(v,sc);
  setlength(ub,pc);
  setlength(vb,sc);
  check_u_v;
  do_test;
  if (find_x_y(x,y)) then
  begin
    do_fail:=not build_path(x,y);
    settle_stack;
    if (not do_fail) then
    begin
      counter:=counter+1;
      if (i1.visible) then begin
        i1.visible:=false;
        i2.bringtofront;
        i2.visible:=true;
        i2.refresh;
      end else begin
        i1.bringtofront;
        i1.visible:=true;
        i2.visible:=false;
        i1.refresh;
      end;
      lab.caption:='正在进行第'+inttostr(counter)+'次迭代运算 . . . ';
      lab.refresh;
      rc:=get_result(get_x);
    end;
  end
  else
  begin
    all_done:=true;
    rc:=get_rc;
  end;
  until (not do_fail);
  until all_done;
  result:=rc;
END;

end.