Bài viết này không còn hiệu quả, hãy xem bài viết mới hơn:
https://sites.google.com/site/kc97ble/algorithm-graph/cap-ghep-tren-do-thi-hai-phia-khong-trong-so
Em xin được phép trích bài toán và code của thầy Lê Minh Hoàng vào trong trang web của em.
Nội dung của bài viết này được lấy từ cuốn DSAP của thầy Lê Minh Hoàng.
Bài toán
"Đây là một dạng bài toán phát biểu như sau: Có m người (đánh số 1, 2, ..., m) và n công việc (đánh số 1, 2, ..., n), mỗi người có khả năng thực hiện một số công việc nào đó. Để giao cho người i thực hiện công việc j cần một chi phí là c[i, j] ≥ 0. Cần phân cho mỗi thợ một việc và mỗi việc chỉ do một thợ thực hiện sao cho số công việc có thể thực hiện được là nhiều nhất và nếu có ≥ 2 phương án đều thực hiện được nhiều công việc nhất thì chỉ ra phương án chi phí ít nhất." (DSAP Textbook - Lê Minh Hoàng)
Code dưới đây thực hiện thuật toán Hungari.
Độ phức tạp
tối đa lên đến : O(n^4)
Code này của thầy Lê Minh Hoàng
{$MODE DELPHI} (*This program uses 32-bit Integer [-231..231 - 1]*)
program Finding_the_Best_Assignment;
const
InputFile = 'ASSIGN.INP';
OutputFile = 'ASSIGN.OUT';
max = 1000;
maxEC = 1000
maxC = max * maxEC + 1;
var
c: array[1..max, 1..max] of Integer;
Fx, Fy, matchX, matchY, Trace: array[1..max] of Integer;
m, n, k, start, finish: Integer;
procedure Enter; {Nhập dữ liệu}
var
i, j: Integer;
f: Text;
begin
Assign(f, InputFile); Reset(f);
ReadLn(f, m, n);
if m > n then k := m else k := n;
for i := 1 to k do
for j := 1 to k do c[i, j] := maxC;
while not SeekEof(f) do ReadLn(f, i, j, c[i, j]);
Close(f);
end;
procedure Init; {Khởi tạo bộ ghép rỗng và các giá trị Fx[.], Fy[.]}
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; {Hàm trả về trọng số cạnh (x[i], y[j])}
begin
GetC := c[i, j] - Fx[i] - Fy[j];
end;
procedure FindAugmentingPath; {Thủ tục tìm đường mở xuất phát ở x[start]}
var
Queue: array[1..max] of Integer; {Hàng đợi dùng cho BFS, chỉ chứa chỉ số các đỉnh ∈ X}
i, j, Front, Rear: Integer;
begin
FillChar(Trace, SizeOf(Trace), 0);
Queue[1] := start;
Front := 1; Rear := 1;
repeat
i := Queue[Front]; Inc(Front); {Lấy i ra khỏi Queue, xét x[i]}
for j := 1 to k do
if (Trace[j] = 0) and (GetC(i, j) = 0) then {Nếy y[j] chưa thăm và kề với x[i] qua 0_cạnh}
begin
Trace[j] := i; {Lưu vết đường đi}
if matchY[j] = 0 then {Nếu y[j] đã ghép thì ghi nhận và thoát ngay}
begin
finish := j;
Exit;
end;
Inc(Rear); Queue[Rear] := matchY[j]; {Không thì đẩy matchY[j] vào Queue, chờ duyệt tiếp}
end;
until Front > Rear;
end;
procedure SubX_AddY; {Phép xoay trọng số cạnh}
var
i, j, t, Delta: Integer;
VisitedX, VisitedY: set of Byte;
begin
{Trước hết tìm hai tập VisitedX và VisitedY chứa chỉ số các đỉnh đến được từ x[start] qua một đường pha}
VisitedX := [start];
VisitedY := [];
for j := 1 to k do
if Trace[j] <> 0 then
begin
Include(VisitedX, matchY[j]);
Include(VisitedY, j);
end;
{Tính Delta := min(GetC(i, j)|i ∈ VisitedX và j ∉ VisitedY)}
Delta := maxC;
for i := 1 to k do
if i in VisitedX then
for j := 1 to k do
if not (j in VisitedY) and (GetC(i, j) < Delta) then
Delta := GetC(i, j);
{Xoay}
for t := 1 to k do
begin
if t in VisitedX then Fx[t] := Fx[t] + Delta;
if t in VisitedY then Fy[t] := Fy[t] - Delta;
end;
end;
procedure Enlarge; {Nới rộng bộ ghép bằng đường mở kết thúc tại y[finish]}
var
i, next: Integer;
begin
repeat
i := Trace[finish];
next := matchX[i];
matchX[i] := finish;
matchY[finish] := i;
start
finish := Next;
until finish = 0; {finish = 0 ⇔ i = start}
end;
procedure Solve; {Thuật toán Hungari}
var
i: Integer;
begin
for i := 1 to k do
begin
start := i; finish := 0;
repeat {Tìm cách ghép x[start]}
FindAugmentingPath;
if finish = 0 then SubX_AddY; {Nếu không tìm ra đường mở xuất phát từ x[start] thì xoay các trọng số cạnh}
until finish <> 0;
Enlarge; {Khi đã tìm ra đường mở thì chỉ cần tăng cặp theo đường mở}
end;
end;
procedure Result; {In kết quả}
var
i, j, Count, W: Integer;
f: Text;
begin
Assign(f, OutputFile); Rewrite(f);
WriteLn(f, 'Optimal assignment:');
W := 0; Count := 0;
for i := 1 to m do
begin
j := matchX[i];
if c[i, j] < maxC then {Chỉ in quan tâm tới những cạnh trọng số < maxC}
begin
Inc(Count);
WriteLn(f, Count:3, ') x[', i, '] - y[', j, '] ', c[i, j]);
W := W + c[i, j];
end;
end;
WriteLn(f, 'Cost: ', W);
Close(f);
end;
begin
Enter;
Init;
Solve;
Result;
end.
Nhận xét