Programul care determina arborele partial de cost minim al unui gaf

 

program Arbore_partial_de_cost_minim;

type lista=record

       x,y,z:integer;

     end;

var a,b:array[1..100,1..100] of boolean; {matricile de adiacenta}

    v:array[1..1000] of lista; {lista de costuri si legaturi}

    u:array[1..100] of boolean;

    j,i,n,nrv,nrleg:integer;

    f,g:text;

(**********************)

procedure citire_date;

          var x,y,z:integer;

          begin

           assign(f,'arbore.in'); reset(f);

            readln(f,n);

            nrv:=0; {numarul de legaturi este initial 0}

            fillchar(a,sizeof(a),false); {se initializeaza matricile a si b cu false pe toate pozitiile}

            fillchar(b,sizeof(b),false);

            while not eof(f) do begin

               readln(f,x,y,z);

               {x si y sunt doua noduri iar z este costul legaturii dintre ele}

               inc(nrv);

               v[nrv].x:=x;

               v[nrv].y:=y;

               v[nrv].z:=z;

               {se adauga in lista urmatoarea legatura citita din fisier}

            end;

           close(f);

          end;

(**********************)

procedure sortare;  {se sorteaza crescator, dupa cost, lista de legaturi}

          var f:boolean;

              i:integer;

              aux:lista;

          begin

            repeat

              f:=true;

               for i:=1 to nrv-1 do begin

                  if v[i].z>v[i+1].z then begin

                     aux:=v[i];

                     v[i]:=v[i+1];

                     v[i+1]:=aux;

                     f:=false;

                  end;

               end;

            until f=true;

          end;

(**********************)

function aciclic:boolean;  {functia are valoarea true daca nu exista ciclu in graf}

         var f:boolean;

         i:integer;

          procedure back(x:integer);

          var i:integer;

          begin

            if u[x] then f:=false else begin

              u[x]:=true;

               for i:=1 to n do

                 if a[x,i] then begin

                     a[x,i]:=false;

                     a[i,x]:=false;

                     back(i);

                 end;

            end;

          end;

         begin

           fillchar(u,sizeof(u),false);

            f:=true;

             for i:=1 to n do

              if not(u[i]) then back(i);

              aciclic:=f;

         end;

(**********************)

procedure prog;

          var j:integer;

          begin

            nrleg:=0; {numarul de legaturi este initial 0}

            j:=0;   {contorul listei de legaturi este initial 0}

            repeat

               inc(j);  {se trece la urmatoarea legatura din lista}

               b[v[j].x,v[j].y]:=true;   {se introduce noua legatura in graf}

               b[v[j].y,v[j].x]:=true;

                 a:=b; {se copie matricea b in a pentru a se verifica existenta ciclurilor}

                       {este necesara aceasta operatie deoarece matricea b va fi distrusa daca se va verifica}

                       {pe ea existenta ciclurilor}

                 if aciclic=true then inc(nrleg) {daca nu exista cicluri atunci creste cu 1 numarul de legaturi din graf}

                   else begin {altfel se scoate legatura j din graf}

                      b[v[j].x,v[j].y]:=false;

                      b[v[j].y,v[j].x]:=false;

                   end;

            until nrleg=n-1;  {se repeta aceste operatii pana cand numarul de legaturi din graf este n-1}

                              {aceasta este conditia pentru ca graful b sa fie arbore}

          end;

(**********************)

Begin

citire_date;

sortare;

prog;

assign(g,'arbore.out'); rewrite(g);

for i:=1 to n do

  for j:=i to n do begin

    if b[i,j]=true then

     writeln(g,i,' ',j);

  end;

close(g);

End.