basicu.pas

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

        findcixiao:=false;
        for w:=0 to pc-1 do
          if ((done[w,v]>=0)and(cost[w,v]<cixiao)) then
          begin
            if (w<>u) then begin
              cixiao:=cost[w,v]; findcixiao:=true;
            end;
          end;
        if (findcixiao) then
          ban_s[v]:=cixiao-zuixiao
        else ban_s[v]:=0;
      end;
    end;
    for v:=0 to pc-1 do
    begin
      if (ban_p[v]>=0) then
      begin
        zuixiao:=maxint;
        for w:=0 to sc-1 do
          if ((done[v,w]>=0)and(cost[v,w]<zuixiao)) then
          begin
            u:=w;
            zuixiao:=cost[v,w];
          end;
        cixiao:=maxint;
        findcixiao:=false;
        for w:=0 to sc-1 do
          if ((done[v,w]>=0)and(cost[v,w]<cixiao)) then
          begin
            if (w<>u) then begin
              cixiao:=cost[v,w]; findcixiao:=true;
            end;
          end;
        if (findcixiao) then
          ban_p[v]:=cixiao-zuixiao
        else ban_p[v]:=0;
      end;
    end;
  end;
  procedure do_end;
  var w,v,u:byte;
      another:boolean;
  begin
    for w:=0 to pc-1 do
      for v:=0 to sc-1 do
        if (done[w,v]=0) then
        begin
          another:=false;
          for u:=0 to sc-1 do
            if ((u<>v)and(done[w,u]=0)) then another:=true;
          if (another) then
            check_spare_s(amount[w,v],v)
          else
            check_spare_p(amount[w,v],w);
        end;
  end;
BEGIN
  da:=-1;
  setlength(done,pc,sc);
  setlength(ban_p,pc);
  setlength(ban_s,sc);
  for i:=0 to pc-1 do ban_p[i]:=maxint;
  for i:=0 to sc-1 do ban_s[i]:=maxint;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
      done[i,j]:=0;
  min_i:=0;min_j:=0;
  reset_ban;
  repeat
    if (not find_min) then break;
    check_spare_s(spare_s,min_j);
    check_spare_p(spare_p,min_i);
    if (spare_p<spare_s) then
    begin
      amount[min_i,min_j]:=spare_p;
      unenable_p(min_i,min_j);
    end
    else if (spare_s<spare_p) then
    begin
      amount[min_i,min_j]:=spare_s;
      unenable_s(min_i,min_j);
    end
    else begin
      amount[min_i,min_j]:=spare_p;
      unenable_s(min_i,min_j);
      unenable_p(min_i,min_j);
    end;
    reset_ban;
  until all_done;
  do_end;
END;

PROCEDURE zdfy_init(pc,sc:byte;
        produce,sale:array of real;
        cost:matrix;var amount:matrix);
var i,j:byte;
    min,max:real;        //最低费用
    min_i,min_j:byte;    //最低费用点坐标
    spare_p,spare_s:real;
  function find_min:boolean;
  var i,j:integer;get_one:boolean;
  begin
    get_one:=false;
    if (min=-1) then min:=cost[0,0]
    else min:=max;
    for i:=0 to pc-1 do for j:=0 to sc-1 do
    begin
      if ((cost[i,j]<min)and(amount[i,j]=-2)) then
      begin
        min:=cost[i,j];
        min_i:=i; min_j:=j;
        get_one:=true;
      end;
      if (cost[i,j]>max) then max:=cost[i,j];
    end;
    result:=get_one;
  end;
  procedure unenable_s(x,y:byte);
  var i:integer;
  begin
    for i:=0 to pc-1 do
      if ((amount[i,y]=0)and(i<>x)) then amount[i,y]:=-1;
  end;
  procedure unenable_p(x,y:byte);
  var i:integer;
  begin
    for i:=0 to sc-1 do
      if ((amount[x,i]=0)and(i<>y)) then amount[x,i]:=-1;
  end;
  procedure check_spare_s(var s_s:real;y:byte);
  var m:real;i:integer;
  begin
    m:=sale[y];
    for i:=0 to pc-1 do
      if amount[i,y]>0 then m:=m-amount[i,y];
    s_s:=m;
  end;
  procedure check_spare_p(var s_p:real;x:byte);
  var m:real;i:integer;
  begin
    m:=produce[x];
    for i:=0 to sc-1 do
      if amount[x,i]>0 then m:=m-amount[x,i];
    s_p:=m;
  end;
  function all_done:boolean;
  var i,j:integer; done1,done2:boolean;
      count:real;
  begin
    done1:=true;
    for i:=0 to pc-1 do for j:=0 to sc-1 do
      if (amount[i,j]=-2) then done1:=false;
    if (not done1) then
    begin
      done2:=true;
      for i:=0 to pc-1 do
      begin
        count:=0;
        for j:=0 to sc-1 do
          if (amount[i,j]>0) then count:=count+amount[i,j];
        if (count<>produce[i]) then done2:=false;
        if (not done2) then
        begin
          result:=done2;
          exit;
        end;
      end;
      for i:=0 to sc-1 do
      begin
        count:=0;
        for j:=0 to pc-1 do
          if (amount[i,j]>0) then count:=count+amount[i,j];
        if (count<>sale[i]) then done2:=false;
        if (not done2) then
        begin
          result:=done2;
          exit;
        end;
      end;
      result:=done2;
    end
    else result:=done1;
  end;
BEGIN
  min:=-1;max:=maxint;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
      amount[i,j]:=-2;          //用-2 表示未做过改动的。
  min_i:=0;min_j:=0;min:=cost[0,0];
  repeat
    if (not find_min) then break;
    check_spare_s(spare_s,min_j);
    check_spare_p(spare_p,min_i);
    if (spare_p<spare_s) then
    begin
      amount[min_i,min_j]:=spare_p;
      unenable_p(min_i,min_j);
    end
    else if (spare_s<spare_p) then
    begin
      amount[min_i,min_j]:=spare_s;
      unenable_s(min_i,min_j);
    end
    else begin
      amount[min_i,min_j]:=spare_p;
      unenable_s(min_i,min_j);
      unenable_p(min_i,min_j);
    end;
  until all_done;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
    if (amount[i,j]=-1) then amount[i,j]:=0;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
    if (amount[i,j]=-2) then amount[i,j]:=0;
END;

PROCEDURE zdfy_d_init(pc,sc:byte;
        produce,sale:array of real;
        cost:matrix;var amount:matrix;
        var grid1:Tstringgrid;var grid2:tstringgrid;
        ptime:dword);
var i,j:byte;
    min,max:real;        //最低费用
    min_i,min_j:byte;    //最低费用点坐标
    spare_p,spare_s:real;
  function find_min:boolean;
  var i,j:integer;get_one:boolean;
  begin
    get_one:=false;
    if (min=-1) then min:=cost[0,0]
    else min:=max;
    for i:=0 to pc-1 do for j:=0 to sc-1 do
    begin
      if ((cost[i,j]<min)and(amount[i,j]=-2)) then
      begin
        min:=cost[i,j];
        min_i:=i; min_j:=j;
        get_one:=true;
      end;
      if (cost[i,j]>max) then max:=cost[i,j];
    end;
    result:=get_one;
  end;
  procedure unenable_s(x,y:byte);
  var i:integer;
  begin
    for i:=0 to pc-1 do
      if ((amount[i,y]=0)and(i<>x)) then amount[i,y]:=-1;
    for i:=0 to pc-1 do
      if (amount[i,y]<=0) then
      begin
       grid2.cells[y+1,i+1]:='--';
       grid1.cells[y+1,i+1]:='*'+floattostr(cost[i,y])+'*';
      end
      else
        grid2.Cells[y+1,i+1]:=floattostr(amount[i,y]);
    grid1.refresh;
    grid2.refresh;
  end;
  procedure unenable_p(x,y:byte);
  var i:integer;
  begin
    for i:=0 to sc-1 do
      if ((amount[x,i]=0)and(i<>y)) then amount[x,i]:=-1;
    for i:=0 to sc-1 do
      if (amount[x,i]<=0)then
      begin
        grid2.cells[i+1,x+1]:='--';
        grid1.cells[i+1,x+1]:='*'+floattostr(cost[x,i])+'*';
      end
      else
        grid2.Cells[i+1,x+1]:=floattostr(amount[x,i]);
    grid1.refresh;
    grid2.refresh;
  end;
  procedure check_spare_s(var s_s:real;y:byte);
  var m:real;i:integer;
  begin
    m:=sale[y];
    for i:=0 to pc-1 do
      if amount[i,y]>0 then m:=m-amount[i,y];
    s_s:=m;
  end;
  procedure check_spare_p(var s_p:real;x:byte);
  var m:real;i:integer;
  begin
    m:=produce[x];
    for i:=0 to sc-1 do
      if amount[x,i]>0 then m:=m-amount[x,i];
    s_p:=m;
  end;
  function all_done:boolean;
  var i,j:integer; done1,done2:boolean;
      count:real;
  begin
    done1:=true;
    for i:=0 to pc-1 do for j:=0 to sc-1 do
      if (amount[i,j]=-2) then done1:=false;
    if (not done1) then
    begin
      done2:=true;
      for i:=0 to pc-1 do
      begin
        count:=0;
        for j:=0 to sc-1 do
          if (amount[i,j]>0) then count:=count+amount[i,j];
        if (count<>produce[i]) then done2:=false;
        if (not done2) then
        begin
          result:=done2;
          exit;
        end;
      end;
      for i:=0 to sc-1 do
      begin
        count:=0;
        for j:=0 to pc-1 do
          if (amount[i,j]>0) then count:=count+amount[i,j];
        if (count<>sale[i]) then done2:=false;
        if (not done2) then
        begin
          result:=done2;
          exit;
        end;
      end;
      result:=done2;
    end
    else result:=done1;
  end;
BEGIN
  min:=-1;max:=maxint;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
      amount[i,j]:=-2;          //用-2 表示未做过改动的。
  for i:=1 to pc do
    for j:=1 to sc do
      grid1.cells[j,i]:=floattostr(cost[i-1,j-1]);
  for i:=1 to pc do
    grid1.cells[0,i]:=inttostr(i);
  for j:=1 to sc do
    grid1.cells[j,0]:=inttostr(j);
  grid1.Refresh;
  grid2.cells[0,0]:='产\销量';
  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]);
  grid2.refresh;
  min_i:=0;min_j:=0;min:=cost[0,0];
  repeat
    if (not find_min) then break;
    check_spare_s(spare_s,min_j);
    check_spare_p(spare_p,min_i);
    if (spare_p<spare_s) then
    begin
      amount[min_i,min_j]:=spare_p;
      unenable_p(min_i,min_j);
    end
    else if (spare_s<spare_p) then
    begin
      amount[min_i,min_j]:=spare_s;
      unenable_s(min_i,min_j);
    end
    else begin
      amount[min_i,min_j]:=spare_p;
      unenable_s(min_i,min_j);
      unenable_p(min_i,min_j);
    end;
    pause(ptime);
  until all_done;
  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(cost[i,j])+'*';
      grid2.cells[j+1,i+1]:='--';
    end;
  grid1.refresh;
  grid2.refresh;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
    if (amount[i,j]=-1) then amount[i,j]:=0;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
    if (amount[i,j]=-2) then amount[i,j]:=0;
END;

PROCEDURE xbj_init(pc,sc:byte;
        produce,sale:array of real;
        var amount:matrix);
var i,j:byte;
    spare:real;     //每步剩余量
    where:boolean;  //剩余量是销方还是产方。T:销，F:产
    tp,ts:real;
BEGIN
  for i:=0 to pc-1 do for j:=0 to sc-1 do
    amount[i,j]:=0;
  i:=0;j:=0;spare:=0;where:=false;
  repeat
    tp:=produce[i];
    ts:=sale[j];
    if (spare<>0)then
    begin
     if (where) then
      ts:=spare
     else
      tp:=spare;
    end;
    if (tp>ts) then
    begin
      amount[i,j]:=ts;
      spare:=tp-ts;
      where:=false;
      j:=j+1;
    end
    else if (tp<ts) then
    begin
      amount[i,j]:=tp;
      spare:=ts-tp;
      where:=true;
      i:=i+1;
    end
    else
    begin
      amount[i,j]:=tp;
      spare:=0;
      i:=i+1;
      j:=j+1;
    end;
  until (i>(pc-1))or(j>(sc-1));
END;

PROCEDURE xbj_d_init(pc,sc:byte;
        produce,sale:array of real;
        var amount:matrix;var grid:Tstringgrid;
        ptime:dword);
var i,j:byte;
    spare:real;     //每步剩余量
    where:boolean;  //剩余量是销方还是产方。T:销，F:产
    tp,ts:real;
BEGIN
  grid.cells[0,0]:='产\销量';
  for i:=1 to pc do
    grid.cells[0,i]:=floattostr(produce[i-1]);
  for j:=1 to sc do
    grid.cells[j,0]:=floattostr(sale[j-1]);
  grid.refresh;
  for i:=0 to pc-1 do for j:=0 to sc-1 do
    amount[i,j]:=0;
  i:=0;j:=0;spare:=0;where:=false;
  repeat
    tp:=produce[i];
    ts:=sale[j];
    if (spare<>0)then
    begin
     if (where) then
      ts:=spare
     else
      tp:=spare;
    end;               
    if (tp>ts) then
    begin
      amount[i,j]:=ts;
      grid.Cells[j+1,i+1]:=floattostr(ts);
      spare:=tp-ts;
      where:=false;
      j:=j+1;
    end
    else if (tp<ts) then
    begin
      amount[i,j]:=tp;
      grid.Cells[j+1,i+1]:=floattostr(tp);
      spare:=ts-tp;
      where:=true;
      i:=i+1;
    end
    else
    begin
      amount[i,j]:=tp;
      grid.Cells[j+1,i+1]:=floattostr(tp);
      spare:=0;
      i:=i+1;
      j:=j+1;
    end;
    grid.refresh;
    pause(ptime);
  until (i>(pc-1))or(j>(sc-1));
  for i:=1 to pc do for j:=1 to sc do
    grid.cells[j,i]:=floattostr(amount[i-1,j-1]);
  grid.refresh;
END;


end.