sâmbătă, 2 februarie 2013

Probleme de informatica rezolvate

Probleme de informatica rezolvate  




Problema 1
Se dau n oraşe. Se cunoaşte distanţa dintre oricare două oraşe. Un distribuitor de carte caută să-şi facă un depozit în unul dintre aceste oraşe. Se cere să se găsească traseul optim de la depozit către celelalte oraşe astfel încât distanţa totală pe care o va parcurge pentru a distribui în toate celelalte n-1 oraşe să fie minimă. Să se precizeze care ar fi oraşul în care să se afle depozitul pentru ca toate celelalte oraşe să fie uşor accesibile {din acel centru de depozitare să se poată pleca spre cât mai multe alte oraşe}.
Rezolvare:
program oraş_depozit;
uses crt;
type muchie=record
            vf1, vf2, cost:integer;
            end;
type vector=array[1..100] of longint;
            vector1=array[1..100] of muchie;
            matrice=array[1..50,1..50] of longint;
var n, i, j, k, v, cost:integer;
            s, t:vector:
            x:vector1;
            a:matrice;
            f:text;
procedure citire;
var i, j, m:integer;
begin
            assign (f, ‘depozit.txt’);
            reset (f);
            readln (f, n); m:=0;
            while not eof(f) do
            begin
                        inc(m);
                        read (f,x[m].vf1);
                        read (f,x[m].vf2);
                        read (f,x[m].cost);
            end;
            for i:=1 to m do
            begin
                        a[x[i].vf1, x[i].vf2:=x[i].cost];
                        a[x[i].vf2,  x[i].vf1:=x[i].cost];
            end;
            writeln (‘matricea costurilor este:’);
            for i:=1 to n do
            begin
                        for j:=1 to n do
                        write (a[i,j], ‘ ‘);
                        writeln;
            end;
end;
procedure prim;
var i, j, min:integer;
begin
            for i:= to n do
            s[i]:=v;
            s[v]:=0
            for i:=1 to n do
            t[i]:=0;
            cost:=0;
            for k:=1 to n-1 do
            begin
                        min:=maxint;
                        for i:=1 to n do
                        if (s[i]<>0) then
                                   if (a[s[i], i]<min) and (a[s[i], i]<>0) then
                                   begin
                                               min:=a[s[i], i];
                                               j:=1;
                                   end;
                                   t[j]:=s[j];
                                   cost:=cost+a[j, s[j]];
                                   s[j]:=0
                        for i:=1 to n do
                        if  (s[i]<>0) then
                        if (a[i,s[i]]=0) or (a[i,s[i]]>a[i,j]) then
                        if a [i,j]<>0 theen
                        s[i]:=j;
            end;
end;
function fii(x:integer):integer;
var k:integer;
begin
            k:=0;
            for i:=1 to n do
            if t[i]=x then
            inc(k);
            fii:=k;
end;
procedure tata(v:integer);
var i:integer;
begin
            for I:=1 to n do
            if t[v]=i then
            begin
                        t[i]:=v;
                        t[v]:=0;
            end;
end;
procedure oraş;
var max,i,j:integer;
begin
            max:=0;
            for i:=1 to n do
            if fii(i)>max then
            max:=fii(i);
            writeln(‘orasele optime sunt:’)
            for i:=1 to n do
            if fii(i)=max then
            begin
                        write(i,’ ‘);
                        tata(i);
                        write (‘vectorul tata este:’);
                        for j:=1 to n do write(t[j], ‘ ‘);
                        writeln;
            end;
end;
begin
clrscr;
            citire;
            writeln(‘dati vf de pornire’) ; readln(v) ;
            prim ;
            writeln(‘costul arborelui este :’, cost) ;
            oras;
readkey ;
end.
Problema 2
Se dă un graf neorientat. Să se creeze un arbore parţial de cost minim care să poată fi memorat apoi sub forma unei liste.
Rezolvare:
Program arbore_lista;
uses crt;
type muchie=record
            vf1, vf2, cost:integer;
            end;
type vector=array[1..50] of longint;
            vector1=array[1..100]of muchie;
            matrice=array[1..20,1..50]of longint
var n,i,j,k,v,cost,y,z,m:integer;
            s,t,s1,t1:vector;
            x:vector1;
            a,a1:matrice;
            f:text;
procedure citire;
var i,j,m:integer;
begin
            assign (f, ’depozit.txt’);
            reset (f);
            readln (f,n); m:=0;
            while not eof (f) do
            begin
                        inc(m);
                        read (f,x[m].vf1);
                        read (f,x[m].vf2);
                        read (f,x[m].cost);
                        readln (f);
            end;
            for i:=1 to m do
            begin
                        a[x[i].vf1, x[i].vf2:=x[i].cost];
                        a[x[i].vf2, x[i].vf1:=x[i].cost];
            end;
            writeln ( ’matricea costurilor este:’);
            for i:=1 to n do
            begin
                        for j:=1 to n do
                        write (a[i,j], ’ ’);
                        writeln
            end;
end;
function fii (y:integer):integer;
var k,j:integer;
begin
            k:=0;
            for j:=1 to n do
            if t[j]=y then
            inc(k);
            fii:=k;
end;
procedure prim (a:matrice);
var i,j,min:integer;
begin
            min:=maxint;
            for i:=1 to n do
            if (s[i]<>0) then
                        if (a[s[i], i]<min) and (a[s[i],i]<>0
then
begin
            min:=a[s[i], i];
            j:=i;
end;
            if (((s[j]<>v) and (fii(s[j])=0)) or (s[j]=v) and (fii(s[j])<=1))) then
                        begin
                                   t[j]:=s[j];
                                   cost:=cost+a[j,s[j]];
                                   s[j]:=0;
                                   for i:=1 to n do
                                   if (s[i]<>0) then
                                   if (a[i,s[i]]=0) or (a[i,s[i]]>a[i,j]) then
                                   if a[i,j]<>0 then
                                   s[i]:=j;
                                   inc(m);
                        end;
            else
                        begin
                                   a1:=a;
                                   a1[s[j],j]:=0;
                                   prim (a1);
                        end;
end;
begin
clrscr;
            citire;
            writeln(’dati vf de pornire’); readln(v);
            m:=0;
            for i:=1 to n do
            s[i]:=v;
            s[v]:=0;
            for i:=1 to n do
            t[i]:=0;
            cost:=0;
            repeat prim(a);
            until m=n-1;
            write (’vectorul tata este:’);
            for i:=1 to n do
            write (t[i], ’ ’);
            writeln;
            writeln (’costul arborelui este:’ , cost);
readkey;
end.  
Problema 3
Se dă  un graf orientat şi se cere să se afle dacă există un arbore parţial de cost minim. Dar o arborescenţă de cost minim? Dacă există să se afle care este este vârful acesteia.
Rezolvare
program arborescenta;        
uses crt;
type muchie=record
     vf1,vf2,cost:integer;
     end;
type vector=array[1..100] of longint;
     vector1=array[1..100] of muchie;
     matrice=array[1..50,1..50] of longint;
var n,i,j,k,v,cost:integer;
    s,t:vector;
    x:vector1;
    a:matrice;
    f:text;
procedure citire;
var i,j,m:integer;
begin
    assign(f,'orient.txt');
    reset(f);
    readln(f,n);m:=0;
    while not eof(f) do
    begin
       inc(m);
       read(f,x[m].vf1);
       read(f,x[m].vf2);
       read(f,x[m].cost);
       readln(f);
    end;
    for i:=1 to m do
        a[x[i].vf1,x[i].vf2]:=x[i].cost;
    writeln('Matricea costurilor este:');
    for i:=1 to n do
    begin
      for j:=1 to n do
      write(a[i,j],' ');
      writeln;
    end;
end;
procedure prim;
var i,j,min:integer;
begin
   for i:=1 to n do
   s[i]:=v;
   s[v]:=0;
   for i:=1 to n do
   t[i]:=0;
   cost:=0;
   for k:=1 to n-1 do
   begin
      min:=maxint;
      for i:=1 to n do
      if (s[i]<>0) then
        if (a[s[i],i]<min) and (a[s[i],i]<>0) then
        begin
          min:=a[s[i],i];
          j:=i;
        end;
        t[j]:=s[j];
        cost:=cost+a[s[j],j];
        s[j]:=0;
      for i:=1 to n do
      if  (s[i]<>0) then
      if (a[s[i],i]=0) or (a[s[i],i]>a[j,i]) then
      if a[j,i]<>0 then
      s[i]:=j;
   end;
end;
begin {main}
clrscr;
   citire;
   writeln('Dati vf de pornire!');readln(v);
   prim;
   writeln('Vectorul tata este:');
   for i:=1 to n do
   write(t[i],' ');
   writeln('Costul arborelui este:',cost);
readkey;
end.
 Problema 4
Se dă un graf conex. Se cere împărţirea acestuia în m arbori parţiali de cost minim fiecare cu p vârfuri. Să se afişeze aceşti arbori.

Rezolvare

program arbori;
uses crt;
type vector=array[1..100] of longint;
program m_arbori;
uses crt;
type vector=array[1..100] of longint;
matrice=array[1..50,1..50] of longint;
var n,i,j,k,v,cost,p,m:integer;
            s,t:vector;
            a:matrice;
            f:text;
procedure citire;
var i,j:integer;
begin
            assign(f,'prim.txt');
            reset(f);
            readln(f,n);
            for i:=1 to n do
            begin
                        for j:=1 to n do
                        read(f,a[i,j]);
                        readln(f);
            end;
            writeln('Matricea costurilor este:');
            for i:=1 to n do
            begin
                        for j:=1 to n do
                        write(a[i,j],' ');
                        writeln;
            end;
end;
procedure prim;
var i,j,min,h:integer;
begin
cost:=0;
            for h:=1 to p-1 do
             begin
                        min:=maxint;
                         for i:=1 to n do
                        if (s[i]>0) then
                        if (a[s[i],i]<min) and (a[s[i],i]<>0) then
                        begin
                                   min:=a[s[i],i];
                                   j:=i;
                        end;
                        t[j]:=s[j];
                        cost:=cost+a[j,s[j]];
                        s[j]:=0;
                        write(j,' ');
                        for i:=1 to n do
                        if  (s[i]>0) then
                        if (a[i,s[i]]=0) or (a[i,s[i]]>a[i,j]) then
                        if a[i,j]<>0 then
                        s[i]:=j;
                        t[j]:=-1;
                        s[j]:=-1;
                        for i:=1 to n do
                        begin
                                   a[i,j]:=0;
                                    a[j,i]:=0;
                        end;
            end;
            write('Costul arborelui este:',cost);
end;
begin {main}
clrscr;
citire;
            writeln('Dati vf de pornire!');readln(v);
            write('m=');read(m);
            write('p=');read(p);
            for i:=1 to n do
            s[i]:=v;
            s[v]:=0;
            for i:=1 to n do
            t[i]:=0;
            for k:=1 to m-1 do
            begin
                        for i:=1 to n do
                        begin
                                    if t[i]=0 then
                                   begin
                                   write(i,' ');
                                   prim;
                                   for j:=1 to n do
                                   if t[j]=0 then s[j]:=i;
                                   s[i]:=-1;writeln;
                                   end;
                                   s[v]:=-1;
                                   t[v]:=-1;
                        end;
            end;
readkey;
end.
            Problema 5
            Se defineşte o muchie a unui graf neorientat ca fiind o înregistrare cu trei câmpuri, două vârfuri extremităţi şi un cost afişare. Să se afişeze muchia de cost minim.
Rezolvare
Program cost;
type muchie=record;
            vf1, vf2, cost:integer;
end;
var v:array[1..100]  of muchie;
            m,n:integer;
procedure citire;
var i:byte;
begin
            read(m); read(n);
            for i:=1to m do with v(i) do
            repeat
            read(vf1, vf2, cost);
            until (vf1>=1)and(vf1<=n)and(vf2>=1)and(vf2<=n)and(vf1<>vf2)and
            (cost>0);
            min:=v[i].cost;
            for i:=2to m do if v[i].cost=min then
            min:=v[i].cost;
            for i:=1 to m do if v[i].cost=min then
            writeln(i);
end.
            Problema 6
            Se defineşte o muchie a unui graf neorientat ca o înregistrare de trei corpuri, cele două vârfuri extremităţi şi un cost apreciat muchiei. Definim un graf neorientat ca vector al muchiilor. Se dă n>=numărul de noduri. Să se construiască şi să se afle matricea de adiacenţă şi apoi să se determine costul mediu.
Rezolvare:
Program matrice;
type muchie=record;
            vf1, vf2, cost:integer;
            end;
type mat:=array[1..100,1..100] of byte
var v:array[1..100] of muchie
            i,j,m,n:integer; s:integer;
procedure citire;
var v:byte; med:real; s;integer;
begin
            for i:=1 to n do
            for j:=1 to n do a[i,j]:=0
            begin
read (m,n)
                        for i:=1 to m with v[i] do begin
repeat
                        read (vf1, vf2, cost);
until(vf1>=1)and(vf1<=n)and(vf2>=1)and(vf2<=n)and(vf1<>vf2)and (cost>0);
                        a[vf1,vf2]:1
end;
for i:=1 to n do
for j:=1 to n do
write (a[i,j]);
end.
Problema 7
Se considera un graf neorientat cu n varfuri numerotate 1..n. Cele n varfuri reprezentand orase. Un automobil pleaca dintr-un oras start, trece prin toate orasele o singura data si revine in orasul din care a plecat. Sttind ca intre unele orase exista drumuri directe si intre altele nu sa se afiseze toate traseele pe care le poate urma automobilul.
Rezolvare :
Program orase ;
type mat=array[1..100,1..100] of 0..1;
            vec=array[1..100] of byte;
var a:mat; st:vec; start, n :integer;
procedure citire;
var i:integer;
begin
read(n);
for i:=1to n do a[i,j]:=0;
for i:=1 to n-1 do       
for j:=i+1to n do
begin
read a[i;j];
a[j,i]:=a[i,j]
            end;
            for i:=1 to n do st[i]:=0;
            repeat
            read (start)
            until (start>=1)and(start<=n);
            st[i]:=start
end;
procedure tipar(p:byte);
var i:byte;
begin
            for i:=1 to p do write (st[p], ‘ ’);
end;
function valid(p:byte):boolean;
var i:byte; t:boolean;
begin
t:=true
for i:=1 to p-1 do
if st[i]:=st[p] then t:=false
if a[st[p], st[p-1]]=o then t:=false
valid:=t;
end;
procedure bktr(p:byte);
var k:byte;
begin
            for k:=1 to n do
            begin
                        st[p]:=k;
                        if valid (p) then
                        if (p=n)and (a[st[1],st[p]]=1) then
                        tipar(p);
                        else bktr(p+1)

          end;

end;

begin

bktr(2);

read(n);

end.     


Problema 8

            Să se afişeze punctele izolate dintr-un graf neorientat.
Rezolvare:
Program puncte izolate
type mat=array[1..20,1..20]of integer;
var n:integer, a:mat;
procedure citire;
var i,j:integer;
begin
            readln(n);
            for i:=1 to n do a[i,j]:=0
            for i:=1 to n-1 do
            for j:=i+1 to n do
            begin
                        repeat
                        read a[i;j]:=0
                        until a[i;j]:=1 or a[i,j]:=0 or a[j,i]:=1;
            end;
end;
procedure izolare;
var s,i,j:integer;
begin
for i:=1 to n do
            begin
                        s:=0;
                        for j:=1 to n do
                        s:=s+a[i,j];
                        if s=a then writeln (i, ’este nod izolat’);
end;
citire izolate;
end.
Problema 9
Din fişierul text se află numere întregi aflate pe un singur rând, separate prin spaţii. Să se verifice dacă secvenţa de numere formează lanţ elementar sau neeelementar într-un graf neorientat. Graful este dat prin matricea de adiacenţă şi se citeşte de la tastatură.
Rezolvare:
Program lanţ;
var a:array[1..50,1..50] of 0..1;
            v:array[1..50] of byte;
            n:byte; f:text;
procedure init;
var i,j:byte;
begin
readln(n);
            for i:=1 to n do a[i,j]:=0;
            for i:=1 to n-1 do
            for j:=i+1 to n do
            begin
                        read (a[i,j]);
                        a[j,i]:=a[i,j];
            end;
end;
procedure vector;
var k,j:byte;
begin
assign(f, ‘matrice.in’);
reset(f)
k:=0;
while (not(eoln(f)))do
begin
            inc(k);
            read (f,v[k]);
end;
close(f);
for j:=1 to k do
write(v[j], ‘ ‘);
t:=true;
for j:=1 to k-1 do
if a[v[j],v[j+1]]:=0 then t:=false;
if t:=false then
begin
            for i:=1 to k-1do
            for j:=i+1 to k do
            if v[i]=v[j] then t:=false;
end;
if t:true then writeln (‘lantul e elementar’);
               else writen (‘lantul e neelementar’);
end;
begin
init;
vector;
end.
            Problema 10
            Sa se genereze toate grafurile neorientate de n varfuri.
Rezolvare :
Program graf ;
type mat=array[1..100,1..100] of 0..1;
            vec=array[1..100] of 0..1;
var a:mat; st:vec; n:byte;
function final(p:byte):boolean;
begin
            if p=n(n-1)/2 then final:=true;
                                    else final:=false;
end;
procedure init;
var i:byte;
begin
            for i:=1 to n do a[i;j]:=0
end;
procedure tipar(p:byte);
var i,j:byte;
begin
            for i:=1 to n-1 do
            for j:=i-1to n do
            begin
                        a[i,j]:=st[n(i-1)—i(i+1)/2+j];
                        a[j,i]:=a[i,j];
            end;
            for i:= to n do
            begin
                        for j:=1 to n do write (a[i,j], ‘ ‘);
                        writeln;
            end;
end;
procedure bktr(p:byte);
var k:byte;
begin
for k:=0 to 1 do      
            begin
                        st[p]:=k;
                        if final (p) then tipar(p)
                                          else bktr(p+1)
            end;
end;
begin
init
bktr(1); readln;
end.

 

 

 

Problema11

            Se dau 7 culori, codificate prin nr. 1, 2, …, 7. Afişaţi toate posibilităţile de alcătuire a unor drapele tricolore care să conţină numai culori dintre cele date, astfel încât: culoarea din mijloc să aparţină unui set dat de patru culori din rândul celor 7 disponibile; a treia culoare nu poate să fie c unde c este un nr. întreg cuprins între 1 şi 3; cele trei culori de pe drapel să fie distincte.
Rezolvare:
program drapele;
                 const n=7;
                 type stiva=array [1..10] of integer;
                 var st:stiva;
                 ev,as:boolean;
                 n,k:integer;
                 procedure init(k:integer;var st:stiva);
                 begin  st[k]:=0;
                 end;
                 procedure succesor(var as:boolean;var st:stiva;k:integer);
                 begin
                            if st[k]<7 then
                                        begin st[k]:=st[k]+1;
                                                     as:=true;
                                      end
                                 else as:=false;
                 end;
                 procedure valid(var ev:boolean;var st:stiva;k:integer);
                 var i:integer;
                 begin
                            ev:=true;
                            for i:=1 to k-1 do if st[i]=st[k] then ev:=false;
                            if (st[3]=1) or (st[3]=3) or (st[3]=2) then ev:=false;
                             if st[3]=(1,2,3) then ev:=false;
                             for i:=1 to 4 do if st[2]<>st[i] then ev:=false;
                 end;
                 function solutie(k:integer):boolean;
                 begin
                            solutie:=(k=n);
                 end;
     
                 procedure tipar;
                 var i:integer;
                 begin
                            for i:=1 to n do write (st[i]);
                            writeln;
                 end;
                 begin;
                            k:=1;init(k,st);
                            while k>0 do
                             begin
                                         repeat
                                        succesor (as,st,k);
                                        if as then valid(ev,st,k);
                                        until (not as) or (as and ev);
                                        if as then
                                        if solutie(k) then tipar
                                 else
                                        begin
                                              k:=k+1;
                                              init(k,st)
                                        end
                                        else k:=k-1;
                            end;
                            readln;
                 end.
                            Problema12
                  Se dau n cuburi numerotate 1,2,...,n, de laturi Li si culori Ci, i=1,2,...,n (fiecare culoare este codificata printr-un caracter). Sa se afişeze toate turnurile care se pot forma luând k cuburi din cele n disponibile, astfel încât:
                  -laturile cuburilor din turn sa fie in ordine crescătoare;
                  -culorile a oricare doua cuburi alăturate din turn sa fie diferite.
Rezolvare:
program cuburi;
type stiva=array [1..100] of integer;
var st:stiva;
                       i,n,p,k:integer;
                       as,ev:boolean;
                       L:array [1..10] of integer;
                       C:array [1..10] of char;
procedure init(k:integer;var st:stiva);
begin
st[k]:=0;
end;
procedure succesor(var as:boolean;var st:stiva;k:integer);
begin
if st[k]<n then
                            begin
                                        st[k]:=st[k]+1;
                                        as:=true;
                            end
                            else as:=false;
end;
procedure valid(var ev:boolean;st:stiva;k:integer);
var i:integer;
begin
ev:=true;
for i:=1 to k-1 do if L[st[k]]<=L[st[i]] then ev:=false;
if C[st[k]]=C[st[k-1]] then ev:=false;
end;
function solutie(k:integer):boolean;
begin
solutie:=(k=p);
end;
procedure tipar;
var i:integer;
begin
for i:=1 to p do write(st[i],’ ‘);
writeln;
end;
begin
write(‘n= ‘);read(n);
write(‘p= ‘);read(p);
for i:=1 to n do
begin
write(‘L[‘,i,’]=’);readln(L[i]);
write(‘C[‘,i,’]=’);readln(C[i]);
end;
                            k:=1;init(k,st);
                            while k>0 do
                             begin
                                         repeat
                                         succesor(as,st,k);
                                        if as then valid(ev,st,k);
                                        until (not as) or (as and ev);
                                        if as then if solutie(k) then tipar
                                        else
                                        begin
                                        k:=k+1;                                
                                                    init(k,st);
                                        end
                                        else k:=k-1;
                            end;
                 end.
                            Problema13
            Scrieţi un program care, folosind metoda backtracking, afişează  toate modurile de a aranja elementele unui şir dat de numere întregi astfel încât in şirul rezultat sa nu existe doua elemente negative alăturate.
Rezolvare:
program sir;
type stiva=array[1..100] of integer;
vector=array[1..100] of integer;
var st:stiva;
                            n,k,i:integer;
                            as,ev:boolean;
                            a:vector;
procedure init(k:integer;var st:stiva);
begin
st[k]:=0
end;
procedure succesor(var as:boolean;var st:stiva;k:integer);
begin
if st[k]<n then
begin
                                        st[k]:=st[k]+1;
                                        as:=true;
                         end
                  else as:=false;
end;
procedure valid(var ev:boolean;st:stiva;k:integer);
var i:integer;
begin
ev:=true;
for i:=1 to k-1 do if st[k]=st[i] then ev:=false;
if (a[st[k]]<0) and (a[st[k-1]]<0) then ev:=false;
end;
function solutie(k:integer):boolean;
begin
solutie:=(k=n);
end;
procedure tipar;
var i:integer;
begin
for i:=1 to n do write(a[st[i]],' ');
writeln;
end;
begin
write('n=');readln(n);
for i:=1 to n do
begin
write(‘a[‘,i,’]=’);readln(a[i]);
end;
k:=1;init(k,st);
while k>0 do
                            begin
                                        repeat
                                        succesor(as,st,k);
                                        if as then valid(ev,st,k);
                                        until (not as) or (as and ev);
                                        if as then if solutie(k) then tipar
                                    else
begin
                                                    k:=k+1;                                
                                                    init(k,st);
                                        end
                                        else k:=k-1;
                            end;
end.
            Problema14
Un comis-voiajor trebuie sa viziteze un numar n de orase. Iniţial, acesta se afla intr-unul dintre ele, notat 1. Comis-voiajorul doreşte sa nu treacă de doua ori prin acelaşi oraş, iar la întoarcere sa revină in oraşul 1. Cunoscând legaturile existente intre orase, se cere sa se tipărească toate drumurile posibile pe care le poate efectua comis-voiajorul.
                 Rezolvare:
program comisv;
type stiva=array[1..100] of integer;
var st:stiva;
                            i,j,n,k:integer;
                            as,ev:boolean;
                            a:array[1..20,1..20] of integer;
procedure init(k:integer;var st:stiva);
begin
st[k]:=1;
end;
procedure succesor(var as:boolean;var st:stiva;k:integer);
begin
if st[k]<n then
begin
                                        st[k]:=st[k]+1;
                                        as:=true
                 end
                else as:=false
end;
procedure valid(var ev:boolean;st:stiva;k:integer);
var i:integer;
begin
ev:=true;
if a[st[k-1],st[k]]=0 then ev:=false
else
for i:=1 to k-1 do if st[i]=st[k] then ev:=false;
if (k=n) and (a[1,st[k]]=0) then ev:=false
end;
function solutie(k:integer):boolean;
begin
solutie:=(k=n)
end;
procedure tipar;
var i:integer;
begin
for i:=1 to n do
write(‘nodul=’,st[i]);
end;
begin
write(‘nr. de noduri=’);readln(n);
for i:= 1 to n do
for j:=1 to i-1 do
begin
write(‘a[‘,i,’,’,j,’]=’); readln(a[i,j]);
a[j,i]:=a[j,i];
                            end;
st[1]:=1; k:=2;
init(k,st);
while k>0 do
                            begin
                                        repeat
                                        succesor(as,st,k);
                                        if as then valid(ev,st,k);
                                        until (not as) or (as and ev);
                                        if as then if solutie(k) then tipar
                                    else
begin
                                                    k:=k+1;
                                                init(k,st);
                                        end
                                        else k:=k-1;
                            end;
                 end.
                            Problema15
                            Sa se afişeze nodurile izolate dintr-un graf neorientat
                 Rezolvare:
                 Program noduri izolate;
                 type matrice=array[1..50,1..50]of byte
                 var a :matrice;
             n, i, j:integer;
             v1, v2=array[1..50] of byte;
procedure citire
var x,y:integer;
begin
             readln(m,n)
             for i:=1to n do
             begin
                         v1[i]:=0, v2[i]:=0
             end;
             for j:=1 to n do
             begin
                         repeat read (x,y) until (x>=1)and(x<=n)and(y>=1)and(y<=n)and(x<>y)
                         v1[x]=v1[x]+1;
                         v2[y]=v2[y]+1;
            end;
            for i:=1 to n do
            if (v1[i]=v2[i])and(v1[i]=0)
            then writeln(j);
end.
            Problema16
            Se citeste de la tastatura matricea de adiacenta asociata unui graf neorientat cu n noduri. Sa se scrie arcele grafurilor in fisierul arce.txt
Rezolvare:
Program arce;
var a:array[1..50,1..50]of 0..1
            f:text, n:byte;
procedure citire;
var i,j:byte
begin
            read(n)
            for i:=1to n do a[i,j]:=0
            for i:=1to n do j:=1 to n do read (a[i,j])
end
procedure rezolvare
var i,j:byte
begin
            assign(f,’arce.txt’); rewrite(f);
            for i:=1 to n do
            for j:=1to n do
            if a[i,j]:=1
            then writln(f,i,’ ’,j);
            close(f)
end;
begin
citire; rezolvare;
end.
            Problema 17
            Sa se tipareasca toate lanturile neelementare care trec prin varfurile v1 si v2.
Rezolvare:
Program lanturi;
var a:array[1..50,1..50]of 0..1;
       st:array[1..50]of byte;
       v1,v2,n:byte;
procedure init;
var i,j:byte;
begin
            readln(n);
            for i:=1 to n-1do
            for j:=i+1to n do
            begin
                        rea (a[i,j]); a[j,i]:=a[i,j]);
            end;
            repeat readln(v1, v2);
            until (v1<>v2)and(v1<=n)and(v1>=1)and(v2>=1)and(v2<=n);
 end;
procedure tipar(p:byte);
var i:byte;
begin
            for i:=1 to p do write(s+i)
end;
function valid(p:byte):boolean;
var i:byte; t:boolean;
begin
            t=true;
            for i:=1 to p-1 do
            if st[p]=st[i] then t:=false;
            if a[st[p],st[p-1]]=0 then t:false;
            valid:=t;
end;
function final(p:byte):boolean;
var t:boolean; i:byte;
begin
            t:=false
            for i:=1 to p do if v1=st[i] then
            for j:=1 to p do if v2=st[i] then
            if p=k then t:true;
            final:=t
end;
procedure bktr(p:byte);
var l:byte;
begin
            for l:=1 to n do
            begin
                        st[p]:=l;
            end;
            valid (p) then
            if final (p) then tipar(p);
                               else bktr(p+1);
end;
begin init;
for k:=3 to n do bktr(1);
end.

0 comentarii:

Trimiteţi un comentariu

Arhiva