Gradele unui arbore (Timisoara - pregatire, ian. 1996)

       Dindu-se n numere pozitive d1,d2,...dn sa se verifice daca
   exista un arbore cu n noduri ale caror grade sunt d1,d2,...dn.
   Daca exista un astfel de arbore sa se reprezinte prin liste ale
   nodurilor. O lista a unui nod contine numarul nodului urmat de
   fii sai.
   ex:
   INT10.TXT contine:
   1 1 2 3 1 1 3

   OUT10.TXT rezultatul corect:
   DA
   1 2 3 4,2 5 6,3 7,4,5,6,7

-------------------------------------------------
Rezolvare: (Mihai Stroe - Liceul Cuza))
   Se sorteaza gradele,apoi se aplica urmatorul algoritm:
   -se porneste de la arborele format din radacina 1 si d[1] frunze
   (daca e posibil);
   -cat timp nu s-au introdus n noduri in arbore,se inlocuieste,daca
   e posibil,prima frunza cu primul nod i neintrodus in arbore;acest
   nod va avea d[i]-1 fii;
   -daca s-a reusit introducerea celor n noduri,s-a ajuns la solutie,
   care se tipareste;altfel,se afiseaza un mesaj.
   Solutia nu este neaparat unica,dar algoritmul gaseste o solutie
   daca exista (voi incerca sa si demonstrez).



var fi,fo:text;s:string;
    d:array[1..200]of byte;
    vecini:array[1..200,1..200]of byte;
    i,j,k,l,m,n:byte;

begin
  assign(fi,'int10.txt');
  reset(fi);
  n:=0;
  while not eoln(fi)do
        begin
          inc(n);
          read(fi,d[n]);
        end;
  close(fi);
  for i:=2 to n do
      for j:=1 to i-1 do
          if d[i]>d[j]then
             begin
               k:=d[i];
               d[i]:=d[j];
               d[j]:=k;
             end;
  for i:=2 to d[1]+1 do
      begin
        vecini[i,1]:=1;
        vecini[1,i]:=1;
      end;
  k:=d[1]+2;
  for i:=2 to n do
      begin
        if (d[i]-2<=n-k)and(i<k) then
           begin
           for j:=1 to d[i]-1 do
               begin
                 vecini[i,k]:=1;
                 vecini[k,i]:=1;
                 inc(k);
               end;
          end
          else
            begin
              assign(fo,'out10.txt');
              rewrite(fo);
              writeln(fo,'Imposibil');
              close(fo);
              halt;
            end;
      end;
   writeln;
   assign(fo,'out10.txt');
   rewrite(fo);
   for i:=1 to n do
       begin
       if d[i]>1 then
       write(fo,i,':')
       else write(fo,i,' ');
       for j:=i+1 to n do
           if vecini[i,j]=1 then write(fo,j,' ');
       if i<>n then write(fo,', ');
      end;
     close(fo);
end.
----------------------------
Solutia 2 (Angel Proorocu - Ploiesti):
program DeterminareGraf;

   uses Crt;

   var dplus,dminus:array[1..40]of integer;
       a,flux:array[1..10,1..10]of integer;
       drum:array[1..100]of byte;
       n,k,aa:integer;
       gasit:boolean;

procedure ReadData;
   var i,j,ss:integer;
       nume:string;
       f:text;
   begin
     clrscr;
     writeln('Introduceti numele fisierului de intrare:');
     readln(nume);
     assign(f,nume);
     reset(f);
     readln(f,n);
     aa:=0;
     for i:=1 to n do
      begin
       read(f,dplus[i]);
       inc(aa,dplus[i]);
      end;
     readln(f);
     ss:=0;
     for i:=1 to n do
      begin
       read(f,dminus[i]);
       inc(ss,dminus[i]);
      end;
     close(f);
     if aa<>ss then
      begin
       assign(f,'output.txt');
       rewrite(f);
       writeln(f,'NO');
       close(f);
       writeln('Rezultatul in OUTPUT.TXT..');
       readkey;
       halt;
      end;

     for i:=1 to n do
      begin
        a[1,1+i]:=dplus[i];
        a[n+1+i,n*2+2]:=dminus[i];
        for j:=1 to n do if i<>j then a[1+i,1+n+j]:=1;
     end;
   end;

procedure GetDrum;
   var i,j,atins,auxa,tataa,min:integer;
       aux,tata:array[1..100]of integer;
       sw:boolean;
   begin
       for i:=1 to n*2+2 do begin aux[i]:=0; tata[i]:=0; end;
       tata[1]:=1;
       sw:=true;

       while (sw)and(tata[n*2+2]=0) do
        begin
         sw:=false;
         min:=32767;
         atins:=0;

         for i:=1 to n*2+2 do if tata[i]>0 then
          for j:=1 to n*2+2 do if tata[j]=0 then if a[i,j]>0 then
           if aux[i]-a[i,j]+flux[j,i]<min then
            begin
             sw:=true;
             atins:=j;
             auxa:=aux[i]-a[i,j]+flux[j,i];
             tataa:=i;
             min:=auxa;
            end;

         if atins>0 then
          begin
            aux[atins]:=auxa;
            tata[atins]:=tataa;
          end;
        end;

        if tata[n*2+2]=0 then
         begin
           gasit:=false;
           exit;
         end;

        drum[1]:=n*2+2;
        k:=1;
        i:=n*2+2;
        while tata[i]<>i  do
         begin
           inc(k);
           drum[k]:=tata[i];
           i:=tata[i];
         end;
   end;


procedure rezolv;
   var i,j,min:integer;
       f:text;
   begin
     gasit:=true;
     getdrum;

     while gasit do
      begin
       min:=32767;
       for i:=k downto 2 do if min>a[drum[i],drum[i-1]] then
        min:=a[drum[i],drum[i-1]];

       for i:=2 to k do
        if flux[drum[i-1],drum[i]]=0 then
         begin
           a[drum[i],drum[i-1]]:=a[drum[i],drum[i-1]]-min;
           flux[drum[i],drum[i-1]]:=flux[drum[i],drum[i-1]]+min;
           a[drum[i-1],drum[i]]:=a[drum[i-1],drum[i]]+min;
         end
        else
         begin
           a[drum[i],drum[i-1]]:=a[drum[i],drum[i-1]]+min;
           flux[drum[i],drum[i-1]]:=flux[drum[i],drum[i-1]]-min;
           a[drum[i-1],drum[i]]:=a[drum[i-1],drum[i]]-min;
         end;
      getdrum;
     end;

     min:=0;
     for i:=n+1 to n*2+1 do min:=min+flux[i,n*2+2];

     assign(f,'output.txt');
     rewrite(f);
     if min<aa then writeln(f,'NO')
      else
       begin
        writeln(f,'YES');
        for i:=1 to n do for j:=1 to n do a[i,j]:=0;
        for i:=2 to n*2+1 do for j:=2 to n*2+1 do
         if flux[i,j]=1 then a[i-1,j-n-1]:=1;
        for i:=1 to n do
         begin
          for j:=1 to n do write(f,a[i,j],' ');
          writeln(f);
         end;
       end;
     close(f);
     writeln('Rezultatul in OUTPUT.TXT');
     readkey;
   end;

begin
  ReadData;
  rezolv;
end.
-----------------------------------
Solutia 3 (Ovidiu Ghiorghioiu)
{Format fisier intrare: pe prima linie numarul N de varfuri
                        pe urmatoarele N linii gradul de iesire,
                        respectiv intrare al varfului i}

const nmax=50;
      mmax=nmax*2+2;
var fi,fo:text;
    f,c:array[1..mmax,1..mmax] of integer;
    gi,go:array[1..nmax] of integer;
    i,j,k,n,fmax,si,so,nn:integer;
    m:array[1..mmax] of boolean;
    posibil:boolean;

procedure citeste;
begin
     assign(fi,'graf.in');reset(fi);
     read(fi,n);
     for i:=1 to n do read(fi,gi[i],go[i]);
     close(fi)
end;

function trace(k:integer):boolean;
var i:integer;
begin
     if k=nn then trace:=true
     else begin
          m[k]:=true;
          for i:=2 to nn do if not m[i] then begin
              if (f[k,i]<c[k,i]) and trace(i) then begin
                 trace:=true;
                 inc(f[k,i]);
                 exit
              end;
              if (f[i,k]>0) and trace(i) then begin
                    trace:=true;
                    dec(f[i,k]);
                    exit
              end;
          end;
          trace:=false;
     end;
end;

procedure rezolva;
begin
     for i:=1 to n do begin
         inc(si,gi[i]);
         inc(so,go[i])
     end;
     for i:=1 to n do c[1,i+1]:=go[i];
     for i:=1 to n do
         for j:=1 to n do c[i+1,j+n+1]:=byte(i<>j);
     nn:=n*2+2;
     for i:=1 to n do c[i+n+1,nn]:=gi[i];
     fmax:=0;
     while trace(1) do begin
           inc(fmax);
           fillchar(m,nn,false);
     end;
     posibil:=fmax=si;
end;

procedure scrie;
begin
     assign(fo,'graf.out');rewrite(fo);
     if posibil then begin
        writeln(fo,'DA');
        for i:=1 to n do begin
            for j:=1 to n do write(fo,f[i+1,j+n+1],' ');
            writeln(fo)
        end;
     end;
     close(fo);
end;

begin
     citeste;
     rezolva;
     scrie;
end.
-----------------------
