INFOMAN брой 18

{$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,P+,Q-,R+,S+,T-,V-,X+,Y+}
{$M 65520,0,655360}

{ Унгарски алгоритъм *
  --------------------

  Цел на унгарски алгоритъм:

   Ако е дадена матрица C трябва да
   се изберат N елемента от C така
   че всеки ред и всеки стълб да съдържа по
   точно един от тези елементи и сумата на избраните
   елементи трябва да е максимална или минимална.


  1. Ако се търси минимума тогава определяме минималният елемент ajмин в
     j-тия стълб на матрицата.
     От всеки елемент на j-тия стълб се изважда Ajmin. т.е

      Cij = Cij - Ajmin.

     Ако се търси максимума тогава определяме маскималният елемент във всеки
     стълб на матрицата.От всеки елемент на j-ти стълб се изважда ajmax и
     се променя знака(от минус на плюс) на получената разлика.
     т.е

      Cij = -(Cij - Ajmax).


    Намираме 0* и техният брой.

  2.Ако броят на 0* е N ==> е намерено решение.Край
  3.Отбелязваме с '+' стълбовете където има 0*.
  4.Ако всички нули са заети ==> Ст.8
  5.Избираме произволно незаета 0 и я отбелязваме с '.Ако в неиният ред
    няма 0* ==> Ст.7 .В противен случаи , ако 0* е такава нула към Ст.6
  6.Изтрива знака '+' от стълба , в които е тази 0.Отбелязваме с '+' реда
    в които е означената 0'.Към Ст.4.
  7.Започваме от намеренате 0' , описваме верига от белязани нули - от 0'
    по стълба и до 0*,от тази 0* по реда до 0' и т.н.
    Премахваме знаковете '*' от нулите във веригата и заменяме в нея всички
    0' с 0*.Премахваме останали знакове ' и '+'.
  8.Избираме минимален незает елемент , изваждаме го от елементите на
    незаетите редове и го прибавяме към тези на заетите сълбове.Към Ст.8.

}

const MaxN = 100;

type Matrix = array[1..MaxN,1..MaxN] of integer;
     Result = array[1..MaxN] of integer;

     TMinMax = (_min_,_max_);

Var
 C:Matrix;
 X:Result;
 N:integer;

procedure PrintMatrix(Var C:Matrix;N:integer);
Var
 i,j:integer;
begin
 WriteLn;
 for i:=1 to N do
  begin
   WriteLn;
    for j:=1 to N do Write(C[i,j]:4);
  end;
 WriteLn;
end;

procedure PrintResult(C:Matrix;X:Result;N:integer;M:TMinMax);
Var
 i,k:integer;
 Sum:Word;
begin
 Sum:=0;
 WriteLn;
 for i:=1 to N do
  begin
   WriteLn('Момиче ',i,' с момче ',X[i],' - оценка(',C[X[i],i],')');
   Sum:=Sum+C[X[i],i];
  end;

 if M = _Max_ then
  Writeln('Тези танцови двоики постигат МАСКИМАЛНА оценка =',Sum)
 else
  Writeln('Тези танцови двоики постигат МИНИМАЛНА оценка =',Sum);
end;

function Min(X,Y:integer):integer;
begin
 if X < Y then Min:=X
 else Min:=Y;
end;

function Max(X,Y:Integer):Integer;
begin
 if X > Y then Max:=X
 else Max:=Y;
end;

procedure ReadIt;
begin
   N := 5;

  C[1,1] := 12;
  C[1,2] := 16;
  C[1,3] := 10;
  C[1,4] := 14;
  C[1,5] := 13;
  C[2,1] := 16;
  C[2,2] := 17;
  C[2,3] := 12;
  C[2,4] := 11;
  C[2,5] := 19;
  C[3,1] := 16;
  C[3,2] := 13;
  C[3,3] := 7;
  C[3,4] := 13;
  C[3,5] := 16;
  C[4,1] := 14;
  C[4,2] := 14;
  C[4,3] := 8;
  C[4,4] := 14;
  C[4,5] := 15;
  C[5,1] := 11;
  C[5,2] := 12;
  C[5,3] := 11;
  C[5,4] := 14;
  C[5,5] := 18;

end;

procedure Hungaru(C:Matrix;Var X:Result;N:integer;MiniMaxi:TMinMax);
Var
 MarkedRow,
 MarkedCol :Array[1..MaxN] of boolean;
 ZeroRow,ZeroCol : Array[1..MaxN] of boolean;
 NewC:Array[1..MaxN,1..MaxN] of ShortInt;
 Count:Word;
const
 Star0 = 1;
 Prime0 = 2;

procedure MakeTable(MiniMaxi:TMinMax);
Var
 i,j:integer;
 MinElem,MaxElem:Integer;
begin
 FillChar(MarkedRow,SizeOf(MarkedRow),0);
 FillChar(MarkedCol,SizeOf(MarkedCol),0);
 FillChar(ZeroRow,SizeOf(ZeroRow),0);
 FillChar(ZeroCol,SizeOf(ZeroCol),0);
 FillChar(NewC,SizeOf(NewC),0);
 Count:=0;


 if MiniMaxi = _Min_ then
   for j:=1 to N do
    begin
     MinElem:=C[1,j];
     for i:=2 to N do
      MinElem:=min(MinElem,C[i,j]);

     for i:=1 to N do
      C[i,j]:=C[i,j]-MinElem;
    end
 else
   for j:=1 to N do
    begin
     MaxElem:=C[1,j];
     for i:=2 to N do
      MaxElem:=Max(MaxElem,C[i,j]);

     for i:=1 to N do
      C[i,j]:=-(C[i,j]-MaxElem);
    end;



 for i:=1 to N do
  if not ZeroRow[i] then
   for j:=1 to N do
    if not ZeroCol[j] then
     if C[i,j] = 0 then
      begin
       NewC[i,j]:=Star0;
       ZeroRow[i]:=True;
       ZeroCol[j]:=True;
       Inc(Count);
       break;
      end;
end;

procedure MarkCols;
Var
 i:integer;
begin
 FillChar(MarkedCol,SizeOf(MarkedCol),0);
 FillChar(MarkedRow,SizeOf(MarkedRow),0);

 for i:=1 to N do
  MarkedCol[i]:=ZeroCol[i];
end;

procedure Convert; { Стъпка 8 => Преобразува матрицата }
Var
 i,j:integer;
 MinElem:Integer;
 First:boolean;
begin
 First:=true;
 for i:=1 to N do
  if not MarkedRow[i] then
   for j:=1 to N do
    if not MarkedCol[j] then
     if first then
      begin
       MinElem:=C[i,j];
       first:=false;
      end
     else
      MinElem:=Min(MinElem,C[i,j]);

  for i:=1 to N do
   if not MarkedRow[i] then
    for j:=1 to N do
     C[i,j]:=C[i,j] - MinElem;

  for j:=1 to N do
   if MarkedCol[j] then
    for i:=1 to N do
     C[i,j]:=C[i,j] + MinElem;
end;


procedure FindPrime0(Var X,Y:integer);

function Find0:boolean; { Проверява има ли незаета 0 }
Var
 i,j:integer;
begin
 Find0:=true;

 for i:=N downto 1 do
  if not MarkedRow[i] then
   for j:=N downto 1 do
    if not MarkedCol[j] then
     if C[i,j] = 0 then Exit;

 Find0:=false;
end;

function Get(Var X,Y:Integer):boolean; { Избира незата нула и връща дали в реда и има 0*}
Var
 i,j:integer;
begin
 X:=0;
 Y:=0;

  for i:=N downto 1 do
   if not MarkedRow[i] then
    for j:=N downto 1 do
     if not MarkedCol[j] then
      if C[i,j] = 0 then
       begin
        Get:=ZeroRow[i];
        X:=i;
        Y:=j;
        NewC[x,y]:=Prime0;
        exit;
       end;

 Get:=False;
end;

procedure Step6(X,Y:integer);
Var
 i,j:integer;
begin
 MarkedRow[X]:=true;

 for j:=1 to N do
  if NewC[x,j] = Star0 then
   begin
    MarkedCol[j]:=false;
    exit;
   end;
end;

begin
 repeat
  if not Find0 then { Ст.4}
   Convert;         { Ст.8}
  if Get(X,Y) then  { Ст.5}
   Step6(X,Y)       { Ст.6}
  else
   exit;
 until false;
end;

procedure Chain(X,Y:integer);
Var
 i,j:integer;
 flag:boolean;
 PrimeOrNot:boolean;
begin
 PrimeOrNot:=true;
 NewC[x,y]:=Star0;

 repeat
  Flag:=true;

   if PrimeOrNot then
    begin
     for i:=1 to N do
      if i <> x then
       if NewC[i,y] = Star0 then
        begin
         X:=i;
         NewC[i,y]:=0;
         flag:=false;
         break;
        end;
    end
   else
    begin
     for j:=1 to N do
      if j <> y then
       if NewC[x,j] = Prime0 then
        begin
         Y:=j;
         NewC[x,j]:=Star0;
         flag:=false;
         break;
        end;
    end;

  PrimeOrNot:=not PrimeOrNot;
 until flag;

 FillChar(ZeroRow,SizeOf(ZeroRow),0);
 FillChar(ZeroCol,SizeOf(ZeroCol),0);

 for i:=1 to N do
   for j:=1 to N do
     if NewC[i,j] = Star0 then
      NewC[i,j]:=Star0
     else
      NewC[i,j]:=0;

 for i:=1 to N do
  for j:=1 to N do
   if NewC[i,j] = Star0 then
    begin
     ZeroRow[i]:=True;
     ZeroCol[j]:=True;
    end;
end;

Var
 _X,_Y,i,j:Integer;
begin
 MakeTable(MiniMaxi); { Стъпка 1 от унгарския алгоритъм }

 while Count < n do { Стъпка 2. Проверка за оптималност }
  begin
   MarkCols; { Ст.3 от алг. Отбелязва стълбовете на 0* с '+'}
   FindPrime0(_X,_Y); { Ст4 , Ст5 , Ст 6 }
   Chain(_X,_Y);
   inc(Count);
  end;

 for j:=1 to n do
  begin
   X[j]:=0;
    for i:=1 to n do
     if NewC[i,j] = Star0 then
      begin
       X[j]:=i;
       break;
      end;
  end;
end;


begin
 ReadIt;
 PrintMatrix(C,N);
 Hungaru(C,X,N,_Max_);
 PrintResult(C,X,N,_Max_);
end.