stepu.pas

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

    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;
  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
      rc:=get_result(get_x);
  end
  else
  begin
    all_done:=true;
    rc:=get_rc;
  end;
  until (not do_fail);
  until all_done;
  result:=rc;
END;

FUNCTION draw_step(pc,sc:byte;produce,sale:array of real;
      cost:matrix;var amount:matrix;
      var grid1:TStringGrid;var grid2:Tstringgrid;
      ptime:dword;var edt:Tedit):boolean;
var
  u,v : array of real;
  ub,vb : array of boolean;
  x,y:byte;
  test : matrix;
  i,j:byte;
  do_fail:boolean;
  rc:real;
  kuang,gao:integer;
  getend:boolean;
  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;
    grid1.cells[0,0]:='Ui\Vj';
    for i:=1 to pc do
      grid1.cells[0,i]:='';
    for j:=1 to sc do
      grid1.cells[j,0]:='';
    grid1.refresh;
    if (random(2)=1) then
    begin
      i:=random(pc);
      ub[i]:=true;
      u[i]:=0;
      grid1.cells[0,i+1]:='0';
    end
    else
    begin
      i:=random(sc);
      vb[i]:=true;
      v[i]:=0;
      grid1.cells[i+1,0]:='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];
              grid1.cells[0,i+1]:=floattostr(u[i]);
              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];
              grid1.cells[j+1,0]:=floattostr(v[j]);
              vb[j]:=true;
            end;
      grid1.refresh;
      pause(ptime);
    until u_v_counted;
  end;
  procedure do_test;
  var i,j:byte; h,w:integer;
  begin
    for i:=0 to pc-1 do
      for j:=0 to sc-1 do
        test[i,j]:=u[i]+v[j];
    for i:=0 to pc-1 do for j:=0 to sc-1 do
      if (amount[i,j]<0) then
//      begin
        grid1.Cells[j+1,i+1]:=floattostr(test[i,j])+'／'+floattostr(cost[i,j]);
{
        h:=grid1.DefaultRowHeight;
        w:=grid1.DefaultColWidth;
        with grid1.Canvas do
        begin
          pen.color:=cllime;
          pen.width:=1;
          MoveTo((j+1)*w+j,(i+1)*h+(h div 2)+i);
          lineto((j+2)*w+j,(i+1)*h+(h div 2)+i);
          if (test[i,j]<=cost[i,j]) then font.color:=cllime
          else font.color:=clred;
          font.size:=11;
          textout((j+1)*w+5+j,(i+1)*h+2+i,floattostr(test[i,j]));
          font.color:=clblue;
          textout((j+1)*w+5+j,(i+1)*h+(h div 2)+2+i,floattostr(cost[i,j]));
        end;
      end;
}
    grid1.refresh;
  end;
  function find_x_y(var x:byte;var y:byte):boolean;
  var i,j:byte; min,k:real; g:boolean;
      h,w:integer;
  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;
    if (g) then