hungarian.pas

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