Program 1 tablice i menu repit
uses
SysUtils;
function stat :real;
var
a,b,c,p:real;
i,n: integer;
x,y:array [1..10] of real;
begin
writeln('podaj n (1-10)');
a:=0;
b:=0;
c:=0;
repeat
readln (n)
until
(n>0) and (n<=10);
for i:=1 to n do
begin
writeln('podaj x[',i,'] y[',i,']');
readln (x[i],y[i]);
a:=a+x[i]*y[i];
b:=b+x[i]*x[i];
c:=c+y[i];
end;
p:=a/(sqrt(b)*sqrt(c)+1);
stat:=p;
end;
function dyna :real;
var
a,b,c,p:real;
i,n: integer;
x,y:array of integer;
begin
writeln('podaj n');
a:=0;
b:=0;
c:=0;
repeat
readln (n)
until
(n>0);
setlength(x,n);
setlength(y,n);
for i:=1 to n-1 do
begin
writeln('podaj x[',i,'] y[',i,']');
readln (x[i],y[i]);
a:=a+x[i]*y[i];
b:=b+x[i]*x[i];
c:=c+y[i];
end;
p:=a/(sqrt(b)*sqrt(c)+1);
dyna:=p;
end;
var w:integer;
begin
repeat
repeat
writeln('1. T.Dynamiczne');
writeln('2. T.Staryczne');
writeln('3. Zakonczenie');
readln(w);
until
(w=1) or (w=2) or (w=3);
case w of
1: writeln (dyna:3:1);
2: writeln(stat:3:1);
end;
readln;
until w=3;
end.
Program 2 tablice i procedury
uses
SysUtils;
type tab=array [1..10] of array [1..10] of integer;
var am,an,bn,bm:integer;
a,b,c:tab;
nazwa:string;
procedure wyswietl (a:tab; n,m:integer);
var i,j:integer;
begin
for i:=1 to n do
begin
for j:=1 to m do
write (a[i,j], ' ');
end;
end;
procedure pobierz (var a:tab; n,m:integer; nazwa:string);
var i,j:integer;
begin
for i:=1 to n do
for j:=1 to m do
begin
writeln('podaj ' ,nazwa,'[',i,',',j,']');
readln(a[i,j]);
end;
end;
procedure suma(a,b:tab; var c:tab; n,m:integer);
var i,j:integer;
begin
for i:=1 to n do
for j:=1 to m do
c[i,j]:=a[i,j]+b[i,j];
end;
begin
{ TODO -oUser -cConsole Main : Insert code here }
writeln('podaj an,am,bn,bm');
readln(an,am,bn,bm);
if (an=bn) and (am=bm) then
begin
nazwa:='a';
pobierz(a,an,am,nazwa);
nazwa:='b';
pobierz(b,bn,bm,nazwa);
suma(a,b,c,an,am);
wyswietl(c,an,am);
end
else
writeln('zle wymiary');
readln
end.
Program 3 Elementy maxymalne w tablicy
uses
SysUtils;
type tab=array of real;
var
c: real;
poz,n: integer;
a:tab;
procedure pobierz (n:integer;a:tab);
var
i: integer;
begin
for i:=0 to n-1 do
begin
writeln('podaj n[',i,']');
readln(a[i]);
end;
end;
function elmax (a:tab;var poz:integer;n:integer):real;
var
i:integer;
max:real;
begin
max:=a[0];
poz:=0;
i:=1;
while i<=n-1 do
begin
if a[i]>max then
begin
max:=a[i];
poz:=i;
end;
i:=i+1;
end;
elmax:=max;
end;
begin
{ TODO -oUser -cConsole Main : Insert code here }
repeat
begin
writeln('podaj ilosc elementow tablicy');
readln(n);
end;
until n>0;
setlength(a,n);
pobierz(n,a);
c:=elmax(a,poz,n);
writeln(' maxymaly element tablicy to ', c:0:3,' ktory jest na pozycji
',poz);
readln;
end.
program 4 trojmian kwadratowy program
ses
SysUtils;
var
a,b,c:real; //współczynniki wielomianu ax^2+bx+c=0
x1,x2,x:real; //miejsca zerowe trójmianu
d:real; //delta
begin
{ TODO -oUser -cConsole Main : Insert code here }
writeln('podaj a,b i c');
readln(a,b,c);
if a<>0
then
begin
d:=b*b-4*a*c;
writeln(d:5:2);
if d>0
then
begin
x1:=(-b-sqrt(d))/(2*a);
x2:=(-b+sqrt(d))/(2*a);
writeln('pierwiastki to ', x1:5:2,' ', x2:5:2 );
end
else
if d=0
then
begin
x:=-b/(2*a);
writeln('pierwiastek równania to ', x:5:2);
end
else
begin
writeln('Nie ma pierwiastków delta < 0');
end
end
else
if b=0
then
begin
if c=0
then
begin
writeln('nieskonczenie wiele rozwiazan');
end
else
writeln('sprzecznosc');
end
else
begin
x:=-c/b;
writeln('wartosc x to ', x:5:2);
end;
readln;
end.
Program 5
Wyszukiwanie wzorca
uses
SysUtils;
var
tekst,wzorzec:string;
znaleziono, jest: boolean;
i,j,n,m,poz:integer;
begin
{ TODO -oUser -cConsole Main : Insert code here }
writeln('podaj tekst glowny');
readln(tekst);
writeln('podaj wzorzec');
readln(wzorzec);
n:=length(tekst);
m:=length(wzorzec);
if n>=m
then
begin
i:=1;
znaleziono:=false;
while (i<=n-m+1) and (znaleziono=false) do
begin
jest:=true;
j:=1;
while (j<=m) and (jest=true) do
begin
if wzorzec[j]<>tekst[i+j-1]
then
begin
jest:=false;
end;
j:=j+1;
end;
if jest=true
then
begin
poz:=i;
znaleziono:=true;
end;
i:=i+1;
end;
if znaleziono=true
then
writeln('znaleziono na pozycji ',poz)
else
writeln('nie ma w tekscie');
end
else
writeln('wzorzec za dlugi');
readln
end.