{ BINARA.PAS - 1999
Cautare binara
Se da un sir de numere de lungime n si un numar x.
Sa se determine pe ce pozitie se afla numarul x. }
uses crt;
var n,i:integer;
a:array[1..20] of real;
r,x:integer;
procedure caut(p,u:integer);
begin
r:=(p+u) div 2;
if a[r]<>n then if (p<=u) then if a[r]<n then caut(p,u-1)
else caut(p+1,u)
else writeln('Valoarea nu exista!')
else writeln('Valoarea este pe pozitia ',r);
end;
begin
clrscr;
write('Elementul cautat n = ');readln(n);
write('Dati numarul de elemente = ');readln(x);
for i:=1 to x do begin
write('Elementul ',i,' = ');readln(a[i]);
end;
caut(1,x); { capetele 1 si ultimul (x) }
readkey;
end.
{3N_SIR.PAS - 13.01.1999
Se citesc 3 numere naturale, n,p,k si un sir de n numere naturale.
Sa se scrie toate nr din sir care impartite la p dau restul k si numarul lor }
uses crt;
var i,x,n,p,k,nr:integer;
begin
clrscr;
write('n=');readln(n);
write('p=');readln(p);
write('k=');readln(k);
for i:=1 to n do
begin
write('Numarul ',i,'=');readln(x);
if x mod p = k then begin
writeln('Este bun: ',x);
inc(nr);
end;
end;
writeln('Numarul de numere bune = ',nr);
readkey;
end.
{BAZA2.PAS - 13.01.1999}
uses crt;
var baza,blap,i,nr,s,n,poz:integer;
begin
clrscr;
s:=0;
poz:=0;
write('n=');readln(n);
write('baza=');readln(baza);
repeat
nr:=n mod 10; { nr = ultima cifra }
n:=n div 10; { tai ultima cifra din numar }
for i:=1 to poz do blap:=baza*baza;
if poz=0 then blap:=1;
if poz=1 then blap:=baza;
s:=s+(nr*blap);
poz:=poz+1;
until n=0;
writeln(s);
end.
{NRCIFRE.PAS - 13.01.99}
{ Sa se scrie un program care sa afiseze nr. de cifre din care este facut un
nr nat dat si suma lor }
uses crt;
var nr:integer;
i,s:integer;
begin
clrscr;
write('nr=');readln(nr);
repeat
inc(i);
s:=s+nr mod 10;
nr:=nr div 10;
until nr=0;
writeln('Numarul de cifre = ',i);
writeln('Suma cifrelor = ',s);
end.
{SUMAPROD.PAS - 13.01.99}
{ Calc. suma cifrelor pare ale unui nr. si prod cifrelor impare ale unui nr }
uses crt;
var nr:integer;
r,i,s,p:integer;
begin
clrscr;
write('nr=');readln(nr);
p:=1;
s:=0;
repeat
r:=nr mod 10;
if odd(r) then p:=p*r else s:=s+r;
nr:=nr div 10;
until nr=0;
writeln('Suma cifrelor pare = ',s);
writeln('Produsul cifrelor impare = ',p);
end.
{CMMDC2.PAS - 15.01.1999}
uses crt;
var i,x,y,n,cd:integer;
function cmmdc(x,y:integer):integer;
var r:integer;
mx,my:integer;
begin
if x>y then begin mx:=x;my:=y;end else begin mx:=y;my:=x;end;
repeat
r:=mx mod my;
mx:=my;
my:=r;
until r=0;
end;
begin
clrscr;
write('Nr. de numere: ');readln(n);
write('Primul nr = ');readln(x);
write('Al 2-lea nr = ');readln(y);
for i:=1 to n do
begin
cd:=cmmdc(x,y);
x:=cd;
write('Al ',i+2,'-lea nr = ');readln(y);
end;
writeln('CMMDC = ',cmmdc(x,y));
readkey;
end.
{SUMAMICA.PAS - 15.01.99}
uses crt;
var i,n,s,sx,sy,x,y:integer;
begin
clrscr;
write('Nr. de numere = ');readln(n);
write('Dati primul numar = ');readln(x);
write('Dati al 2-lea numar = ');readln(y);
s:=x+y;sx:=x;sy:=y;
for i:=1 to n-2 do
begin
x:=y;
write('Dati al ',i+2,'-lea numar = ');readln(y);
if x+y>s then begin s:=x+y;sx:=x;sy:=y;end;
end;
writeln('Cea mai mare suma este ',s,' si sa obtinut din ',sx,' + ',sy);
readkey;
end.
{ ECU.PAS - 19.01.99 }
{ se dau a,b,c coef. unei ecuatii de grad 2 .
Se citeste n natural. Sa se calcu. x1 ^n + x2^n }
uses crt,math;
var a,b,c:integer;
n:integer;
d:integer;
x1,x2:real;
begin
clrscr;
write('a,b,c=');readln(a,b,c);
write('n=');readln(n);
d:=b*b-4*a*c;
if d<0 then writeln('Ecuatia nu are coeficienti reali')
else
begin
x1:=(-b+sqrt(d))/2*a;
x2:=(-b-sqrt(d))/2*a;
writeln('X1^n + X2^n = ',nlap(x1,n)+nlap(x2,n):10:3);
end;
readkey;
end.
{LUCRARE.PAS - 19.01.99}
uses crt;
var a,b,x:real;
begin
CLRSCR;textcolor(lightgreen);write('BAGA PE a=');
readln(a);
textcolor(lightcyan);
write('SI PE b=');
readln (b);
TEXTCOLOR(LIGHTRED);
if (a=0) and (b=0) then
writeln('INECUATIA ARE CA SOLUTIE TOATE NUMERELE REALE!!!')
else if (a=0) and (b<>0) then writeln('INECUATIA NU ARE SOLUTII!!!')
else if a>0 then
writeln('SOLUTIA APARTINE INTERVALULUI DE LA -INFINIT LA ',b/a:5:2)
else if a<0 then
writeln('SOLUTIA APARTINE INTERVALULUI DE LA ',b/a:5:2,'LA +INFINIT');
readln;
END.
{MATH.PAS - 19.01.99}
unit math;
interface
function nlap(n:real;p:integer):real;
implementation
function nlap(n:real;p:integer):real;
var i:integer;
nlp:real;
begin
nlp:=1;
if p=0 then nlap:=1
else
if p=1 then nlap:=n
else for i:=1 to p do nlp:=nlp*n;
nlap:=nlp;
end;
begin
end.
{PROG.PAS - 26.01.99}
program meniuri;
uses crt,graph;
var gd,gm:integer;
c:char;
y:byte;
q:integer;
procedure BaraAlbastra1;
begin
setfillstyle(1,9);
bar(200,100,400,200);
setcolor(15);
rectangle(200,100,400,200);
settextstyle(5,0,6);
outtextxy(220,100,'new');
end;
procedure BaraAlbastra2;
begin
setfillstyle(1,9);
bar(200,200,400,300);
setcolor(15);
rectangle(200,200,400,300);
settextstyle(5,0,6);
outtextxy(220,200,'continue');
end;
procedure BaraAlbastra3;
begin
setfillstyle(1,9);
bar(200,300,400,400);
setcolor(15);
rectangle(200,300,400,400);
settextstyle(5,0,6);
outtextxy(220,300,'quit');
end;
procedure BaraAlba1;
begin
setfillstyle(1,15);
bar(200,100,400,200);
setcolor(9);
rectangle(200,100,400,200);
settextstyle(5,0,6);
outtextxy(220,100,'new');
end;
procedure BaraAlba2;
begin
setfillstyle(1,15);
bar(200,200,400,300);
setcolor(9);
rectangle(200,200,400,300);
settextstyle(5,0,6);
outtextxy(220,200,'continue');
end;
procedure BaraAlba3;
begin
setfillstyle(1,15);
bar(200,300,400,400);
setcolor(9);
rectangle(200,300,400,400);
settextstyle(5,0,6);
outtextxy(220,300,'quit');
end;
procedure AfisezBara(y:integer);
begin
case y of
1:begin BaraAlbastra1;BaraAlba2;BaraAlba3;end;
2:begin BaraAlba1;BaraAlbastra2;BaraAlba3;end;
3:begin BaraAlba1;BaraAlba2;BaraAlbastra3;end;end;
end;
function meniu:integer;
begin
cleardevice;
BaraAlba1;
BaraAlba2;
BaraAlba3;
y:=1;AfisezBara(y);
repeat
c:=readkey;
If c=#0 then c:=readkey;
if c=#72 then begin y:=y-1;if y=0 then y:=3;AfisezBara(y);end;
if c=#80 then begin y:=y+1;if y=4 then y:=1;AfisezBara(y);end;
until c=#13;
meniu:=y;
end;
begin
gd:= Detect;
InitGraph(gd,gm,'C:\bP\BGI');
q:=meniu;
closegraph;
case q of
1:write('S-a ales new');
2:write('S-a ales continue');
3:write('S-a ales quit');end;
readln;
end.
{STR1.PAS - 9.02.99}
{ Se citeste un string a de 10 caractere si un caracter c. Scrieti un program
care spune de cate ori apare c in string si sa elimine de peste tot c }
uses crt;
var s:string[10];
c:char;
i,x:integer;
begin
clrscr;
write('String=');readln(s);
write('Caracter=');readln(c);
repeat
x:=pos(c,s);
if x>0 then begin delete(s,x,1);i:=i+1;end;
until x=0;
writeln(s);
writeln('Apare de ',i,' ori.');
end.
{STR2.PAS - 9.02.99}
uses crt;
var s:string[10];
x,z:integer;
c:char;
begin
clrscr;
write('s=');readln(s);
write('c=');readln(c);
z:=0;
repeat
x:=pos(c,s);
if x>0 then begin delete (s,x,1);z:=z+1;end;
until x=0;
writeln(s);
writeln(z);
end.
{STR3.PAS - 9.02.99}
uses crt;
var c,cc:char;
s,ss:string;
x,i:integer;
begin
clrscr;
readln(s);ss:=s;
readln(c);
readln(cc);
repeat
i:=i+1;
if s[i]=c then begin insert(cc,s,i+1);i:=i+1;x:=x+1;end;
until i>length(ss)+x;
writeln(s);
end.
{INVERS.PAS - 11.02.99}
uses crt;
var s:string;
poz1,poz2,sfc,x,i,j:integer;
a,b:byte;
aux,c1,c2:string[30];
begin
clrscr;
write('Text = ');readln(s);
write('Cuv 1 si 2 = ');readln(a,b);
for i:=1 to length(s) do
begin
if s[i]=' ' then inc(x);
if x=a-1 then begin
for j:=i to length(s) do if s[j]=' ' then begin sfc:=j-i;poz1:=i;break;end;
c1:=copy(s,i,sfc);
writeln('C1=',c1);
delete(s,i,sfc);
break;
end;
end;
x:=0;
for i:=1 to length(s) do
begin
if s[i]=' ' then inc(x);
if x=b-1 then begin
for j:=i to length(s) do if s[j]=' ' then begin sfc:=j-i;break;end;
c2:=copy(s,i,sfc);
writeln('C2=',c2);
delete(s,i,sfc);
insert(c1,s,i);
insert(c2,s,poz1);
break;
end;
end;
writeln;
writeln(S);
end.
{NRCAR.PAS - 11.02.99}
uses crt;
var s:string;
c:char;
x,i:integer;
begin
clrscr;
write('Text = ');readln(s);writeln;
for c:='A' to 'z' do
begin
x:=0;
for i:=1 to length(s) do if s[i]=c then x:=x+1;
if x>0 then writeln('Caracterul ',c,' apare de ',x,' ori.');
end;
readkey;
end.
{NRCUV.PAS - 11.02.99}
uses crt;
var s:string;
i,c:integer;
begin
write('Text=');readln(s);
for i:=1 to length(s) do if (s[i]=' ')or(s[i]=',')or(s[i]='.') then c:=c+1;
write('Nr. de cuvinte = ',c);
readkey;
end.
{NRSPATII.PAS - 11.02.99}
uses crt;
var ss,s:string;
x:integer; { nr de eliminari }
i:integer; { ciclare }
z:integer; { pos }
begin
clrscr;
write('Text=');readln(s);ss:=s;
repeat
inc(i);
if (s[i]=' ')and(s[i+1]=' ') then begin delete(s,i,1);inc(x);dec(i);end;
until i=length(ss)-x;
writeln(s);
readkey;
end.
{PALINDRO.PAS - 11.02.99}
uses crt;
var s:string;
i:integer;
nue:boolean;
begin
clrscr;
write('Text=');readln(s);
for i:=1 to length(s) div 2 do
begin
if s[i]<>s[length(s)-i+1] then nue:=true;
end;
write(' Este frate ? ',not nue);
readkey;
end.
{STR5.PAS - 12.02.99}
uses crt;
var c,s:string;
suma,x,nr,z,e:integer;
begin
clrscr;
write('Sir=');readln(s);
repeat
x:=pos('*',s);
if x>0 then begin
c:=copy(s,1,x-1);
delete(s,1,x);
val(c,z,e);
suma:=suma+z;nr:=nr+1;
end
else begin
c:=copy(s,1,length(s));
delete(s,1,length(s));
val(c,z,e);
suma:=suma+z;nr:=nr+1;
end;
until s='';
writeln('Suma=',suma);
writeln('Numere=',nr); readkey;
end.
{REC1.PAS - 13.02.99}
uses crt;
var elev:record
nume:array[1..30] of string[30];
varsta:array[1..30] of byte;
clasa:array[1..30] of string[3];
end;
begin
clrscr;
write('Dati numele=');readln(elev.nume[1]);
write('Varsta=');readln(elev.varsta[1]);
write('Clasa=');readln(elev.clasa[1]);
clrscr;
with elev do begin
writeln('Numele este ',nume[1]);
writeln('Varsta este ',varsta[1]);
writeln('Clasa e si mai si: ',clasa[1]);
end;
end.
{REC2.PAS - 13.02.99}
uses crt;
var elev:record
nr:array[1..30] of byte;
nume:array[1..30] of string[30];
varsta:array[1..30] of byte;
end;
a,b:array[1..30,1..30] of 0..1;
j,i,ii:byte;
aux:string[30];
begin
clrscr;
for i:=1 to 30 do begin
elev.nr[i]:=i;
write('Nume elev ',i,' = ');readln(elev.nume[i]);
if elev.nume[i]='0' then begin elev.nume[i]:='';break;end;
write('Varsta ',i,' = ');readln(elev.varsta[i]);
end;
ii:=i-1;
clrscr;
for i:=1 to ii do
for j:=1 to ii do
begin
gotoxy(1,i);write(elev.nume[i]);
gotoxy(j*3+20,i);
readln(a[i,j]);
end;
for i:=1 to ii-1 do
for j:=i to ii do
begin
if elev.nume[i]>elev.nume[j] then begin
aux:=elev.nume[i];
elev.nume[i]:=elev.nume[j];
elev.nume[j]:=aux;
end;
end;
with elev do
for i:=1 to ii do
for j:=1 to ii do
begin
b[i,nr[i]]:=a[nr[i],j];
end;
for i:=1 to ii do
for j:=1 to ii do
begin
gotoxy(1,i+10);write(elev.nume[i]);
gotoxy(j*3+20,i+10);
write(b[i,j]);
end;
end.
{VECTOR.PAS - 16.02.99}
uses crt;
var a:array[1..100] of real;
i,j,k,n:integer;
begin
clrscr;
write('Dati nr de componente: ');readln(n);
for i:=1 to n do
begin
write('A[',i,']=');readln(a[i]);
end;
writeln('-----------------');
for i:=1 to n do
begin
k:=0;
for j:=1 to n do
if a[i]=a[j] then k:=k+1;
if k=1 then writeln(a[i]:5:3);
end;
readln;
end.
{ARRAY.PAS - 18.02.1999
Reuniunea a doi vectori
Se citesc doi vectori. Sa se afiseze reuniunea celor 2 vectori. }
uses crt;
var a,b,c:array[1..50] of word;
f,i,j,m,n:integer;
k:boolean;
begin
clrscr;
write('Dati nr de elem din multimea A: ');readln(n);
write('Dati nr de elem din multimea B: ');readln(m);
for i:=1 to n do begin write('A[',i,']=');readln(a[i]);end;
for i:=1 to m do begin write('B[',i,']=');readln(b[i]);end;
for i:=1 to n do c[i]:=a[i]; { copiaza multimea A in C }
f:=n;
for i:=1 to m do
begin
k:=false;
for j:=1 to n do if a[j]=b[i] then begin
k:=true;
break;
end;
if not k then begin
inc(f);
c[f]:=b[i];
end;
end;
write('C={');
for i:=1 to f-1 do write(c[i],',');
write(c[f],'}');
readkey;
end.
{VASILE.PAS - 21.02.99}
program cuvinte;
uses crt;
var a:string;
s,i,c,k,b:integer;
begin
clrscr;
writeln('dati textul:');
readln(a);
c:=0;
k:=0;
b:=0;
s:=0;
for i:=1 to length(a) do
case a[i] of
'e','u','i','o','a':k:=k+1;
'w','r','t','y','p','s','d','f','g','h','j','k','l','z','x','c','v','b','n','m':c:=c+1;
' ':s:=s+1;
else b:=b+1;
end;
write('Sunt ',k,' vocale,',c,' consoane ,',b,' caractere speciale si ',s,' spatii');
readln
end.
{VASILE2.PAS - 21.02.99}
program vector;
uses crt;
var a:array[1..56] of integer ;
i,n,c:integer;
begin
clrscr;
write('Dati nr. de componente:');
readln(n);
write('Dati nr. cu care vrei sa fie divizibile componentele:');
readln(c);
writeln('Dati componentele vectorului:');
for i:=1 to n do begin
write('a[',i,']=');
readln(a[i])
end;
for i:=1 to n do
if a[i] mod c=0 then writeln('Nr. ',a[i],' este divizibil cu ',c);
readln
end.
{VASILE3.PAS - 21.02.99}
program pauza;
uses crt;
var a,b,c:array[1..23] of integer;
i,n,m,r,t,j:integer;
k:boolean;
begin
clrscr;
write('Dati nr. de componente al primului vector:');readln(n);
write('Dati nr de camponente al celui de-al doilea vector:');readln(m);
writeln('Dati componentele primului vector:');
for i:=1 to n do begin write('a[',i,']=');readln(a[i]);end;
writeln ('Dati componentele celuilalt vector:');
for i:=1 to m do begin
write('b[',i,']=');
readln(a[i])
end;
t:=1; r:=1;
for i:=1 to n+m do
for j:=1 to n do
repeat
k:=true;
for i:=1 to n+m-1 do
if c[i]>c[i+1] then begin
t:=c[i];
c[i]:=c[i+1];
c[i+1]:=t;
k:=false;
end;
until k=true;
writeln('Componentele celor doi vectori aranjati in ordine crescatoare sunt:');
for i:=1 to n+m do
write(c[i],',');
readln
end.
{INTERSCH.PAS - 26.02.99}
uses crt;
var a:string[55];
b,c:string[10];
i,l1,l2:integer;
begin
clrscr;
write('Dati sirul: ');readln(a);
i:=1;
while (a[i]<>' ') do inc(i);
l1:=i+1;
inc(i);
while (a[i]<>' ') do inc(i);
l2:=i-1;
b:=copy(a,l1,l2-l1+1);
i:=length(a);
while (a[i]<>' ') do dec(i);
c:=copy(a,i+1,length(a)-i-1);
delete(a,i+1,length(a)-i-1);
insert(b,a,i+1);
delete(a,l1,l2-l1+1);
insert(c,a,l1);
writeln(a);
readln;
end.
{SORTBIN2.PAS - 26.02.99}
uses crt;
var a:array[1..10] of word;
k,n,i,l1,l2,lm,m:integer;
x:boolean;
begin
clrscr;
write('Marime vector = ');readln(n);
for i:=1 to n do begin write('A[',i,']=');readln(a[i]);end;
write('Val. cautata = ');readln(m);
l1:=1;
l2:=n;
x:=false;
while (l1<=l2) and not x do
begin
lm:=(l1+l2) div 2;
if m=a[lm] then x:=true
else if m<a[lm] then l2:=lm-1
else l1:=lm+1;
end;
if x then writeln(m,' se afla pe pozitia ',lm)
else writeln('Nu este.');
readln;
end.
{INVERSAR.PAS - 04.03.99}
{ Se citeste n natural. Scrie nr obtinut prin inversarea cifrelor sale }
uses crt;
var n,b:longint;
begin
clrscr;
readln(n);
repeat
b:=b*10+n mod 10;
n:=n div 10;
until n=0;
writeln('Nr inversat este ',b); readkey;
end.
{SORTBIN.PAS - 4.03.99}
uses crt;
var i,M,n,l1,l2,lm:integer;
a:array[1..10] of real;
b:boolean;
begin
clrscr;
write('Ce valoare caut? ');readln(m);
write('Marime vector: ');readln(n);
for i:=1 to n do begin write('A[',i,']=');readln(a[i]);end;
l1:=1;
l2:=n;
repeat
lm:=(l1+l2) div 2;
if m=a[lm] then begin writeln('Val. caut. e pe pozitia ',lm);halt;end
else if M<A[lm] then l2:=lm-1
else l1:=lm+1
until (l1>l2);
{if m=a[n] then writeln('Val. caut. e pe pozitia ',n)
else writeln('Nu e.');}
readkey;
end.
{MATRICE8.PAS - 5.03.99}
{SORTARE DESCRESCATOARE A ELEMENTELOR DE PE DIAGONALA PRINCIPALA}
uses crt;
var a:array[1..10,1..10] of integer;
t,i,j,n:integer;
k:boolean;
procedure afis;
var i,j:integer;
begin
clrscr;
for i:=1 to n do
for j:=1 to n do
begin
gotoxy(3*j+1,3*i+1);
write(a[i,j]);
end;
end;
begin
clrscr;
write('M=');readln(n);
for i:=1 to n do
for j:=1 to n do
begin
gotoxy(3*j+1,3*i+1);
read(a[i,j]);
end; { gata citire }
repeat
k:=false;
for i:=1 to n-1 do if a[i,i]<a[i+1,i+1] then BEGIN
K:=TRUE;
for j:=1 to n do begin
t:=a[i,j];
a[i,j]:=a[i+1,j];
a[i+1,j]:=t;
end;
for j:=1 to n do begin
t:=a[j,i];
a[j,i]:=a[j,i+1];
a[j,i+1]:=t;
end;
END;
until not k;
clrscr;
for i:=1 to n do
for j:=1 to n do
begin
gotoxy(3*j+1,3*i+1);
write(a[i,j]);
end;
readkey;
end.
{MATRICA.PAS - 9.03.99}
uses crt;
var b,n,i,j:integer;
a:array[1..10,1..10] of byte;
begin
clrscr;
write('N=');readln(n);
for i:=1 to n do
for j:=1 to n do
begin
gotoxy(3*j+1,3*i+1);
read(a[i,j]);
end;
writeln;
for b:=1 to n-1 do
begin
for j:=1 to n do write(a[b,j],',');
for i:=b+1 to n do write(a[i,n],',');
for j:=n-b to b do write(a[n,j],',');
for i:=n-b to b do write(a[i,b],',');
end;
readkey;
end.
{POLI.PAS - 10.03.99}
program unu;
uses crt;
var a:array[1..10] of real;
k,i,n:integer;dmax:real;
begin
clrscr;
write('Dati nr de componente:');readln(n);
for i:=1 to n do begin
write('a[',i,']=');readln(a[i]);end;
dmax:=abs(a[i]-a[2]);k:=1;
for i:=2 to n-1 do
if dmax < abs(a[i]-a[i+1]) then
begin
dmax:=abs(a[i]-a[i+1]);k:=i;
end;
write('Diferenta max este:',dmax:5:2,'si se obtine din el ',a[k]:5:2,'si',a[k+1]:5:2);
readln;
end.
{PRIETENI.PAS - 18.03.99}
uses crt;
type prieten=record
nr:byte;
nume:string[34];
virsta:1..90 ;
end;
var a:array[1..50] of prieten;
m:array [1..50, 1..50] of 0..1 ;
i,j,n :integer; k:boolean; t:prieten;
begin
clrscr; write ('dati n='); readln (n);
for i:= 1to n do
for j:=1 to n do begin
gotoxy(2*i+3,2*j+3);
readln (m[i,j]);
end;
for i:=1 to n do
with a[i] do begin
write ('Numele:'); readln(nume);
write ('Virsta:');readln (virsta); nr:=i;end;
for i:=1 to n-1 do { Chiorule! folosesti tot i pt. ciclare? }
for j:=i+1 to n do
if a[i].virsta>a[j].virsta then begin { facem intershimb }
t:=a[i];
a[i]:=a[j];
a[j]:=t;
end;
End.
{SPITAL.PAS - 19.03.99}
program varza_de_varza_spital_de_nebuni;
uses crt;
type pacient=record
nume:string[20];
varsta:byte;
diag:string[20];
case spitalizat:boolean of
TRUE:(sectie:integer;salon:integer);
FALSE:(str:string[20];nr:byte;ap:integer);
end;
var a:array[1..10] of pacient;
t:pacient;
ss:string[2];
n,i,j:integer;
begin
clrscr;
write('Nr. pacienti=');readln(n);
for i:=1 to n do
with a[i] do begin
write('Nume=');readln(nume);
write('Varsta=');readln(varsta);
write('Diagnostic=');readln(diag);
write('Este spitalizat ? (da/nu)');readln(ss);
if ss='da' then spitalizat:=true else spitalizat:=false;
case spitalizat of
true:begin write('Sectie=');readln(sectie);
write('Salon=');readln(salon);
end;
false:begin write('Strada=');readln(str);
write('Numar=');readln(nr);
write('Apartament=');readln(ap);
end;
end;
end;
for i:=1 to n-1 do
for j:=i+1 to n do
if a[i].nume>a[j].nume then begin
t:=a[i];
a[i]:=a[j];
a[j]:=t;
end;
clrscr;
for i:=1 to n do
with a[i] do begin
writeln(nume,' <-Nume--Varsta-> ',varsta,' --Diag-> ',diag,' ---In spital?--> ',spitalizat);
end; READLN;
for i:=1 to n-1 do
for j:=i+1 to n do
if a[i].varsta>a[j].varsta then begin
t:=a[i];
a[i]:=a[j];
a[j]:=t;
end;
for i:=1 to n do
with a[i] do begin
writeln(NUME);
case spitalizat of
true:begin writeln('sectie=',sectie);
writeln('salon=',salon);
end;
false:begin
writeln('strada=',str);
writeln('numar=',nr);
writeln ('apartament=',ap);
end;
end;
end;
end.
{TARI.PAS - 19.03.99}
uses crt;
type tara=record
nume:string[10];
nrcul:1..5;
n:set of 1..5;
end;
var a:array[1..20] of tara;
i,nr:1..20;
j:1..5;
nn:1..5;
begin
clrscr;
write('Nr. de tari=');readln(nr);
for i:=1 to nr do
with a[i] do begin
writeln('Tara ',i);
writeln('-----------');
write('Nume=');readln(nume);
write('Nrcul=');readln(nrcul);
n:=[];
for j:=1 to nrcul do begin
write('Culoarea ',j,'=');
readln(nn);
n:=n+[nn];
end;
end;
clrscr;
write('Spune-mi o culoare=');readln(nn);
writeln('Tarile ce au culoarea data:');writeln('-------------------------------');
for i:=1 to nr do if nn in a[i].n then writeln(a[i].nume);
readkey;
end.
{POLIN.PAS - 26.03.99}
{Se dau doua polinoame ae caror coef. sunt retinuti in 2 vectori.
Sa se calculeze coeficientii produsului celor 2 polinoame.
p(x)=a0+a1x+a2x^2+....+anx^n
q(x)=b0+b1x+b2x^2+....+bnx^n }
uses crt;
type vector=array [1..20] of integer;
var a,b,c:vector;
g1,g2,n,i,j:integer;
procedure scrie(k:integer;v:vector);
begin
for i:=0 to k do begin
write(v[i],' ');
end;
end;
procedure citire (k:integer;var v:vector);
begin
for i:=0 to k do begin
write ('A[',i,'] = ');
readln (v[i]);
end;
end;
procedure produs (g1,g2:integer; a,b:vector);
begin
for i:=0 to g1+g2 do
begin
c[i]:=0;
for j:=0 to i do c[i]:=c[i]+a[j]*b[i-j];
end;
end;
begin
clrscr;
write('Gradul polinomului A = ');readln(g1);
citire(g1,a);
write('Gradul polinomului B = ');readln(g2);
citire(g2,b);
produs(g1,g2,a,b);
scrie(g1+g2,c);
readkey;
end.
{DAME.PAS - 26.08.1999
obs. pt. 10 dame se obtin 724 solutii}
program ProblemaDamelor;
uses crt;
const max=10;
type vector=array[1..max] of integer;
var nrsol:integer;
procedure scrie(n:integer;x:vector);
var i:integer;
begin
inc(nrsol);
writeln('Solutia nr. ',nrsol);
for i:=1 to n do
writeln('Dama de pe coloana ',i,' e pe linia ',x[i]);
writeln;
readkey;
end;
function PotContinua(x:vector;k:integer):boolean;
var atac:boolean;
i:integer;
begin
atac:=false;i:=1;
while (i<k) { i este mai mic decat nr. coloanei }
and(not atac) do
if (x[i]=x[k]) { atac pe orizontala }
or (abs(x[i]-x[k])=k-i) { atac pe diagonala }
then atac:=true
else i:=i+1; { trecem la urmatoarea dama }
potcontinua:=not atac;
end;
procedure dame(n:integer;var x:vector);
var k:integer;cont:boolean;
begin
k:=1; { se proneste cu prima dama ce se pune pe coloana 1}
x[k]:=0; { se plaseaza in afara tablei, sub prima linie }
while k>0 do { mai sunt de asezat dame, de incercat variante (k:=k-1 nu e in afara tablei)}
begin
cont:=false;
while (x[k]<n) {dama k poate fi deplasata cu o linie mai sus }
and (not cont) do { dama k nu e bine asezata pe coloana k si linia x[k] }
begin
x[k]:=x[k]+1; {dama k(de pe col. k) se deplaseaza cu o linie (x[k]) }
if potcontinua(x,k) then cont:=true;
end;
if not cont then k:=k-1 { se revine la dama anterioara }
else if k=n then scrie(n,x) { s-a ajuns la ultima dama }
else begin k:=k+1; { se trece la urmatoarea dama }
x[k]:=0; { noua dama se aseaza in afara tablei, sub prima linie (pe linia 0)}
end;
end;
end;
var asezaredame:vector;
nrdame:integer;
begin
clrscr;writeln(' Problema Damelor ');writeln;
writeln;nrsol:=0;
write('Dati nr. de dame: ');readln(nrdame);
Dame(NrDame,AsezareDame);
end.
{PROBL10X.PAS - 22.09.99}
{Se citeste de la tastatura un nr. nat. n (n<=20) si un nr.nat. v. Scrieti
in program comentat folosind metoda back-tracking care afiseaza toate numerele
de la 1 la n in toate modurile posibile astfel incat intre oricare 2 nr.
afisate in pozitii invecinate diferenta in modul sa fie mai mare decat valoarea
data v. Datele de iesire se vor scrie in fisierul OUT.DAT. In cazul in care
nu exista solutie in fisierul de iesire se va scrie "nu exista solutie"
exemplu:
n=4
v=1
OUT.DAT
3 1 4 2
2 4 1 3-
}
uses crt;
var n,v:integer;
as,ev:boolean;
f:text;
k,j:integer;
st:array[1..20] of integer;
begin
clrscr;
write('n=');readln(n);
write('v=');readln(v);
assign(f,'output.dat') ;
rewrite(f); j:=false
k:=0; j:=false;
while k>0 do
begin
repeat
if st[k]<n then begin
as:true;
inc(st[k]);
end
else as:=false;
if as then begin
ev:true;
for i:=1 to k-1 do
if st[k]=st[i] then begin
ev:=false;
break;
end;
if ev and if (k<>1) then
if abs (st[k]-st[k-1])<=v;
then ev:=false;
end;
until(as and ev) or (not as);
if as then if k=n then begin
j:=true;
for i:=1 to n do begin
write(f,st[i]);
write(f,'');
end;
writeln(f);
end
else begin inc(k);
st(k):=0;
end;
else dec(k);
end;
if not j then write (f,'nu exista solutie');
end.
end.
{SUBMULTI.PAS - 27.09.99}
uses crt;
var n,p,i,k:integer;
as,ev:boolean;
st:array[1..20] of integer; { stiva in care se genereaza submultimile }
a:array[1..20] of integer; { multimea principala }
begin
clrscr;
write('Cate elemente are multimea A? (n)=');readln(n);
write('Cate elemente au submultimile ? (p)=');readln(p);
{ generarea multimii A }
for i:=1 to n do a[i]:=i;
k:=1;st[k]:=a[1];
while k>0 do
begin
repeat { elem de pe poz.k sa fie mai mic decat cel mai mare din multime }
if st[k]<n then begin { conditia pt. a avea succesor }
inc(st[k]); { calculez succesor }
as:=true; { am succesor }
end
else as:=false; { nu am succesor }
{ e valid = daca continuand se poate ajunge la o solutie }
if as then begin
ev:=true; { presupun ca succ. este valid }
if (st[k]=st[k-1]) then ev:=False;
end;
until (as and ev) or (not as);
{ daca am suc. - ori sunt la capatul stivei si voi afisa solutia }
{ - ori avansez in stiva }
{ daca nu am suc. cobor in stiva }
if as then if k=p then begin { daca am ajuns la solutie }
for i:=1 to k do write(st[i],',');writeln;
readkey; { afiseaza }
end
else begin { daca nu am ajuns la solutie }
k:=k+1; { avansez in stiva }
st[k]:=0;
end
else k:=k-1; { cobor in stiva (pt. ca nu mai am succesor) }
end; readkey;
end.
{SUMABKTR.PAS - 27.09.99}
uses crt;
var n,p,i,k:integer;
as,ev:boolean;
st:array[1..20] of integer;
a:array[1..20] of integer;
begin
clrscr;
write('Cate elemente are multimea A? (n)=');readln(n);
write('Cate elemente au submultimile ? (p)=');readln(p);
k:=1;st[k]:=0;
while k>0 do
begin
repeat
if st[k]<n-k+1 then begin
inc(st[k]); { calculez succesor }
as:=true; { am succesor }
end
else as:=false; { nu am succesor }
if as then begin
ev:=true; { presupun ca succ. este valid }
s:=0; { init. suma cu 0 }
for i:=1 to k do s:=s+st[i]; { calculez suma }
if (s>n)or(st[k]>st[k-1]) then ev:=false; { nu e valid }
end;
until (as and ev) or (not as);
if as then if s=n then begin { daca am ajuns la solutie }
for i:=1 to k do write(st[i],'+');writeln;
readkey; { afiseaza }
end
else begin { daca nu am ajuns la solutie }
k:=k+1; { avansez in stiva }
st[k]:=0;
end
else k:=k-1; { cobor in stiva (pt. ca nu mai am succesor) }
end;
readkey;
end.
{DRAPEL.PAS - 30.09.99}
USES crt;
var as,ev:boolean;
st:array[1..20] of integer;
k,i:integer;
begin
k:=1;st[k]:=0;;
while k>0 do
begin
repeat
if st[k]<6 then begin { verific daca am succesor }
st[k]:=st[k]+1; { calculez succesor }
as:=true;
end
else as:=false;
if as then begin { verific daca este valid }
ev:=true;
for i:=1 to k-1 do
if st[k]=st[i] then begin
ev:=false;
break;
end;
if ev then if (k=2)and((st[k]<>2)and(st[k]<>4)) then ev:=False;
end;
until (as and ev)or(not as);
if as then { daca am succesor am doua situatii }
if k=3 then begin { am ajuns la capatul stivei si afis. solutia}
for i:=1 to k do
begin
case st[i] of
1:write('alb ');
2:write('galben ');
3:write('rosu ');
4:write('verde ');
5:write('albastru ');
6:write('rozbombon ');
end;
end;
writeln;
end
else begin
inc(k); { avansez la nivelul urmator al stivei }
st[k]:=0;
end
else dec(k); { nu am succesor si cobor in stiva }
end;
end.
{RUCSACD.PAS - 30.09.99}
uses crt;
var g,c,x,iau:array[1..10] of integer;
CMax,CC,GG:Integer; {CMax=castig maxim / CC=Castig curent / GG=greut max}
n,k,i,Greut:integer;
as,ev:boolean;
begin
clrscr;
write('Numar obiecte n=');readln(n);
for i:=1 to n do
begin
write('C[',i,']=');readln(c[i]);
write('G[',i,']=');readln(g[i]);
end;
write('Greutatea maxima GG = ');readln(gg);
k:=1;x[k]:=0;CMax:=0;
while k>0 do
begin
repeat
if k<n then begin
inc(x[k]);
as:=true;
end;
if as then begin
ev:=true;
for i:=1 to k do if x[i]=1 then Greut:=Greut+G[i];
ev:=Greut<=GG;
end;
until (as and ev)or(not as);
if as then if k=n then begin
CC:=0;
for i:=1 to n do if x[i]=1 then CC:=CC+C[i];
if CC>=CMax then
begin
CMax:=CC;
for i:=1 to n do Iau[i]:=X[i];
end;
end
else begin
inc(k);
x[k]:=0;
end
else dec(k);
end;
for i:=1 to n do
if Iau[i]=1 then writeln('Se ia obiectul ',i);
writeln('Castig = ',CMax);
readkey;
end.
{DELEGATI.PAS - 5.10.1999
Dintr-un grup de n persoane dintre care p femei trebuie formata o delegatie
de k persoane dintre care l sunt femei. Sa se precizeze toate delegatiile
care se pot forma.
Observatii:
----------
Stiva are capacitatea k
1 -------> p = femei
p+1 -----> n = barbati
}
uses crt;
var as,ev:boolean;
x,y,v,n,p,k,l,i:integer;
st:array[1..20] of integer;
begin
clrscr;
write('Cate persoane sunt disponibile? n = ');readln(n);
write('Cate persoane din ',n,' sunt femei? p = ');readln(p);
write('Cate persoane are delegatia? k = ');readln(k);
write('Cate persoane din ',k,' sunt femei? l = ');readln(l);
v:=1;st[v]:=0;
while v>0 do
begin
repeat
if v<=l then x:=p else x:=n;
if (st[v]<x) then begin { verific daca am succesor }
inc(st[v]);
as:=true;
end
else as:=false;
if as then begin
ev:=true;
if x=p then y:=1 else y:=l+1;
for i:=y to v-1 do
if (st[v]=st[i]) then begin
ev:=false;
break;
end;
if ev then if st[v]<st[v-1] then ev:=false;
end;
until (as and ev)or(not as);
if as then { daca am succesor am doua situatii }
if v=k then begin { am ajuns la capatul stivei si afis. solutia}
{afisez solutia}
for i:=1 to v do write(st[i],' ');
writeln;
readkey;
end
else begin
inc(v); { avansez la nivelul urmator al stivei }
if v<=l then st[v]:=0 else st[v]:=p;
end
else dec(v); { nu am succesor si cobor in stiva }
end;
end.
{PIU.PAS - 5.10.99}
{Afiseaza fisierul POEZIE.DAT litera cu litera}
uses crt;
var s:string; f:text;
i:integer;
begin
clrscr;
assign(f,'poezie.dat'); reset(f);
while not eof(f) do
begin
readln(f,s);
for i:=1 to length(s) do begin
write(s[i]);
delay(150);
end;
writeln;
end;
close(f);
readkey;
end.
{SUMABANI.PAS - 10.10.99}
{ Sa se afiseze toate modalitatile de a plati o suma n cu bancnote de valori
b1,b2,...,bm. Se presupune ca exista un numar suficient de bancnote de fiecare
fel.
Indicatii:
O solutie va fi sub forma unui vector x, unde x[k] = nr. de bancnote de tipul
b[k] care se vor folosi.
Astfel suma n se partitioneaza in mai multe sume, de forma x[k]*b[k].
REZOLVARE:
Valoarea maxima pe care o poate lua st[k] poate fi considerata n-s[k-1], unde
s[k-1] este suma componentelor deja alese din st[k].
Deci s[k-1] = x[1]+x[2]+...+x[k-1]. Pentru ca relatia sa fie valabila si
pentru k=1, s-a considerat vectorul s cu indici de la 0, iar s[0]=0.}
uses crt;
var st, { cate bancnote se ia din fiecare tip }
b, { valoarea bancnotelor }
s { suma actuala din stiva (pana la nivelul k ce se completeaza) }
:array[0..100] of integer;
as,ev:boolean; { am succesor, este valid }
n, { suma }
m, { nr. de bancnote }
i,k:integer; { i = var. ciclare , k = indicator de nivel }
begin
clrscr;
write('Dati suma n = ');readln(n);
write('Dati nr. de bancnote m = ');readln(m);
for i:=1 to m do
begin
write('Dati valoarea bancnotei ',i,' = ');readln(b[i]);
end;
k:=1;st[k]:=0;s[0]:=0;
while k>0 do
begin
repeat
if (k<=m) { daca nivelul stivei < nr. de bancnote (adica mai am de unde lua bancnote) }
and (st[k]*b[k]<n-s[k-1]) { si suma a st[k] bancnote de valoare b[k]<suma maxima-sumatuturorbancnotelor existente in stiva}
then begin { atunci }
inc(st[k]); { mareste nr de bancnote de valoarea b[k] }
as:=true;
end
else as:=false; { altfel nu am succesor (si voi cobora an stiva) }
if as then begin
ev:=true; { presupun ca este valid }
s[k]:=s[k-1]+st[k]*b[k]; { calculez valoarea totala din stiva }
if s[k]>n then ev:=false; { daca ea depaseste suma maxima atunci succesorul nu este valid }
end;
until (as and ev)or(not as); { pana cand am succesorul si e valid (afisez sau urc in stiva) sau nu am deloc (cobor in stiva) }
if as then { daca am succesor }
if s[k]=n then begin { daca valoarea din stiva=suma maxima am ajuns la o solutie }
for i:=1 to k do { afisez solutia }
writeln('Se iau ',st[i],' bancnote de ',b[i],' $');
writeln('-----------------------------------------');
end
else begin { urc in stiva }
inc(k); { maresc nivelul stivei }
st[k]:=0; { initializez nr. de bancnote de tipul b[k] cu 0 }
end
else dec(k); { daca nu am succesor cobor in stiva }
end;
readkey;
end.
{CUBCOLOR.PAS - 12.10.1999 }
uses crt;
var st,l:array[1..20] of integer;
c:array[1..20] of string[15];
as,ev:boolean;
k,i,m,n:integer;
begin
clrscr;
write('Dati nr. de cuburi n = ');readln(n);
write('Dati nr. de cuburi din turn m = ');readln(m);
for i:=1 to n do begin
write('Dati latura cubului ',i,' = ');readln(l[i]);
write('Dati culoarea cubului ',i,' = ');readln(c[i]);
end;
k:=1;st[k]:=0;
while k>0 do
begin
repeat
if (st[k]<n) then begin
inc(st[k]);
as:=true;
end
else as:=false;
if as then begin
ev:=true;
if (k<>1)and(c[st[k]]=c[st[k-1]]) then ev:=false;
if (k<>1)and(l[st[k]]>l[st[k-1]]) then ev:=false;
for i:=1 to k-1 do if st[i]=st[k] then ev:=false;
end;
until (as and ev)or(not as);
if as then if k=m then begin
writeln('-------------------------------------------------------------------');
for i:=1 to m do
begin
textcolor(7);
if c[st[i]]='verde' then textcolor(lightgreen);
if c[st[i]]='rosu' then textcolor(red);
if c[st[i]]='galben' then textcolor(yellow);
if c[st[i]]='albastru' then textcolor(blue);
if c[st[i]]='alb' then textcolor(white);
if c[st[i]]='maro' then textcolor(brown);
writeln('Cubul ',st[i],' ',c[st[i]],' cu latura ',l[st[i]],' este pe ',i);
end;
end
else begin inc(k);st[k]:=0;end
else dec(k);
end;
end.
{CURCOLO.PAS - 12.10.1999}
uses crt,graph;
var st,l:array[1..20] of integer;
c:array[1..20] of string[15];
as,ev:boolean;
k,i,m,n:integer;
x,gd,gm:integer;
begin
clrscr;
{ write('Dati nr. de cuburi n = ');readln(n);
write('Dati nr. de cuburi din turn m = ');readln(m);
for i:=1 to n do begin
write('Dati latura cubului ',i,' = ');readln(l[i]);
write('Dati culoarea cubului ',i,' = ');readln(c[i]);
end;
k:=1;st[k]:=0;
while k>0 do
begin
repeat
if (st[k]<n) then begin
inc(st[k]);
as:=true;
end
else as:=false;
if as then begin
ev:=true;
if (k<>1)and(c[st[k]]=c[st[k-1]]) then ev:=false;
if (k<>1)and(l[st[k]]>l[st[k-1]]) then ev:=false;
for i:=1 to k-1 do if st[i]=st[k] then ev:=false;
end;
until (as and ev)or(not as);
if as then if k=m then begin
writeln('-------------------------------------------------------------------');
for i:=1 to m do
begin
textcolor(7);
if c[st[i]]='verde' then textcolor(lightgreen);
if c[st[i]]='rosu' then textcolor(red);
if c[st[i]]='galben' then textcolor(yellow);
if c[st[i]]='albastru' then textcolor(blue);
if c[st[i]]='alb' then textcolor(white);
if c[st[i]]='maro' then textcolor(brown);
writeln('Cubul ',st[i],' ',c[st[i]],' cu latura ',l[st[i]],' este pe ',i);
end;
end
else begin inc(k);st[k]:=0;end
else dec(k);
end;}
gd:=detect;initgraph(gd,gm,'c:\Bp\bgi');
setcolor(white);
k:=2;
st[1]:=2;st[2]:=1;l[1]:=5;l[2]:=25;c[1]:='rosu';c[2]:='galben';
for i:=1 to k do
begin
x:=x-l[st[i]];
rectangle(10,480-(l[st[i]]*2),10*l[st[i]],480-l[st[i]]);
end;
readkey;closegraph;
end.
{NA&IO.PAS - 18.10.99}
program canibali;
uses crt;
type stiva = array[1..100,1..5] of integer;
var st :stiva;
k,cs,ms,cd,md,i:integer;
ev,as:boolean;
procedure init(var st: stiva; k:integer);
begin
st[k,1]:=0;
st[k,2]:=cs;
st[k,3]:=ms;
st[k,4]:=cd;
st[k,5]:=md;
end;
procedure succesor(var as:boolean; var st:stiva; k:integer);
begin
if st[k,1]<5 then begin
as:=true;
st[k,1]:=st[k,1]+1;
end else
as := false;
end;
procedure valid (var ev:boolean;st:stiva;k:integer);
begin
cs:=st[k,2];
ms:=st[k,3];
cd:=st[k,4];
md:=st[k,5];
if k mod 2<>0 then
case st[k,1] of
1 : begin cs:=cs-2;
cd:=cd+2; end;
2 : begin ms:=ms-2;
md:=md+2; end;
3 : begin cs:=cs-1;
ms:=ms-1;
cd:=cd+1;
md:=md+1; end;
4:begin cs:=cs-1;
cd:=cd+1;end;
5: begin ms:= ms-1;
md:=md+1; end;
end else
case st[k,1] of
1 : begin cs:=cs+2;
cd:=cd-2; end;
2 : begin ms:=ms+2;
md:=md-2; end;
3 : begin cs:=cs+1;
ms:=ms+1;
cd:=cd-1;
md:=md-1; end;
4:begin cs:=cs+1;
cd:=cd-1;end;
5: begin ms:= ms+1;
md:=md-1; end;
end;
ev := true;
if (ms<0)or (md<0)or(cs<0)or(cd<0)or ((ms>0)and(ms<cs))or((md>0)and(md<cd)) then ev:=false;
if (k<>1)and (st[k,1]=st[k-1,1])then ev := false;
for i:= 1 to k-1 do if (st[i,2]=st[k,2])and(st[i,3]=st[k,3])and((k-i{i sau 1})mod 2=0) then ev:= false;
end;
function solutie(k :integer): boolean;
begin
if (st[k,2]=0)and(st[k,3]=0) then solutie := true
else solutie := false;
end;
procedure tipar;
begin
for i:=1 to k do begin
write(st[i,1],' ',st[i,2],' ',st[i,3],' ',st[i,4],' ',st[i,5]);
writeln end;
readkey;
end;
begin
clrscr;
repeat
writeln('Dati nr. de canibali');
readln(cs);
writeln('Dati nr. de misionari');
readln(ms)
until (ms>=cs)and(ms>0)and(cs>0);
cd:=0;
md:=0;
k:=1;
init(st,k);
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(st,k);
end
else k:=k-1;
end;
readkey;
end.
{CANIBALI.PAS - 19.10.1999 - FUNCTIONARE INCORECTA???
Problema canibalilor si misionarilor:
-------------------------------------
Pe malul unei ape se gasesc c canibali si m misionari. Ei urmeaza sa treaca
apa avand la dispozitie o barca cu doua locuri. Se stie ca daca atat pe un mal
cat si pe celalalt avem mai multi canibali decat misionari, misionarii sunt
mancati de canibali. Se cere sa se scrie un program care sa furnizeze
toate variantele de trecere a apei in care misionarii sa nu fie mancati.
Canibalii si misionarii trebuie a treaca pe malul celalalt.
Codurile traversarilor:
1: 2 canibali
2: 2 misionari
3: 1 canibal
4: 1 misionar
5: 1 can & 1 misionar
st[k,1] - codul traversarii
st[k,2] - nr.de canibali de pe malul stg
st[k,3] - nr. de misionari de me malul stg
st[k,4] - nr. de canubali de pe malul drpt
st[k,5] - nr. de misonari de pe malul drpt.
am succesor daca st[k,1]<5
validare:
1) succesorul nu e bun daca sm<0 sau sc<0 sau dc<0 sau dm<0
2) nu e bun daca ((sm>0)and(sm<sc))or((dm>0)and(dm<dc)
3) nu e bun daca (k mod 2 = 0)and(st[k,1]=st[k-1,1])
4) nu e bun daca
for i:=1 to k-1 do
if (st[k,2]=st[i,2])and(st[k,3]=st[i,3]) and
((k-i) mod 2 = 0) then ev:=false
Solutia:
(sc=0)and(sm=0)
}
uses crt;
var st:array[1..50,1..50] of integer;
as,ev:boolean;
dm,dc,sc,sm,k,i,m,c:integer;
begin
clrscr; textcolor(13);
write('DATI NR DE CANIBALI: '); READLN(C);
WRITE('DATI NR DE MISIONARI: '); READLN(M);
k:=1;
st[k,1]:=0;
st[k,2]:=c;
st[k,3]:=m;
st[k,4]:=0;
st[k,5]:=0;
while k>0 do
begin
repeat
if st[k,1]<5 then begin { daca nu mai exista alte traversari }
inc(st[k,1]); { incearca urmat. traversare }
as:=true;
end
else as:=false;
if as then
begin { validare }
sc:=st[k,2];
sm:=st[k,3];
dc:=st[k,4];
dm:=st[k,5];
{ writeln('Inainte de case: > SC=',sc,' > SM=',sm);readkey;}
case st[k,1] of { executa traversarile in functie de codul traversarii }
1:if k mod 2<>0 then begin sc:=sc-2;dc:=dc+2;end
else begin sc:=sc+2;dc:=dc-2;end;
2:if k mod 2<>0 then begin sm:=sm-2;dm:=dm+2;end
else begin sm:=sm+2;dm:=dm-2;end;
3:if k mod 2<>0 then begin sc:=sc-1;dc:=dc+1;end
else begin sc:=sc+1;dc:=dc-1;end;
4:if k mod 2<>0 then begin sm:=sm-1;dm:=dm+1;end
else begin sm:=sm+1;dm:=dm-1;end;
5:if k mod 2<>0 then begin sc:=sc-1;sm:=sm-1;
dc:=dc+1;dm:=dm+1;
end
else begin
sc:=sc+1;sm:=sm+1;
dc:=dc-1;dm:=dm-1;
end;
end;
ev:=true;
{ writeln('Dupa casE: > SC=',sc,' > SM=',sm);readkey;}
if (sm<0)or(sc<0)or(dm<0)or(dc<0) then ev:=false;
if ((sm>0)and(sm<sc))or((dm>0)and(dm<dc)) then ev:=false;
if (k<>1)and(st[k,1]=st[k-1,1]) then ev:=false;
for i:=1 to k-1 do
if (st[k,2]=st[i,2])and(st[k,3]=st[i,3]) and
((k-i) mod 2 = 0) then ev:=false;
end;
until (not as)or(as and ev);
if as then begin
st[k,2]:=sc;
st[k,3]:=sm;
st[k,4]:=dc;
st[k,5]:=dm;
if (sc=0)and(sm=0) then begin { afisare solutie }
for i:=1 to k do
writeln(st[i,1],' | ',st[i,2],' ',st[i,3],' ',st[i,4],' ',st[i,5],' ');
writeln;
readkey;
end
else begin
writeln('Urc in stiva, k=',k);
inc(k);
st[k,1]:=0;
st[k,2]:=sc;
st[k,3]:=sm;
st[k,4]:=dc;
st[k,5]:=dm;
end
end
else
begin
k:=k-1;writeln('Cobor in stiva, k=',k);readkey;
end;
end;
END.
{EVOL.PAS - 19.10.99
Proiect simulator al evolutiei omenirii
---------------------------------------
* Unitatea de timp 1 secunda.
O zi are 30 secunde.
Intr-un minut omul poate parcurge 1 patratel pe harta sau poate prelucra
un patratel (adapost, hrana).
* Tipuri de om:
1 - barbat
2 - femeie
* Fiecare om are o varsta: 1..100 ani
Omul moare la o varsta<100 ani calculata in functie de ce s-a intamplat in
viata lui:
- daca un elev nu mai invata pana la 18 ani devine hot
Se intampla sa nu invete daca nu gaseste mancare suficienta si adapost
- daca a fost muscat de un animal i se ia 1 an din viata
- daca a fost prins furand i se iau 2 ani din viata (l-a caftit)
- daca a avut accidente la munca i se ia 1 an din viata
- daca hotul se intalneste pe harta cu vanator i se iau 20 ani
- etc...
* Preturile
1 leu - hrana pt. o zi ( castiga vanatorul )
1 leu - construirea unui adapost ( castiga muncitorul )
1 leu - spitalizarea ( castiga medicul )
* Regulile unui elev
* Regulile unui muncitor (2)
- intr-o zi trebuie sa faca rost de 10 lei pt.
* Oamenii au 5 meserii:
1 - elev
2 - muncitori
3 - hoti
4 - medici
5 - vanatori
Tipurile sunt memorate intr-un string
Cand varsta unei
* Pamantul poate fi de zece tipuri:
0 - teren arid
1 - iarba
2 - copac(umbra)
3 - adapost
4 - mancare
5 - unelte
6..10 - rezervate
Pozitia omului pe planeta la un moment dat este retinuta intr-o matrice
in care elementul de la pozitia X,Y este indicele persoanei
}
uses crt;
var p : array[1..40,1..40] of 0..10; { pamantul poate fi de 10 tipuri }
xy : array[1..40,1..40] of 0..1; { pozitia }
v : array[1..10] of 0..100; { varsta om , max. 10 oameni }
f : text;
lalala : 0..10;
i,j: byte;
n,m: byte;
k : byte; { nivelul stivei (max. 255 oameni) }
x,y: byte; { pozitia om 1 }
begin
clrscr;
assign(f,'harta.map');reset(f);
readln(f,n);readln(f,m);
for i:=1 to n do
begin
writeln;
for j:=1 to m do
begin
read(f,k);
p[i,j]:=k;
textbackground(lalala);
write(' '{,p[i,j]});
textbackground(1);
write(' ');
end;
end;
close(f);
k:=1;while keypressed do
begin
repeat
if (v[k]<100) {traieste}
and (dir<8) then begin
as:=true;
inc(dir);
case dir of
1: begin dec(x);dec(y) end;
2: begin dec(y);end;
3: begin inc(x);inc(y);end;
4: begin inc(x);end;
5: begin inc(y);inc(x);end;
6: begin inc(y);end;
7: begin dec(x);inc(y);end;
8: begin dec(x);end;
end;
if as then begin
if p[x,y]
end.
{REGI.PAS - 24.10.99}
program ProblemaRegilor;
uses crt;
const max=10;
type vector=array[1..max] of integer;
var nrsol:integer;
procedure scrie(n:integer;x:vector);
var i:integer;
begin
inc(nrsol);
writeln('Solutia nr. ',nrsol);
for i:=1 to n do
writeln('Dama de pe coloana ',i,' e pe linia ',x[i]);
writeln;
readkey;
end;
function PotContinua(x:vector;k:integer):boolean;
var atac:boolean;
i:integer;
begin
atac:=false;i:=1;
while (i<k) { i este mai mic decat nr. coloanei }
and(not atac) do
if (x[i]=x[k]) { atac pe orizontala }
or (abs(x[i]-x[k])=k-i) { atac pe diagonala }
then atac:=true
else i:=i+1; { trecem la urmatoarea dama }
potcontinua:=not atac;
end;
procedure regi(n:integer;var x:vector);
var k:integer;cont:boolean;
begin
k:=1; { se proneste cu prima dama ce se pune pe coloana 1}
x[k]:=0; { se plaseaza in afara tablei, sub prima linie }
while k>0 do { mai sunt de asezat dame, de incercat variante (k:=k-1 nu e in afara tablei)}
begin
cont:=false;
while (x[k]<n) {dama k poate fi deplasata cu o linie mai sus }
and (not cont) do { dama k nu e bine asezata pe coloana k si linia x[k] }
begin
x[k]:=x[k]+1; {dama k(de pe col. k) se deplaseaza cu o linie (x[k]) }
if potcontinua(x,k) then cont:=true;
end;
if not cont then k:=k-1 { se revine la dama anterioara }
else if k=n then scrie(n,x) { s-a ajuns la ultima dama }
else begin k:=k+1; { se trece la urmatoarea dama }
x[k]:=0; { noua dama se aseaza in afara tablei, sub prima linie (pe linia 0)}
end;
end;
end;
var asezaredame:vector;
nrdame:integer;
begin
clrscr;writeln(' Problema Damelor ');writeln;
writeln;nrsol:=0;
write('Dati nr. de dame: ');readln(nrdame);
Regi(NrDame,AsezareDame);
end.
{CMMDC.PAS - 4.11.1999}
uses crt;
var a,b:integer;
function c(a:integer;b:integer):integer;
begin
if a=b then c:=a;
if a<b then c:=c(a,b-a);
if a>b then c:=c(a-b,b);
end;
begin
clrscr;
textcolor(13);
write('a='); readln(a);
write('b='); readln(b);
write('Cel mai mare divizor comun = ',c(a,b));
readkey;
end.
{MANAPNUNE.PAS - 4.11.99}
USES CRT;
var x:integer;
function mana(x:integer):integer;
begin
if x>=12 then mana:=x-1
else
mana:=mana(mana(x+2));
end;
begin
clrscr;
textcolor(13);
writeln('MANNA - PNUELLI');
writeln('---------------');
writeln('////////PROGRAM SPONSORIZAT DE RAZVAN & MIHAI COMPANY///////');
write('X=');readln(x);
writeln(mana(x));readkey;
end.
{VECTORX.PAS - 4.11.99}
{ Functie recursiva pentru a afla daca un vector contine cel putin un
element pozitiv }
uses crt;
var n,i:integer;
v:array[1..20] of real;
function POZ(i:integer):boolean;
begin
poz:=false;
if (v[i]<=0)and(i<n) then begin poz:=poz(i+1);end
else if v[i]>0 then poz:=true;
end;
begin
clrscr;
write('Dati nr. de numere = ');readln(n);
writeln('Dati numerele: ');
for i:=1 to n do begin
write('V[',i,'] = ');readln(v[i]);
end;
if poz(1) then writeln('Exista cel putin un nr. pozitiv.') else writeln('Nu exista nici un nr. pozitiv.');
readkey;
end.
{GRAF.PAS - 5.11.99}
uses crt;
var a:array[1..10,1..10] of 0..1;
c,viz:array[1..10] of 0..1;
x,n,i,j:integer;
p,u:integer; {p = vf.cozii , u = baza }
begin
textbackground(0);
clrscr;
write('Nr. de noduri n = ');readln(n);
write('Nodul de la care plec x = ');readln(x);
clrscr;
writeln('Dati matricea!');
for i:=1 to n do
for j:=1 to n do
begin
gotoxy(2*j,2*i);
readln(a[i,j]);
end;
for i:=1 to n do viz[i]:=0;
p:=1;u:=1;c[p]:=x;
while p<=u do {while coada nu este vida }
begin
for i:=1 to n do
if (a[c[p],1]=1)and(viz[i]=0) then begin
write(i);
viz[i]:=1;
inc(u);
c[u]:=i;
end;
inc(p);
end;
end.
{XXX.PAS - 5.11.99}
uses crt;
var a:array[1..5,1..5] of byte;
n,i,j:byte;
nue:boOlean;
begin
clrscr;
write('n=');reAdln(n);
for i:=1 to n do
for j:=1 to n do
begin
gotoxy(2*j,2*i);
readln(a[j,i]);
end;
for i:=1 to n do
begin
nue:=false;
for j:=1 to n-1 do
if a[i,j]=1 then nue:=true;
if nue=false thEn writeln('Este nod izolat: ',i);
end;
end.
{FUNCTIE.PAS - 6.11.99}
USES CRT;
VAR X:INTEGER;
FUNCTION F(K:INTEGER):INTEGER;
BEGIN
IF K<0 THEN F:=F(F(K+2))
ELSE IF( K>=0) AND (K<=9) THEN F:=K-1
ELSE IF K>9 THEN F:=F(K-5);
END;
BEGIN
{
textbackground(0);
window(24,15,24,15);textbackground(red);clrscr;gotoxy(12,7);textcolor(green);write('program realizat de razvan');clrscr;]}
TEXTBACKGROUND(0); CLRSCR;
WINDOW(23,10,35,10);
textbackground(red);clrscr;GOTOXY(15,7);textcolor(green);
WRITE('DATI X='); READLN(X);
WRITE(F(X));
READKEY;
END.
{CUBURI.PAS - 6.11.1999
Folosind metoda backtr. recursiv scrieti un program pt. aranjarea a n
cuburi etichetate de la 1 la n de laturi Ni si culori Ci, cu i de la
1 pana la n a.i. toate turnurile de m cuburi care se pot forma sa aiba
cuburile asezate in ordine descrescatoare iar culorile cuburilor alaturate
sa fie diferite.}
uses crt;
var st,l:array[1..20] of integer;
c:array[1..20] of string[15];
as,ev:boolean;
k,i,m,n:integer;
begin
clrscr;
write('Dati nr. de cuburi n = ');readln(n);
write('Dati nr. de cuburi din turn m = ');readln(m);
for i:=1 to n do begin
write('Dati latura cubului ',i,' = ');readln(l[i]);
write('Dati culoarea cubului ',i,' = ');readln(c[i]);
end;
{DEATH.PAS - 6.11.1999}
uses crt;
var s,urm:array[1..20] of integer;
viz:array[1..20] of 0..1;
a:array[1..20,1..20] of 0..1;
v,i,j,n,m,k,x:integer;
begin
clrscr;
write('dati nr. de noduri='); readln(n);
write('dati nodul='); readln(x);
write('nr. de muchii='); readln(m);
for i:=1 to n do
for j:=1 to n do
a[i,j]:=0;
for i:=1 to m do begin
readln(j,k);
a[j,k]:=1;
a[k,j]:=1;
end;
for i:=1 to n do begin
viz[i]:=0;
urm[i]:=0;
end;
v:=1;
viz[x]:=1;
s[v]:=x;
write('Ordinea nodurilor este :',x);
while v>=1 do begin
k:=s[v];j:=urm[k]+1;
while (j<=n) and (((a[k,j]=1) and (viz[j]=1)) or (a[k,j]=0))
do inc(j);
if j>n then v:=v-1
else begin viz[j]:=1;inc(v);s[v]:=j;
write(' ',j);urm[k]:=j;
end;end;readkey;
end.
{COSTMIN2.PAS - 4.12.1997
sunt n-1 incercari }
uses crt,dos;
var fin,fout:text;
i,x,y,j:integer;
instring:string;
nrn:integer;
n:array[1..1000] of longint;
coptim,cost,rez:integer;
ctotal,nrzerouri,lungnr:integer;
strn:string;
opx,opy:longint;
procedure calculeaza_si_modifica_nr_zerouri;
begin
repeat
if strn[lungnr]='0' then begin
dec(lungnr);
inc(nrzerouri);
end;
until strn[lungnr]<>'0';
end;
begin
coptim:=maxint;
clrscr;
assign(fin,'intrare.in');
assign(fout,'iesire.out');
repeat
reset(fin);
rewrite(fout);
readln(fin,nrn);
for i:=1 to nrn do read(fin,n[i]);
if (n[i]<>0) or (n[j]<>0) then coptim:=maxint;
for i:=1 to nrn do
begin
for j:=i+1 to nrn do
begin
rez:=n[i]*n[j];
str(rez,strn);
lungnr:=length(strn);
calculeaza_si_modifica_nr_zerouri;
cost:=lungnr;
if (cost<=coptim) and (cost<>0) and (n[i]<>0) and (n[j]<>0) then begin coptim:=cost;opx:=n[i];opy:=n[j];
writeln('------> Cea buna: ',n[i],' * ',n[j],' = ',rez
,' / cost = ',cost);readkey;
end;
if (n[i]<>0) and (n[j]<>0) and (cost<>0) then writeln(n[i],' * ',n[j],' = ',rez,' cost = ',cost);
end;
{writeln(' Coptim la ',n[i],' = ',coptim,'| oper:',opx,'*',opy,'| Ctotal = ',ctotal);}
if (n[i]<>0) or (n[j]<>0) and (coptim<>0) then inc(ctotal,coptim);
end;
n[1]:=opx*opy;
nrn:=nrn-1;
n[nrn]:=0;
writeln('---------------------> S-A FORMAT UN NOU VECTOR! <-----------------');
readkey;
{ clrscr;write('Noul vectorul:');
for i:=1 to nrn do write(n[i],' ');}
writeln('Rezultat: ',rez);
for i:=1 to nrn do write(fout,n[i],' ');
clrscr;write('Noul vectorul:');
for i:=1 to nrn do begin read(fout,n[i]);write(n[i],' ');end;
close(fout);
until nrn=1;
writeln('Cost optim total: ',ctotal);
close(fout);
close(fin);
end.
Mihai MATEI
Software Engineer
Laborator Pascal – Educational
You are here:
- Home
- Blog
- Software Development
- Pascal
- Laborator Pascal – Educational
