Listing CRITICI.PAS
Program critici;
type critic=array[0..20] of Byte;
critic_list=array[1..100] of critic;
adiacenta=array[1..100,1..100] of Byte;
big_adiacenta=array[1..102,1..102] of Byte;
var c,r:Byte;
cl:critic_list;
a:adiacenta;
b,b2:big_adiacenta;
s,t,n:Byte; 

 

procedure InitData;
{ Se initializeaza cu 0 matricea cu listele }
{ de capodopere propuse de critici si matricea }
{ de adiacenta }
begin
FillChar(cl,Sizeof(cl),0);
FillChar(a,Sizeof(a),0)
end;

 

procedure ReadData;
{ Se citesc datele de intrare: numarul de }
{ critici si pentru fiecare critic lista }
{ capodoperelor propuse de acesta }
var fin:Text; i:Integer;
begin
Assign(fin,'CRITICI.IN'); Reset(fin);
Read(fin,c); Readln(fin,r);
for i:=1 to c do 
begin
cl[i][0]:=0;
while not Eoln(fin) do 
begin
Inc(cl[i][0]); Read(fin,cl[i][cl[i][0]])
end;
Readln(fin)
end;
Close(fin)
end;

 

function QueryMatch(x,y:Byte):Boolean;
{ Functia returneaza true daca preferintele }
{ criticilor x si y difera exact pentru un }
{ roman si false in caz contrar }
type hash=array[1..20] of Byte;
var ii:Byte;
diffs:Integer;
v1,v2:critic;
h:hash;

 

function GetMin(first,second:Byte):Byte;
begin
if (first<second) then GetMin:=first 
else GetMin:=second
end;

 

begin
if (Abs(cl[x][0]-cl[y][0])<>1) 
then begin QueryMatch:=false; Exit end;
ii:=1; diffs:=0;
FillChar(h,Sizeof(h),0);
if (cl[x][0]<cl[y][0]) 
then begin v1:=cl[x]; v2:=cl[y] end 
else begin v1:=cl[y]; v2:=cl[x] end;
for ii:=1 to v1[0] do h[v1[ii]]:=1;
for ii:=1 to v2[0] do
if (h[v2[ii]]=0) then Inc(diffs);
if (diffs=1) then QueryMatch:=true 
else QueryMatch:=false
end;

 

procedure MakeAdiacenta;
{ Construieste matricea de adiacenta, varfurile	} 
{ grafului vor reprezenta criticii, iar intre }
{ doua varfuri i si j va exista muchie daca }
{ parerile celor doi critici difera exact }
{ pentru un roman 	}
var i,j:Integer;
begin
for i:=1 to c do
for j:=i+1 to c do
if QueryMatch(i,j) 
then begin a[i,j]:=1; a[j,i]:=1 end 
else begin a[i,j]:=0; a[j,i]:=0 end
end;

 

function GetPos(x:Byte):Byte;
begin
GetPos:=x+1
end;

 

function GetS:Byte;
begin
GetS:=1
end;

 

function GetT:Byte;
begin
GetT:=c+2
end;

 

procedure MakeFluxInitialData;
{ Se determina cuplajul maximal 	}
var i,j:Integer;
begin
for i:=1 to c do 
begin
for j:=i+1 to c do
if a[i,j]=1 
then 
begin
if cl[i][0] mod 2=1 
then b[GetPos(i),GetPos(j)]:=1 
else b[GetPos(j),GetPos(i)]:=1
end;
if cl[i][0] mod 2=1 
then b[GetS,GetPos(i)]:=1 
else b[GetPos(i),GetT]:=1
end
end;

 

procedure FluxIt;
type
reached_set=set of Byte;
path_array=array[1..256] of Byte;
var reached:reached_set;
path:path_array;
atpath:Integer;
FindT:Boolean;
i:Integer;
min:Integer;

 

procedure Way(from:Byte; at:Byte);
var i:Integer;
begin
path[at]:=from;
reached:=reached+[from];
if from=t 
then begin FindT:=true; atpath:=at; Exit end;
for i:=1 to n do
if (b[from,i]=1) and not(i in reached) 
and not(FindT)
then Way(i,at+1)
end;

 

begin
repeat
atpath:=0;
reached:=[]; FindT:=false;
Way(s,atpath +1);
if FindT 
then 
begin
min:=32767;
for i:=1 to atpath-1 do
if b[path[i],path[i+1]]<min 
then min:=b[path[i],path[i+1]];
if min=32767 
then 
begin 
Writeln('Error: invalid min at 
flux.');
Halt
end;
for i:=1 to atpath-1 do 
begin
Dec(b[path[i],path[i+1]],min);
Inc(b[path[i+1],path[i]],min)
end
end
until not FindT
end;

 

procedure WriteResult;
{ Scrie solutia in fisier 	}
var i,j:Integer;
fout:Text;
count:Integer;
begin
Assign(fout,'CRITICI.OUT'); Rewrite(fout);
count:=0;
for i:=GetPos(1) to GetPos(c) do
for j:=GetPos(1) to GetPos(c) do
if (b[i,j]-b2[i,j]=-1) then Inc(count);
Writeln(fout,count);
for i:=GetPos(1) to GetPos(c) do
for j:=GetPos(1) to GetPos(c) do
if b[i,j]-b2[i,j]=-1 
then Writeln(fout,i-1,' ',j-1);
Close(fout)
end;

 

Begin
InitData;
ReadData;
MakeAdiacenta;
FillChar(b,Sizeof(b),0); 
FillChar(b2,Sizeof(b2),0);
MakeFluxInitialData;
b2:=b;
s:=GetS; t:=GetT; n:=c+2;
FluxIt;
WriteResult
End.