Cod sursa(job #558930)

Utilizator gabeekaDobai Gabor gabeeka Data 17 martie 2011 15:10:57
Problema Cuplaj maxim in graf bipartit Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 2.04 kb
type rec=record
          a,b:integer;
         end;
     vek=array[1..7500] of rec;
     matrix=array[1..7500,1..7500] of integer;
     vek1=array[1..7500] of integer;
     boo=array[1..7500] of boolean;
var i,j,k,n,x,y,m,akt:integer;
    jart:boo;
    v:vek;
    cs,t,e:vek1;
    h:matrix;
    f,g:text;
    z,z1,la:boolean;
procedure szeles(x,y:integer);
   begin
    akt:=1;
    cs[1]:=x;
    k:=1;
    t[x]:=0;
    jart[x]:=true;
    while akt<=k do
     begin
      for i:= 1 to n do
       if (not jart[i]) and (h[cs[akt],i]=1) then
                                    begin
                                     jart[i]:=true;
                                     inc(k);
                                     t[i]:=t[cs[akt]]+1;
                                     cs[k]:=i;
                                    end;
      inc(akt);
     end;
   end;
procedure quick(var t:vek1;also,felso:byte);

var i,j,k:integer;
    x:integer;

Begin
  i:=also;
  j:=felso;
  x:=t[(i+j) div 2];
  repeat
    while t[i]<x do i:=i+1;
    while t[j]>k do j:=j-1;
    if i<j then
      begin
        k:=t[i];
        t[i]:=t[j];
        t[j]:=k;
      end;
    if i<=j then
      begin
        i:=i+1;
        j:=j-1;
      end;
  until i>j;
  if also<j then quick(t,also,j);
  if felso>i then quick(t,i,felso);
End;

begin
 assign(f,'cuplaj.in');
 reset(f);
 readln(f,n,m,x,y);
 for i:= 1 to m do
  begin
   readln(f,j,k);
   h[j,k]:=1;
   h[k,j]:=1;
  end;
 close(f);
 szeles(x,y);
 for i:= 1 to n do
  v[i].a:=t[i];
 for i:= 1 to n do
  begin
   cs[i]:=0;
   t[i]:=0;
   jart[i]:=false;
  end;
 szeles(y,x);
 for i:= 1 to n do
  v[i].b:=t[i];
 j:=v[1].a;
 for i:= 1 to n do
  if v[i].a>j then j:=v[i].a;
 k:=j;
 assign(g,'cuplaj.out');
 rewrite(g);
 writeln(g,k);
 akt:=0;
 for i:= 0 to k do
  begin
   x:=0;
   for j:= 1 to n do if v[j].a=i then begin inc(x); y:=j; end;
   if x=1 then begin inc(akt); e[akt]:=y; end;
  end;
quick(e,1,k);
 for i:= 1 to k do
  write(g,e[i],' ');
 close(g);
end.