basicu.pas

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

Unit BasicU;

interface
uses
  Windows,Messages,SysUtils,Classes,Controls,Forms,Grids,Dialogs;
Type
  matrix=array of array of real;

procedure pause(t:Dword);
procedure xbj_init(pc,sc:byte;produce,sale:array of real;var amount:matrix);
procedure xbj_d_init(pc,sc:byte;produce,sale:array of real;
              var amount:matrix;var grid:Tstringgrid;ptime:dword);
procedure zdfy_init(pc,sc:byte;produce,sale:array of real;
                                 cost:matrix;var amount:matrix);
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);
procedure ce_init(pc,sc:byte;produce,sale:array of real;
                                 cost:matrix;var amount:matrix);
procedure ce_d_init(pc,sc:byte;produce,sale:array of real;
              cost:matrix;var amount:matrix;
              var grid1:Tstringgrid;var grid2:Tstringgrid;
              ptime:dword);

implementation

PROCEDURE pause(t:Dword);
var i:dword;
begin
  i:=gettickcount;
  while((i+t)>=gettickcount) do ;
end;

PROCEDURE ce_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;
    da:real;
    min_i,min_j:byte;
    spare_p,spare_s:real;
    ban_p,ban_s:array of real;
    done:matrix;
  function find_min:boolean;
  var i,j:integer;get_one:boolean;
      po,po2:byte;pb:boolean;
      zui,zuixiao:real;
  begin
    get_one:=false;
    pb:=true;
    da:=-1;
    po:=0;po2:=0;
    for i:=0 to pc-1 do
    begin
      if (ban_p[i]>da) then
      begin
        da:=ban_p[i];
        po:=i; pb:=true;
        get_one:=true;
      end;
    end;
    for j:=0 to sc-1 do
    begin
      if (ban_s[j]>da) then
      begin
        da:=ban_s[j];
        po:=j; pb:=false;
        get_one:=true;
      end;
    end;
    if (get_one) then
    begin
      if (pb) then
      begin
        min_i:=po;
        zui:=-1;
        for i:=0 to sc-1 do
          if (done[po,i]>=0) then
            zui:=cost[po,i];
        if (zui=-1) then get_one:=false
        else begin
          zuixiao:=zui;
          for i:=0 to sc-1 do
            if ((done[po,i]>=0)and(cost[po,i]<=zuixiao)) then
            begin
              po2:=i;
              zuixiao:=cost[po,i];
            end;
          min_j:=po2;
        end;
      end else begin
        min_j:=po;
        zui:=-1;
        for j:=0 to pc-1 do
          if (done[j,po]>=0) then
            zui:=cost[j,po];
        if (zui=-1) then get_one:=false
        else begin
          zuixiao:=zui;
          for j:=0 to pc-1 do
            if ((done[j,po]>=0)and(cost[j,po]<=zuixiao)) then
            begin
              po2:=j;
              zuixiao:=cost[j,po];
            end;
          min_i:=po2;
        end;
      end;
    end;
    result:=get_one;
  end;
  procedure unenable_s(x,y:byte); //横
  var i:integer;
  begin
    for i:=0 to pc-1 do done[i,y]:=-1;
  end;
  procedure unenable_p(x,y:byte);
  var i:integer;
  begin
    for i:=0 to sc-1 do done[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 done[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 done[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 (done[i,j]>=0) 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 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 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;
  procedure reset_ban;
  var v,w,u:byte;
      zuixiao,cixiao:real;
      findcixiao:boolean;
  begin
    u:=0;
    for v:=0 to sc-1 do
    begin
      if (ban_s[v]>=0) then
      begin
        zuixiao:=maxint;
        for w:=0 to pc-1 do
          if ((done[w,v]>=0)and(cost[w,v]<zuixiao)) then
          begin
            u:=w;
            zuixiao:=cost[w,v];
          end;
        cixiao:=maxint;
        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
  begin
      done[i,j]:=0;
      amount[i,j]:=0;
  end;
  min_i:=0;min_j:=0;
  grid1.cells[0,0]:='列\行差';
  grid2.cells[0,0]:='产\销量';
  for i:=1 to pc do
    for j:=1 to sc do
      grid1.cells[j,i]:=floattostr(cost[i-1,j-1]);
  grid1.Refresh;
  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;
  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;
    for i:=1 to pc do
      for j:=1 to sc do
      begin
        if (done[i-1,j-1]=-1) then
        begin
          grid1.cells[j,i]:='--';
          if (amount[i-1,j-1]>0) then
            grid2.cells[j,i]:=floattostr(amount[i-1,j-1])
          else
            grid2.cells[j,i]:='--';
        end
        else
        begin
          grid1.cells[j,i]:=floattostr(cost[i-1,j-1]);
        end;
      end;
    for i:=1 to pc do
      grid1.cells[0,i]:=floattostr(ban_p[i-1]);
    for j:=1 to sc do
      grid1.cells[j,0]:=floattostr(ban_s[j-1]);
    grid1.refresh;
    grid2.refresh;
    pause(ptime);
  until all_done;
  do_end;
  for i:=1 to pc do
    for j:=1 to sc do
      begin
        if (done[i-1,j-1]=-1) then
        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
        else
          if (amount[i-1,j-1]>0) then
            grid2.cells[j,i]:=floattostr(amount[i-1,j-1]);
      end;
  grid2.refresh;
END;

PROCEDURE ce_init(pc,sc:byte;produce,sale:array of real;
        cost:matrix;var amount:matrix);
var i,j:byte;
    da:real;
    min_i,min_j:byte;
    spare_p,spare_s:real;
    ban_p,ban_s:array of real;
    done:matrix;
  function find_min:boolean;
  var i,j:integer;get_one:boolean;
      po,po2:byte;pb:boolean;
      zui,zuixiao:real;
  begin
    get_one:=false;
    pb:=true;
    da:=-1;
    po:=0;po2:=0;
    for i:=0 to pc-1 do
    begin
      if (ban_p[i]>da) then
      begin
        da:=ban_p[i];
        po:=i; pb:=true;
        get_one:=true;
      end;
    end;
    for j:=0 to sc-1 do
    begin
      if (ban_s[j]>da) then
      begin
        da:=ban_s[j];
        po:=j; pb:=false;
        get_one:=true;
      end;
    end;
    if (get_one) then
    begin
      if (pb) then
      begin
        min_i:=po;
        zui:=-1;
        for i:=0 to sc-1 do
          if (done[po,i]>=0) then
            zui:=cost[po,i];
        if (zui=-1) then get_one:=false
        else begin
          zuixiao:=zui;
          for i:=0 to sc-1 do
            if ((done[po,i]>=0)and(cost[po,i]<=zuixiao)) then
            begin
              po2:=i;
              zuixiao:=cost[po,i];
            end;
          min_j:=po2;
        end;
      end else begin
        min_j:=po;
        zui:=-1;
        for j:=0 to pc-1 do
          if (done[j,po]>=0) then
            zui:=cost[j,po];
        if (zui=-1) then get_one:=false
        else begin
          zuixiao:=zui;
          for j:=0 to pc-1 do
            if ((done[j,po]>=0)and(cost[j,po]<=zuixiao)) then
            begin
              po2:=j;
              zuixiao:=cost[j,po];
            end;
          min_i:=po2;
        end;
      end;
    end;
    result:=get_one;
  end;
  procedure unenable_s(x,y:byte); //横
  var i:integer;
  begin
    for i:=0 to pc-1 do done[i,y]:=-1;
  end;
  procedure unenable_p(x,y:byte);
  var i:integer;
  begin
    for i:=0 to sc-1 do done[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 done[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 done[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 (done[i,j]>=0) 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 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 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;
  procedure reset_ban;
  var v,w,u:byte;
      zuixiao,cixiao:real;
      findcixiao:boolean;
  begin
    u:=0;
    for v:=0 to sc-1 do
    begin
      if (ban_s[v]>=0) then
      begin
        zuixiao:=maxint;
        for w:=0 to pc-1 do
          if ((done[w,v]>=0)and(cost[w,v]<zuixiao)) then
          begin
            u:=w;
            zuixiao:=cost[w,v];
          end;
        cixiao:=maxint;