Liste, multimi, arbori, stive, cozi - algoritmi si probleme rezolvate

Liste, multimi, arbori, stive, cozi

1. Ciurul lui Eratostene-varianta multime

program Eratostene_varianta_multime;
type ind=0..255;
var n,i,j,k:ind;

mult:set of ind;

sf:char;
begin

sf := 'D';

repeat
write ('n=');
readln (n);
mult:=[.n];
j:=0;
writeln('Numerele prime pana la ',n);
for i:=2 to n do

if i in mult then

begin
write (i:4);
j:=j+1;
k:=2;
while i*k<=n do

begin

mult:=mult-[i*k];
k:=k+1;
end;

end;
writeln;
writeln('Numarul de elemente prime ',j);
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

Sume maxime de numere intregi

program sume_de_numere;
const nmax=100;
type sir=array[1..nmax]of byte;
var s,a:sir;

i,j,nr,n:byte;
f:file of byte;
l:string[80];
ss:longint;
nume:string[10];

sf:char;
begin
sf := 'D';

repeat
write('nume fisier input:');
readln(nume);
assign(f,nume);
rewrite(f);
write('dati nr. de linii:');
readln(n);
write(f,n);

for i:=1 to n do

begin
writeln('Linia cu',i:2,' numere');
for j:=1 to i do

begin

write(j:3,'. ');
readln(nr);
write(f,nr);

end;

end;
reset(f);
read(f,n);
for i:=1 to nmax do s[i]:=0;
writeln ('sumele partiale sunt:');
for i:=1 to n do

begin

for j:=1 to i+1 do a[j]:=s[j];
read(f,nr);
s[1]:=s[1]+nr;
for j:=2 to i do

begin

read(f,nr);
if a[j-1]<a[j] then s[j]:=a[j]+nr

else s[j]:=a[j-1]+nr;
end;
s[i+1]:=nr;
for j:=1 to i do write(s[j],' ');
writeln;

end;
ss:=s[1];
for j:=1 to i+1 do

if ss<s[j] then ss:=s[j];
writeln('Suma maxima=',ss:5);
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

3. Eliminare elemente-varianta vector logic

program cerc1_varianta_vector_boolean;
const nmax=100;
type nr=1..nmax;
var i,k,n:nr;

j,m:integer;
prezent:array[nr] of boolean;

sf:char;
begin

sf := 'D';

repeat
write('n='); readln(n);
write('m='); readln(m);
for i:=1 to n do prezent[i]:=true;
i:=n;
for k:=1 to n do begin

for j:=1 to m do
repeat
if i<n then i:=i+1 else i:=1

until prezent[i];
write(i:3);
prezent[i]:=false;

end;
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

4. Eliminare elemente-varianta vector numeric

program cerc2_varianta_vector_intregi;
const nmax =100;
type nr =1..nmax;
var i,k,n:nr;

j,m:integer;
next:array[nr] of nr;

sf:char;
begin
sf := 'D';

repeat
write('n='); readln(n);
write('m='); readln(m);
for i:=1 to n-1 do next[i]:=i+1;
next[n]:=1;
i:=n;
while next[i] <> i do begin

for j:=1 to m-1 do i:=next[i];
write(next[i]:3);
next[i]:=next[next[i]];

end;
writeln(i:3);
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

5. Eliminare elemente-varianta calcul iterativ

program cerc3_varianta_calcul_iterativ;
const nmax=100;
type nr=1..nmax;
var i,k,n:nr;

j,m:integer;
copil:array[nr] of nr;

sf:char;
begin
sf := 'D';

repeat
write('n='); readln(n);
write('m='); readln(m);
for i:=1 to n do copil[i]:=i;
i:=1;
for k:=n downto 1 do begin

i:=(i+m-2) mod k+1;
write(copil[i]:3);
for j:=i to k-1 do

copil[j]:=copil[j+1];
end;
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

6. Eliminare elemente-varianta multime

program cerc4_varianta_multime;
const nmax=100;
type numar=1..nmax;
var i,n:numar;

j,m:integer;
multime:set of numar;

sf:char;
begin
sf := 'D';

repeat
write('n='); readln(n);
write('m='); readln(m);
multime:=[1..n];
i:=n;

while multime<>[] do begin
for j:=1 to m do
repeat
if i<n then i:=i+1

else i:=1
until i in multime;
write(i:3);

multime:=multime-[i];
end;
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

7. Eliminare elemente-varianta alocare dinamica

program cerc5_varianta_alocare_dinamica;
const nmax=100;
type list=^term;

term=record
nr:integer;
next:list;
end;

var i,n:1..nmax;
j,m:integer;
prim,p:list;

sf:char;

begin
sf := 'D';

repeat
write('n='); readln(n);
write('m='); readln(m);
new(prim);
p:=prim;
for i:=1 to n do begin

p^.nr:=i;

if i<n then begin
new(p^.next);
p:=p^.next;

end;
end;
p^.next:=prim;
i:=n;
while i>0 do begin

for j:=1 to m-1 do p:=p^.next;
write(p^.next^.nr:3);
p^.next:=p^.next^.next;
i:=i-1;

end;
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

8. Diferenta multimilor alocate static

program diferenta_a_doua_multimi;
const n_max=50;
type vector=array[1..n_max] of integer;

header=string[20];
var a,b:vector;
na,nb:integer;

sf:char;
procedure citire_vector(var v:vector; var n:integer;x:char);
var i:integer;
begin

repeat
write('nr de componente:');
readln(n)

until n in [1..n_max];

for i:=1 to n do begin
write(x,'[',i,']=');
readln(v[i])

end;

writeln;
end;
procedure afisare_vector(v:vector; n,nr_lin:integer;h:header);
var i:integer;
begin

write(h);
for i:=1 to length(h) do h[i]:=' ';
for i:=1 to n do begin

write(v[i]:3);
if (i mod nr_lin=0)and(i<n)then begin
writeln;

write(h)
end

end
end;
function exist(v:vector;val:integer; n:integer):boolean;
var i:integer;
begin

i:=1;
while (i<n) and (val<>v[i]) do inc(i);
exist:=(n>0) and (val=v[i])

end;
procedure insert(var v:vector;val:integer;var n:integer);
begin

if not exist(v,val,n) then begin
n:=n+1;
v[n]:=val

end;
end;
procedure det_dif (v1,v2:vector;n1,n2:integer; h:header);
var d:vector;

nd,i:integer;
procedure scrie_dif;
var i:integer;
begin

if nd=0 then write ('Diferenta vida')

else afisare_vector(d,nd,5,h)
end;
begin

nd:=0;
for i:=1 to n1 do
if not exist (v2,v1[i],n2) then
insert(d,v1[i],nd);

scrie_dif
end;
begin

sf := 'D';

repeat
writeln('First vector:');
citire_vector(a,na,'a');
sf := 'D'; repeat

writeln('Second vector:');
citire_vector(b,nb,'b');
sf := 'D'; repeat
afisare_vector(a,na,10,'First vector:');
writeln;

afisare_vector(b,nb,10,'Second vector:');
writeln;
det_dif(a,b,na,nb,'FirstSecond:');
writeln;
det_dif(b,a,nb,na,'SecondFirst:');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

9. Operatii cu multimi generate dinamic

program reuniune_si_intersectie_generate_dinamic;
const nmax=100;
type list=^nod;

nod=record
info:integer;
next:list

end;

var a:array[1..nmax]of integer;
l,l1,l2:list;
n,i:integer;

sf:char;

function reun(l1,l2:list):list; forward;
function inters(l1,l2:list):list;forward;
function creal(i,n:integer):list;
var l:list;
begin

if i>n then creal:=nil

else

begin
new(l);
l^.next:=creal(i+1,n);
l^.info:=a[i];
creal:=l

end;
end;
procedure afisl(l:list);
begin

if l<>nil then begin
write(l^.info,' ');
afisl(l^.next)

end

end;

function atasare(x:integer;l1,l2:list):list;

var prim:list;

begin
new(prim);
prim^.info:=x;
prim^.next:=reun(l1,l2);
atasare:=prim;

end;

function atasare1(x:integer;l1,l2:list):list;

var prim:list;

begin
new(prim);
prim^.info:=x;
prim^.next:=inters(l1,l2);
atasare1:=prim;

end;

function reun(l1,l2:list):list;

begin
if (l1=nil)and(l2=nil) then reun:=nil
else if l1=nil then
reun:=atasare(l2^.info,nil,l2^.next)
else if l2=nil then
reun:=atasare(l1^.info, l1^.next,nil)
else if l1^.info<l2^.info then
reun:=atasare(l1^.info,l1^.next,l2)
else if l1^.info>l2^.info then
reun:=atasare(l2^.info,l1,l2^.next)
else
reun:=atasare(l1^.info,l1^.next,l2^.next)

end;

function inters(l1,l2:list):list;

begin
if (l1=nil)or(l2=nil) then inters:=nil
else if l1^.info<l2^.info then
inters:=inters(l1^.next,l2)
else if l1^.info>l2^.info then
inters:=inters(l1,l2^.next)

else

inters:=atasare1(l1^.info,l1^.next,l2^.next);
end;
begin

sf := 'D';

repeat
write('prima lista, n='); readln(n);
for i:=1 to n do read (a[i]);
l1:=creal(1,n);
writeln;
afisl(l1);
writeln;
write('A doua lista, n='); readln(n);
for i:=1 to n do read (a[i]);
l2:=creal(1,n);
writeln;
afisl(l2);
writeln;
l:=reun(l1,l2);
writeln('reuniunea');
afisl(l);
writeln;
l:=inters(l1,l2);
writeln('intersectia');
afisl(l);
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

10. Ordonare dinamica recursiva sir numeric

program sortare_dinamica_recursiva_prin_separare;
const nmax=100;
type list=^nod;

nod=record
info:integer;
next:list

end;

var     a:array[1..nmax]of integer;
k,n:integer;
l:list;

sf:char;

function fuzi(l1,l2:list):list;

begin
if l1=nil then fuzi:=l2
else if l2=nil then fuzi:=l1

else if l1^.info<=l2^.info then

begin
l1^.next:=fuzi(l1^.next,l2);
fuzi:=l1

end

else begin
l2^.next:=fuzi(l1,l2^.next);
fuzi:=l2

end
end;
function separ(l:list):list;
var l1:list;
begin

if l=nil then separ:=nil
else if l^.next=nil then separ:=nil

else begin
l1:=l^.next;
l^.next:=l1^.next;
l1^.next:=separ(l1^.next);
separ:=l1;

end;
end;
procedure sortfuzi(var l:list);
var l1:list;
begin

if l<>nil then

if l^.next <>nil then begin
l1:=separ(l);
sortfuzi(l);
sortfuzi(l1);
l:=fuzi(l,l1);

end;
end;
function creal(i,n:integer):list;
var l:list;

begin
if i>n then creal:=nil

else begin
new(l);
l^.next:=creal(i+1,n);
l^.info:=a[i];
creal:=l;

end;
end;
procedure afisl(l:list);
begin

if l<>nil then begin
write(l^.info,' ');
afisl(l^.next);

end;
end;
begin

sf := 'D';

repeat
write('n=');
readln(n);
for k:=1 to n do begin

write('a[',k,']=');

readln(a[k]);
end;
l:=creal(1,n);
sortfuzi(l);
afisl(l);
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

11. Polinoame de o variabila generate dinamic

program polinoame_generate_dinamic;
type poli=^term;

term=record

cf:real;
ex:integer;
next:poli

end;
var p,q,sum,mult:poli;

sf:char;
procedure readp (var p:poli);
var n:0..maxint;

i:integer;
crt:poli;

begin
write('nr. termeni:');
readln(n);
if n=0 then p:=nil

else begin
writeln('introd. coef+exp in ordine descresc:');
new(p);
crt:=p;
for i:=1 to n do begin

with crt^ do read(cf,ex);

if i<n then begin
new(crt^.next);
crt:=crt^.next

end
end;
crt^.next:=nil

end;
end;
procedure adaug(cf:real;ex:integer;var p:poli; var
n:integer);
begin

if n<>1 then p:=p^.next;
n:=n+1;
p^.cf:=cf;
p^.ex:=ex;
new(p^.next)

end;
procedure writep(p:poli);
var crt:poli;
begin

crt:=p;
while crt<>nil do begin

with crt^ do begin
if cf<0 then write('-')
else if cf>0 then write('+');
if (abs(cf)<>1) or (ex=0) then write(abs(cf):2:0);
if ex>0 then write('x');
if ex>1 then write('^',ex:1)

end;

crt:=crt^.next
end;
writeln

end;
procedure sumap(p,q:poli; var sum:poli);
var crt:poli;

n:integer;

begin
new(sum);
crt:=sum;
n:=1;
while (p<>nil)and(q<>nil) do

if p^.ex < q^.ex then begin
adaug(q^.cf,q^.ex,crt,n);
q:=q^.next

end

else if p^.ex > q^.ex then begin
adaug(p^.cf,p^.ex,crt,n);
p:=p^.next

end
else begin
if p^.cf+q^.cf<>0 then

adaug(p^.cf+q^.cf,p^.ex,crt,n);
p:=p^.next;
q:=q^.next

end;

while p<>nil do begin
adaug(p^.cf,p^.ex, crt,n);
p:=p^.next

end;

while q<>nil do begin
adaug(q^.cf,q^.ex, crt,n);
q:=q^.next

end;

crt^.next:=nil

end;
procedure prodp(p,q:poli; var mult:poli);
var crt,crtp,crtq:poli;

exc,rex,n:integer;

cfc:real;

begin
if (p=nil) or (q=nil) then mult:=nil
else begin

new(mult);
crt:=mult;
n:=1;
exc:=p^.ex+q^.ex;
while exc>=0 do begin

cfc:=0;
crtp:=p;
repeat

rex:=exc-crtp^.ex;

if rex>0 then begin
crtq:=q;
while

(crtq^.ex>rex)and(crtq^.next<>nil) do
crtq:=crtq^.next;
if crtq^.ex=rex then

cfc:=cfc+crtp^.cf*crtq^.cf;
end;
crtp:=crtp^.next;

until crtp=nil;
if cfc<>0 then
adaug(cfc,exc,crt,n);

exc:=exc-1
end;
crt^.next:=nil

end;

end;

begin
sf := 'D';

repeat
readp(p);
readp(q);
write('p(x)=');
writep(p);
write('q(x)=');

writep(q);
sumap(p,q,sum);
write('p(x)+q(x)');
writep(sum);
prodp(p,q,mult);
write('p(x)*q(x)=');
writep(mult);
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

1 Afisare vector in ordine inversa

program vector_inversat;
const nmax=100;
type vector=array[1..nmax] of integer;
var v:vector;

n,i:integer;

sf:char;
begin
sf := 'D';

repeat
repeat

write('Numar elemente [1..100]:');

readln(n)
until n in [1..100];
writeln('Dati cele ',n,' elemente');
for i:=1 to n do begin

write('v[',i,')=');

readln(v[i])
end;
writeln('Elementele in ordine inversa:');
for i:=n downto 1 do begin

write(v[i]:3);

if (n-i+1) mod 10=0 then writeln
end;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

13. Cautare secventiala in vector neordonat

program cautare_secventiala;
const nmax=100;

type     arr=array[1..nmax] of integer;

var list:arr;
n,i:1..nmax;
ok:boolean;
elem:integer;

sf:char;

begin
sf := 'D';

repeat
repeat

write('Dati Numarul elementelor:');

readln(n)
until n in [1..nmax];
for i:=1 to n do begin

write('list[',i,']=');

readln(list[i])
end;
write('Elementul cautat=');
readln(elem);
i:=1;
ok:=false;
while not ok and (i<n) do begin

i:=i+1;

if list[i]=elem then ok:=true
end;
if ok then writeln ('Elem. ',elem,' gasit pe pozitia ',i)
else writeln ('Elem. ',elem,' negasit');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

14. Cautare binara in vector ordonat

program cautare_binara;
const nmax=100;
type arr=array[1..nmax] of integer;
var list:arr;

n,i,linf,lsup,med:1..nmax;
ok:boolean;
elem:integer;

sf:char;
begin
sf := 'D';

repeat
repeat

write('Dati Numarul elementelor:');

readln(n)
until n in [1..nmax];
for i:=1 to n do begin

write('list[',i,']=');

readln(list[i])
end;
write('Elementul cautat=');
readln(elem);
ok:=false;
linf:=1;
lsup:=n;
repeat

med:=(linf+lsup) div 2;
if elem=list[med] then ok:=true
else if elem < list[med] then lsup:=med-1

else linf:=med+1
until ok or (linf>lsup);
if ok then writeln ('Elem. ',elem,' gasit pe pozitia ',med)
else writeln ('Elem. ',elem,' negasit');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

15. Proceduri pe siruri de caractere

program proceduri_pe_siruri;
const size=20;
type line=string[size];
var s1,s2:line;

p,c:integer;
option:char;
buflen:word;

sf:char;
begin
sf := 'D';

repeat
s1:='';
repeat

writeln('String=',s1);
write('Option[Read, Delete, Insert,
Quit]:');

readln(option);
case upcase(option) of 'R':

begin
sf := 'D'; repeat
write('New string: ');
buflen:=size;
readln(s1);

end;
'D':

begin
write('Delete starting from: ');
readln (p);
write('Number of deleted characters: ');
readln(c);
delete(s1,p,c)

end;

'I':

begin
write('Insert substr: ');
buflen:=size;
read(s2);
write('Starting from: ');
readln(p);
insert (s2,s1,p)

end;
'Q':

begin
write ('Are you sure [Y/N]:');
readln(option);
if upcase(option)='Y' then option:='Q'
end
else writeln ('Incorrect')

end;
until option='Q';
writeln('Gata!');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

16. Conversie ;ir de caractere ]n numeric

program str_to_val;
const size=10;
type line=string[size];
var s:line;
n,code:integer;
x:real;

sf:char;
begin
sf := 'D';

repeat
repeat
write ('Numeric constant: ');
readln (s);
if length(s)>0 then

begin

val (s,n,code);
if code=0 then writeln('Is a
integer constant')

else

begin
val (s,x,code);
if code=0 then writeln('Is a real constant')

else

begin
writeln ('Error!');
writeln('Codul de eroare:19',code)
end
end

end
until s='';
writeln('Gata! Press any key');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

17. Ordonare vector prin selectie

program sortare_prin_selectie;
const nmax=100;
var c:array[1..nmax]of integer;

k,n,min,i,j,aux:integer;

sf:char;
begin
sf := 'D';

repeat
write('Numarul componentelor:'); readln(n);

for i:=1 to n do begin

write ('c[',i,']='); readln (c[i])
end;
for i:=1 to n do begin

k:=i;
min:=c[i];
for j:=i to n do

if c[j]<min then begin
min:=c[j];
k:=j

end;
aux:=c[i];
c[i]:=c[k];
c[k]:=aux

end;
write('vectorul ordonat:');
for j:=1 to n do write(c[j],' ');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

18. Ordonare vector prin enumerare

program sortare_prin_enumerare_da pozitia_in sirul sortat;
const nmax=100;
var c,rang:array[1..nmax]of integer;
n,i,j:integer;

sf:char;
begin
sf := 'D';

repeat
write('Numarul componentelor:'); readln(n);
for i:=1 to n do begin

rang[i]:=1;
write ('c[',i,']=');
readln (c[i])

end;
for i:=1 to n do
for j:=1 to i-1 do
if c[j]<c[i] then rang[i]:=rang[i]+1
else rang[j]:=rang[j]+1;
write('vectorul ordonat:');

for j:=1 to n do write(rang[j],' ');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

19. Ordonare vector prin inserare

program sortare_prin_inserare;
const nmax=100;
var c:array[0..nmax]of integer;

k,n,cheie,i:integer;

sf:char;
begin
sf := 'D';

repeat
write('Numarul componentelor:'); readln(n);
for i:=1 to n do begin

write ('c[',i,']='); readln (c[i])
end;
c[0]:=-maxint;
for i:=1 to n-1 do begin

cheie:=c[i+1];
k:=i;
while cheie<c[k] do begin

c[k+1]:=c[k];

k:=k-1
end;
c[k+1]:=cheie;

end;
write('vectorul ordonat:');
for i:=1 to n do write(c[i],' ');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

20. Ordonare vector prin transpozitii

program sortare_prin_transpozitii;
const nmax=100;
var c:array[1..nmax]of integer;

k,n,max,i,aux:integer;
schimb:boolean;

sf:char;

begin
sf := 'D';

repeat

write('Numarul componentelor:'); readln(n);
for i:=1 to n do begin

write ('c[',i,']='); readln (c[i])
end;
k:=n;
schimb:=true;
while schimb do begin

max:=k;
schimb:=false;
for i:=1 to max-1 do

if c[i]>c[i+1] then begin
aux:=c[i];
c[i]:=c[i+1];
c[i+1]:=aux;
k:=i;
schimb:=true

end;
for i:=1 to n do write(c[i],' ');
writeln

end;
write('vectorul ordonat:');
for i:=1 to n do write(c[i],' ');
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

21. Generarea triunghiului lui Pascal

program Triunghiul_lui_Pascal;
const nmax=100;
var i,j,n:integer;

triunghi:array[1..nmax,1..nmax] of integer;

sf:char;
begin

sf := 'D';

repeat
write('n='); readln(n);
triunghi[1,1]:=1;
for j:=2 to n do triunghi[i,j]:=0;
for i:=1 to n do begin

triunghi[i,1]:=1;
write(triunghi[i,1],'');
for j:=2 to i do begin

triunghi[i,j]:=
triunghi[i-1,j]+triunghi[i-1,j-1];

write(triunghi[i,j]:4)
end;
for j:=i+1 to n do triunghi[i,j]:=0;
writeln

end;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

2 Generare stiva de intregi

program stiva_de_intregi;
const nmax=100;
var data,n:integer;

inalt:0..nmax;
stack:array[1..nmax] of integer;

sf:char;
begin
sf := 'D';

repeat
write('n='); readln(n);
inalt:=0;
writeln('introduceti ',n,' intregi');
while inalt <n do begin

read(data);
inalt:=succ(inalt);
stack[inalt]:=data;

end;

while inalt >0 do begin
data:=stack[inalt];
inalt:=pred(inalt);
write(data,' ')

end;
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

23. Generare coada de asteptare

program fir_de_asteptare_de_intregi;
const nmax=100;

var data,n:integer;
lung:0..nmax;
coada:array[1..nmax] of integer;

sf:char;

begin
sf := 'D';

repeat
write('n='); readln(n);
lung:=0;
writeln('introduceti ',n,' intregi');
while lung <n do begin

read(data);
lung:=succ(lung);
coada[lung]:=data;

end;
lung:=1;
while lung<=n do begin

data:=coada[lung];
lung:=succ(lung);
write(data,' ')

end;
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

24. Traversare arbore binar

program traversare_graf;
type ref=^nod;

nod=record
info:'a'..'z';
st,dr:ref

end ;
var rad:ref;

c:char;

sf:char;
procedure preordine (pointer:ref);
begin

if pointer<>nil then begin
write (pointer^.info);
preordine (pointer^.st);

preordine(pointer^.dr)

end
end;

procedure inordine (pointer:ref);
begin

if pointer<>nil then begin
inordine (pointer^.st);
write (pointer^.info);
inordine(pointer^.dr)

end
end;
procedure postordine (pointer:ref);
begin

if pointer<>nil then begin
postordine (pointer^.st);
postordine(pointer^.dr);
write (pointer^.info);

end
end;
procedure creare (var pointer:ref);
begin

read(c);

if c<>'.' then begin
new(pointer);
pointer^.info:=c;
creare (pointer^.st);
creare (pointer^.dr)

end else pointer:=nil
end;
begin

sf := 'D'; repeat
write('Arborele dat :':25);
creare (rad);
writeln;
write('Preordine :':25);
preordine (rad);
writeln;
write('Inordine :':25);
inordine (rad);
writeln;
write('Postordine :':25);
postordine (rad);
writeln;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

25. Modelarea matricilor rare

program matrice_rara;
type ind=0..25;

sir=array[ind]of integer;
mat=array[ind,ind]of integer;
var n,m,p:integer;

v:byte;

sf:char;
procedure varianta1;
var i,j,k:ind;

a,b:sir;
c:mat;

begin
writeln('Dati vectorii:'
write('Lungimea vectorilor:');
readln(m);
for i:=1 to m do begin

write('v[',i,']=');

readln(a[i]);
end;
for i:=1 to m do begin

write('o[',i,']=');

readln(b[i]);
end;
for i:= 1 to n do

for j:= 1 to n do
c[i,j]:=0;
for k:= 1 to m do

begin
j:=(b[k] div n)+1;
i:=b[k] mod n;
if i=0 then begin

i:=n;

j:=j-1;
end;
c[i,j]:=a[k];

end;

for i:= 1 to n do begin
for j:=1 to n do write(c[i,j]:4);
writeln

end
end;
procedure varianta2;
var i,j,k:ind;

a,b:sir;
c:mat;

begin
writeln('Dati matricea:');
k:=0;
for i:= 1 to n do

for j:=1 to n do begin
write('a[',i,',',j,']=');
readln(c[i,j]);
if c[i,j]<>0 then begin

k:=k+1;
a[k]:=c[i,j];
b[k]:=(i-1)*n+j;

end;
end;

for i:=1 to k do begin
write('v[',i,']=',a[i],' ');
writeln('o[',i,']=',b[i]);

end;
end;
procedure varianta3;
var i,j,k:ind;

a,b,c,d:sir;
e:mat;

begin
write('Dati prima matrice:');
write('Dati lungimea vectorilor:');
readln(m);
for i:=1 to m do begin

write('v[',i,']='); readln(a[i]);

write('o[',i,']='); readln(b[i]);
end;
write('Dati a doua matrice:');
write('Dati lungimea vectorilor:');
readln(p);
for i:=1 to p do begin

write('v[',i,']='); readln(c[i]);
write('o[',i,']='); readln(d[i]);

end;
k:=m;
for j:= 1 to p do

begin
k:=i;
while(d[j]<>b[i]) and(i<=m) do

i:= i+1;

if i>m then begin
k:=k+1;
a[k]:=c[j];
b[k]:=d[j];

end
else a[i]:=a[i]+c[j];

end;
m:=k;
for i:= 1 to n do

for j:= 1 to n do
e[i,j]:=0;

for k:=1 to m do begin
j:=(b[k] div n)+1;
i:=b[k] mod n;
if i=0 then begin

i:=n;
j:=j-1;

end;
e[i,j]:=a[k];
end;
writeln('Matrice suma este:');
for i:= 1 to n do begin

for j:= 1 to n do writeln(e[i,j]:4);
writeln;

end;
end;
begin

sf := 'D';

repeat
writeln('1-Se dau v si o,sa se calculeze a');
writeln('2-Se da a,sa se calculeze v si o ');

writeln('3-Se dau doua matrici sa se calculeze suma ');
write('Alegeti varianta 1,2,3:');
readln(v);
write('Dati dimensiunea matricei:');

readln(n);
case v of

varianta1;

varianta2;

3: varianta3;
end;
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.

26. Polinoame de m variabile generate static

program polinoame_de_mai_multe_variabile;
type adev=0..1;

ind=0..50;
sir=array[ind] of real;
mat=array[ind,ind]of byte;

var m,n,p,q:ind;
a,c,e:sir;
b,d,f:mat;

sf:char;

procedure citire_p(r:ind;var x:sir;var y:mat);
var i,j:ind;
begin

writeln('Dati coeficienti monoamelor:');

for i:=1 to r do begin
write('a(',i,')=');
readln(x[i]);

end;
writeln('Dati exponenti necunoscute:');
for i:=1 to r do

for j:=1 to m do begin
write('b(',i,',',j,')=');
readln(y[i,j]);

end;
end;
procedure suma_p(x,z:sir;y,t:mat;var r:ind;var u:sir;var v:mat);
var i,j:ind;
begin

for i:=1 to n do begin
u[i]:=x[i];
for j:=1 to m do v[i,j]:=y[i,j];

end;

for i:=1 to p do begin
u[n+1]:=z[i];
for j:=1 to m do v[n+1,j]:=t[i,j];

end;

r:=n+p;
end;
procedure produs_p(x,z:sir;y,t:mat;var r:ind;var u:sir;var v:mat);
var i,j,k:ind;
begin

r:=0;
for i:=1 to n do

for j:=1 to p do begin
r:=r+1;
u[r]:=x[i]*z[j];
for k:=1 to m do

v[r,k]:=y[i,k]+t[j,k];

end;
end;
procedure reducere_p(r:ind;var x:sir;var y:mat);

var i,j,k:ind;
v_adev:adev;
begin

for i:=1 to r-1 do begin
j:=i+1;
v_adev:=0;
while (v_adev=0) and (j<=r) do begin

k:=1;
v_adev:=1;
while (v_adev=1) and (k<=m) do

if y[i,k]<>y[j,k] then v_adev:=0
else k:=k+1;

j:=j+1;
end;
if v_adev=1 then begin

x[j-1]:=x[j-1]+x[i];
x[i]:=0;
end;

end;
end;
procedure micsorare_p(var r:ind;var x:sir;var y:mat);
var i,j,k:ind;
begin

i:=1;
while i<=n do begin
if x[i]=0 then begin

for j:=i+1 to r do begin
x[j-1]:=x[j];
for k:=1 to m do

y[j-1,k]:=y[j,k];
end;
r:=r-1;
i:=i-1;

end;
i:=i+1;

end;
end;
procedure afisare_p(r:ind;x:sir;y:mat);
var i,j:ind;
begin

write('P(a');
for i:=1 to m-1 do write(',',chr(ord('a')+i));
write(')=');
if x[1]<>0 then begin

write (x[1]:3:1);
for j:=1 to m do

if y[1,j]<>0 then begin
write('*',chr(ord('a')+j-1));
write('^',y[1,j]);

end;
end;
for i:=2 to r do

if x[i]<>0 then begin
if x[i]>0 then write('+')

else write('-');
write(abs(x[i]):3:1);
for j:=1 to m do

if y[i,j]<>0 then begin
write('*',chr(ord('a')+j-1));
write('^',y[i,j]);

end;

end;

writeln;
end;
begin

sf := 'D';

repeat
writeln('Dati primul polinom:');
write('Dati Numarul de monoame:');
readln(n);
write('Dati Numarul de necunoscute:');
readln(m);
citire_p(n,a,b);
writeln('Primul polinom este:');
afisare_p(n,a,b);
writeln('Dati al doilea polinom:');
write('Dati Numarul de monoame:');
readln(p);
citire_p(p,c,d);
writeln('Al doilea polinom este:');
afisare_p(p,c,d);
suma_p(a,c,b,d,q,e,f);
reducere_p(q,e,f);
micsorare_p(q,e,f);
writeln('Polinomul suma este:');
afisare_p(q,e,f);
produs_p(a,c,b,d,q,e,f);
reducere_p(q,e,f);
micsorare_p(q,e,f);
writeln('Polinomul produs este:');
afisare_p(q,e,f);
writeln(' Continuati (D / N) ? ');

read(sf);

until sf = 'N';

end.