Listing CRITICI.PAS
Program
typecritic=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;
varc,r:Byte;
cl:critic_list;
a:adiacenta;
b,b2:big_adiacenta;
s,t,n:Byte;
procedureInitData;
{ 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;
procedureReadData;
{ Se citesc datele de intrare: numarul de }
{ critici si pentru fiecare critic lista }
{ capodoperelor propuse de acesta }
varfin: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 }
typehash=array[1..20] of Byte;
varii:Byte;
diffs:Integer;
v1,v2:critic;
h:hash;
functionGetMin(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;
procedureMakeAdiacenta;
{ 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 }
vari,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;
functionGetPos(x:Byte):Byte;
begin
GetPos:=x+1
end;
functionGetS:Byte;
begin
GetS:=1
end;
functionGetT:Byte;
begin
GetT:=c+2
end;
procedureMakeFluxInitialData;
{ Se determina cuplajul maximal }
vari,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;
procedureFluxIt;
type
reached_set=set of Byte;
path_array=array[1..256] of Byte;
varreached:reached_set;
path:path_array;
atpath:Integer;
FindT:Boolean;
i:Integer;
min:Integer;
procedureWay(from:Byte; at:Byte);
vari: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;
procedureWriteResult;
{ Scrie solutia in fisier }
vari,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.