MATCH2 - Bộ ghép đầy đủ trọng số cực tiểu

Tác giả: ll931110

Ngôn ngữ: Pascal

{$MODE DELPHI}
program Finding_the_Best_Assignment;
const
  InputFile  = '';
  OutputFile = '';
  max = 200;
  maxEC = 200;
  maxC = max * maxEC + 1;
var
  c: array[1..max, 1..max] of Integer;
  Fx, Fy, matchX, matchY: array[1..max] of Integer;
  Trace, Queue, d, arg: array[1..max] of Integer;
  Front, Rear: Integer;
  start, finish: Integer;
  m, n, k: Integer;

procedure Enter;
var
  i, j: Integer;
  f: Text;
begin
  Assign(f, InputFile); Reset(f);
  ReadLn(f, n);
  k := n;
  m := n;
  for i := 1 to k do
    for j := 1 to k do c[i, j] := maxC;
  while not Eof(f) do ReadLn(f, i, j, c[i, j]);
  Close(f);
end;

procedure Init;
begin
  FillChar(matchX, SizeOf(matchX), 0);
  FillChar(matchY, SizeOf(matchY), 0);
  FillChar(Fx, SizeOf(Fx), 0);
  FillChar(Fy, SizeOf(Fy), 0);
end;

function GetC(i, j: Integer): Integer;
begin
  GetC := c[i, j] - Fx[i] - Fy[j];
end;

procedure InitBFS;
var
  j: Integer;
begin
  Front := 1; Rear := 1;
  Queue[1] := start;
  FillChar(Trace, SizeOf(Trace), 0);
  for j := 1 to k do
    begin
      d[j] := GetC(start, j);
      arg[j] := start;
    end;
  finish := 0;
end;

procedure Push(v: Integer);
begin
  Inc(Rear); Queue[Rear] := v;
end;

function Pop: Integer;
begin
  Pop := Queue[Front]; Inc(Front);
end;

procedure FindAugmentingPath;
var
  i, j, w: Integer;
begin
  repeat
    i := Pop;
    for j := 1 to k do
      if Trace[j] = 0 then
        begin
          w := GetC(i, j);
          if w = 0 then
            begin
              Trace[j] := i;
              if matchY[j] = 0 then
                begin
                  finish := j;
                  Exit;
                end;
              Push(matchY[j]);
            end;
          if d[j] > w then
            begin
              d[j] := w;
              arg[j] := i;
            end;
        end;
  until Front > Rear;
end;

procedure SubX_AddY;
var
  Delta: Integer;
  i, j: Integer;
begin
  Delta := maxC;
  for j := 1 to k do
    if (Trace[j] = 0) and (d[j] < Delta) then Delta := d[j];
  Fx[start] := Fx[start] + Delta;
  for j := 1 to k do
    if Trace[j] <> 0 then
      begin
        i := matchY[j];
        Fy[j] := Fy[j] - Delta;
        Fx[i] := Fx[i] + Delta;
      end
    else
      d[j] := d[j] - Delta;
  for j := 1 to k do
    if (Trace[j] = 0) and (d[j] = 0) then
      begin
        Trace[j] := arg[j];
        if matchY[j] = 0 then
          begin
            finish := j;
            Exit;
          end;
        Push(matchY[j]);
      end;
end;

procedure Enlarge;
var
  i, next: Integer;
begin
  repeat
    i := Trace[finish];
    next := matchX[i];
    matchX[i] := finish;
    matchY[finish] := i;
    finish := Next;
  until finish = 0;
end;

procedure Solve;
var
  i: Integer;
begin
  for i := 1 to k do
    begin
      start := i;
      InitBFS;
      repeat
        FindAugmentingPath;
        if finish = 0 then SubX_AddY;
      until finish <> 0;
      Enlarge;
    end;
end;

procedure Result;
var
  i, j, Count, W: Integer;
  f: Text;
begin
  Assign(f, OutputFile); Rewrite(f);

  W := 0; Count := 0;
  for i := 1 to m do
    begin
      j := matchX[i];
      W := W + c[i, j];
    end;

  WriteLn(f, W);
  for i := 1 to m do
    begin
      j := matchX[i];
      writeln(f, i, ' ', j);
    end;
  Close(f);
end;

begin
  Enter;
  Init;
  Solve;
  Result;
end.

Download