stepu.pas

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

    begin
        grid1.Cells[y+1,x+1]:='('+floattostr(test[x,y])+')／('
                        +floattostr(cost[x,y])+')';
{
        h:=grid1.DefaultRowHeight;
        w:=grid1.DefaultColWidth;
        with grid1.Canvas do
        begin
          pen.color:=cllime;
          pen.width:=1;
          MoveTo((y+1)*w+y,(x+1)*h+(h div 2)+x);
          lineto((y+2)*w+y,(x+1)*h+(h div 2)+x);
          font.Color:=clred;
          font.Size:=11;
          textout((y+1)*w+y+5,(x+1)*h+x+2,'('+floattostr(test[x,y])+')');
          textout((y+1)*w+y+5,(x+1)*h+(h div 2)+x+2,'('+floattostr(cost[x,y])+')');
        end;
}
        grid1.refresh;
        pause(ptime);
    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;              // dir 向左转过90度后与 dr 相同
    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
  rc:=-1;
  repeat
  do_fail:=false;
  for i:=1 to pc do
    grid2.cells[0,i]:=floattostr(produce[i-1]);
  for j:=1 to sc do
    grid2.cells[j,0]:=floattostr(sale[j-1]);
  for i:=1 to pc do for j:=1 to sc do
  begin
    if (amount[i-1,j-1]>=0) then
      grid2.cells[j,i]:=floattostr(amount[i-1,j-1])
    else
      grid2.cells[j,i]:='';
  end;
  grid2.refresh;
  for i:=1 to pc do for j:=1 to sc do
  begin
    if (amount[i-1,j-1]>=0) then
      grid1.cells[j,i]:=floattostr(cost[i-1,j-1])
    else
      grid1.cells[j,i]:='';
  end;
  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
      for i:=1 to pc do for j:=1 to sc do
        grid2.cells[j,i]:='';
      grid2.refresh;
      kuang:=grid2.DefaultColWidth;
      gao:=grid2.DefaultRowHeight;
      for i:=1 to 3 do
      begin
        with grid2.Canvas do
        begin
          for j:=1 to getlength do
            grid2.cells[stack[j,2]+1,stack[j,1]+1]:='';
          grid2.refresh;
          pen.color:=clred;
          brush.color:=clred;
          pen.width:=1;
            ellipse((stack[1,2]+1)*kuang+(kuang div 2)-2 , (stack[1,1]+1)*gao+(gao div 2)-2,
                    (stack[1,2]+1)*kuang+(kuang div 2)+2 , (stack[1,1]+1)*gao+(gao div 2)+2);
          pen.color:=clblue;
          brush.color:=clblue;
          for j:=2 to getlength do
            ellipse((stack[j,2]+1)*kuang+(kuang div 2)-2 , (stack[j,1]+1)*gao+(gao div 2)-2,
                    (stack[j,2]+1)*kuang+(kuang div 2)+2 , (stack[j,1]+1)*gao+(gao div 2)+2);
          pause(500);
          pen.color:=clfuchsia;
          pen.width:=2;
          moveto((stack[1,2]+1)*kuang+(kuang div 2) , (stack[1,1]+1)*gao+(gao div 2));
          for j:=2 to getlength do
            lineto((stack[j,2]+1)*kuang+(kuang div 2) , (stack[j,1]+1)*gao+(gao div 2));
          lineto((stack[1,2]+1)*kuang+(kuang div 2) , (stack[1,1]+1)*gao+(gao div 2));
        end;
        pause(500);
      end;
      for i:=1 to pc do for j:=1 to sc do
      begin
        if (amount[i-1,j-1]>=0) then
          grid2.cells[j,i]:=floattostr(amount[i-1,j-1])
        else
          grid2.cells[j,i]:='';
      end;
      grid2.refresh;
      pause(1000);
      rc:=get_result(get_x);
      for i:=1 to pc do for j:=1 to sc do
      begin
        if (amount[i-1,j-1]>=0) then
          grid2.cells[j,i]:=floattostr(amount[i-1,j-1])
        else
          grid2.cells[j,i]:='';
      end;
      grid2.refresh;
    end;
    getend:=false;
  end
  else
  begin
    rc:=get_rc;
    getend:=true;
  end;
  until (not do_fail);
  edt.text:=floattostr(rc);
  edt.refresh;
  result:=getend;
END;

end.