const n=5;

var a:array[1..n] of integer; i:integer;

begin clrscr; randomize;

for i:=1 to n do begin a[i]:=random(9);

write(a[i]); end;

writeln;

for i:=1 to n do begin if odd(a[i])=false then a[i]:=1 else a[i]:=0;

write(a[i]);

end;

readkey;

end.

Раздел: Процедуры и функции

1.Описание: Найти последовательности целых чисел те, которые встречаются в ней ровно два раза.

program one;

uses crt;

type mas=array[1..100]of integer; func=function(var x:mas):integer; var a:mas; j,n,m,x:integer;

function kolichestvo(var c:mas):integer; var k,i:integer;

begin k:=0;

for i:=1 to n do if c[i]>m then k:=k+1;

kolichestvo:=k; end;

procedure deist(var b:mas; operation:func);

begin writeln('b[j]');

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

for j:=1 to n do write(b[j],' '); writeln;

x:=operation(a); end;

begin clrscr;

writeln('vvedite celoe chislo m i razmer massiva(n)');

readln(m,n);

deist(a,kolichestvo);

writeln('kolichestvo=',x);

readkey;

end.

2.Описание: Процедура отображения рамки в текстовом режиме

program frame;

uses Crt;

procedure Frm(l:integer; t:integer; w:integer; h:integer);

var x,y:integer; i:integer; c1,c2,c3,c4,c5,c6:char;

begin clrscr;

c1:=chr(218); c2:=chr(196);

c3:=chr(191); c4:=chr(179);

c5:=chr(192); c6:=chr(217); GoToXY(l,t);

write(c1);

for i:=1 to w-2 do write(c2);

write(c3);

y:=t+1;

x:=l+w-1;

for i:=1 to h-2 do begin GoToXY(l,y);

write(c4);

GoToXY(x,y);

write(c4);

y:=y+1; end;

GoToXY(l,y);

write(c5);

for i:=1 to w-2 do write(c2);

write(c6);

end;

begin Frm(2,2,15,10);

readln;

end.

3.Описание: Произведение нечетных элементов

Program one;

type massiv= array [1..100] of integer;

var A1,A2:massiv; i,j:integer; n1,n2:integer; function pr_nec(m:massiv; n:integer):integer;

var i,j,pr:integer;

begin pr:=1;

for i:=1 to n do if odd(m[i]) then pr:=pr*m[i];

pr_nec:=pr;

end;

begin writeln('Vvedite PERVYI massiv:');

write('ego razmer "n": '); readln(n1);

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

writeln('_______________________');

writeln('Vvedite VTOROI massiv:');

write('ego razmer "n": '); readln(n2);

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

writeln('_______________________');

writeln;

writeln('Vi vveli:');

write('A1: '); for i:=1 to n1 do write(A1[i],' '); writeln;

write('A2: '); for i:=1 to n2 do write(A2[i],' '); writeln;

writeln;

writeln('Proizvedenie iz A1= ',pr_nec(A1,n1));

writeln('Proizvedenie iz A2= ',pr_nec(A2,n2));

readln;

end.

4.Описание: Нахождение тангенса tg и котангенса ctg угла, используя выражения sin(x)cos(x) и обратное ему.

Program one;

uses crt;

var y1,y2,z: real; function tg (x : real) : real;

begin tg := sin(x)/cos(x);

end;

function ctg (x : real) : real;

begin ctg := cos(x)/sin(x);

end;

Begin clrscr;

write ('input x: ');

readln (z);

y1:=tg(z); y2:=ctg(z);

writeln ('tg (',z:0:2,')=',y1:0:2);

writeln ('ctg (',z:0:2,')=',y2:0:2);readln;

End.

5. Описание: Определить максимальное число из четырех введенных, путем сравнения их сначала попарно, а затем результат между собой.

program one;

uses crt;

var a,b,c,d,z,x,y,x1,y1:integer; function max(x,y:integer):integer;

begin if x>y then max:=x else max:=y;

end;

begin clrscr;

writeln('Vvedite chisla');

readln(a,b,c,d);

x1:=max(a,b); y1:=max(c,d); z:=max(x1,y1);

writeln('max=',z);

readkey;

end.

6.Описание: Вычислить день недели по дате

program Kalendar;

uses crt; var y,d,m,c,w: integer; {m-mesiac,d-den, y-god }Procedure WriteDay(d,m,y:Integer);

constDays_of_week: rray [0..6] of String [11] =('Voskresen`e','Ponedelnik','Vtornik', ' Sreda', ' Chetverg', ' Piatnica', ' Subbota') ;

Begin if m <3 then begin m := m + 10;

y := y - 1;end else m := m - 2;c := y div 100;y := y mod 100;w := (d+(13*m-1) div 5+y+y div 4+c div 4-2*c+777) mod 7;

WriteLn(Days_of_week[w] );end;

Procedure InputDate(var d,m,y : Integer);

Begin Write('Vvedite datu v formate DD MM GG ');

ReadLn(d,m,y);

if (d>=1)and (d<=31) and (m>=1) and (m<=12) and (y>=1582) and (y<=4903) then Writeday(d,m,y) else begin writeln ('Nekorrektnyj vvod!');end;end;

BEGIN clrscr;

InputDate(d,m,y);

readkey;

End.

7. Описание: Нахождение процента от числа

Program one;

uses crt;

var k,n:byte; x:real; function procent(n,m:byte):real;

begin procent:=m*100/n;

end;

begin clrscr;

writeln('Vvedite chisla');

readln(k,n);

x:=procent(k,n);

writeln('x=',x:5:2);

readkey;

end.

8. Вывести заданное число звездочек.

program one;;

uses crt;

var n:byte; function zvezda(n:byte):real; var i:integer; s:string;

begin i:=1;

s:='';

while i<=n do begin s:=s+'*';

inc(i); end;

writeln(s); end;

begin clrscr;

writeln('Vvedite chislo'); readln(n);

zvezda(n); readkey;

end.

9. Описание: Функция возведения числа в степень. С учетом дробных чисел и частных случаев, когда числа отрицательные или равны нулю

program one;

Uses crt;

var x,y,z:real; Function Pow(A,B:Real):Real; Var T,R:Real; L:integer;

Begin T := Abs(A);

If A < 0 Then R := (-1)*Exp(B*Ln(T)) else if A > 0 Then R := Exp(B*Ln(T)) else R:=0;

L := round(B);

If (L mod 2 = 0) Then R:=Abs(R);

If (B=0) Then R:=1;

Pow:=R;

End;

BEGIN clrscr;

Writeln('vvedite chislo:');

readln(x);

Writeln('vvedite stepen:');

readln(y);

z:=Pow(x,y);

Writeln(z:0:2);

readkey;

END.

10. Описание: Вывести заданный символ заданное количество раз

program one;

uses crt;

var n:byte; l:string; function zvezda(n:byte;l:string):real; var i:integer; s:string;

begin i:=1;

s:='';

while i<=n do begin s:=s+l;

inc(i); end;

writeln(s); end;

begin clrscr;

writeln('Vvedite chislo'); readln(n);

writeln('Vvedite simvol'); readln(l);

zvezda(n,l);

readkey;

end.

11.Описание: Определить к чему ближе меньшее из двух чисел: к их среднему арифметическому или среднему геометрическому.

Program one;

vara,b : real; average : real; geometricmean : real; minstr : string;function min(a,b : real) :real;

begin min := a;

minstr := 'Pervoe';

if (b < a) then begin min := b;

minstr := 'Vtoroe';end;end;

beginwrite('Vvedite 1-e chslo: ');readln(a);

write('Vvedite 2-e chslo: ');readln(b);

average := (a + b) / 2;

geometricmean := sqrt(a*a + b*b);

a := min(a,b);

writeln('Naimenshee chislo - ',minstr,' (',a:0:3,')');

write('Blize k srednemu ');

if (abs(average - a) < abs(geometricmean - a)) thenbegin writeln('arifmeticheskomu (',average:0:3,')');

end else begin writeln('geometricheskomu (',geometricmean:0:3,')');end;

readln;

end.

12.Описание:Возведение в степень для целого показателя, вычисляемого за время log2(степень).

Program power_maximal;

Uses crt;

Var a,b,c: integer; function power (x,pow:integer):integer; var res: integer;

begin res := 1;

while (pow > 0) do beginif (pow and 1 = 1) then res:= res * x;

x := x * x;

pow := pow shr 1;end;

power := res; end;

Begin Clrscr;

Writeln ('input a,b: ');

Readln (a,b);

c:=power(a,b);

Writeln('a^b = ',c);

Readkey;

End.ъ

13.Описание:Арккосинус числа. Нахождение из математических соображений

var ca,al,albeg: real; function ArcCos(arg:real):real;

var r:real;

begin if (abs(arg)>1) then begin writeln(' Unavailable argument ');

halt; end;

if abs(arg)<0.000001 then r := pi/2 else r := ArcTan(sqrt(1/arg/arg-1)); { arccos }

if arg<0 then r:=pi-r;

ArcCos := r; end;

begin albeg:=pi/2+0.2;

ca := cos(albeg);

al := arccos(ca);

writeln('ArcCos(',ca:10:7,')=',al:10:7,' AlBeg=',albeg:10:7,

' ChekSum =',al-albeg,' Must be sero');

readln;

end.

14.Описание:Есть ли в строке числовые значения

Function NumInStr(S: String): Boolean;

VAR C, I: INTEGER; N: BOOLEAN;

BEGIN; I:=0;

Repeat;

I:=I+1;

C:=Ord(S[I]);

N:=( (C >= 48) AND (C <= 57) );

Until (NOT N) OR (I=Length(S));

NumInStr:=N;

END;

15.Описание:Нахождение функции методом половинного деления

program half_del;

uses crt;

type ms=array[1..100] of real; { [x,y] }

var Eps,XH,DX,Y,z,X,YH,P,S,A,B:real; N,U,Er:integer; masx,masy:ms;Function F(X:real):real;

beginF:=exp(x)+x*x-2

end;

Function FuncA(Eps,s,p,YH:real):real;

begin if F(p)*F(s)<0 then begin YH:=0.5*(p+s);

while abs(F(YH)) > EPS do begin If F(p)*F(YH) <0 then S:=YH else P:=YH;

YH:=0.5*(P+S) end; end else er:=1;

FuncA:=YH; end;

procedure P1(a,b,XH:real; N:integer); var z,q:real; u:integer;

begin if x>1 then begin Z:=sqrt(X*sqrt(X-1));

a:=FuncA(Eps,s,p,YH);

for U:=1 to N do begin masx[U]:=X;

masy[U]:=sin(x)/z;

X:=X+DX; end;

{else writeln(' Error: x<1 ');} end; end;

Begin clrscr;

write ('vvedite eps: '); readln(eps);

Write ('vvedite dx: '); readln(DX);

write ('vvedite N: '); readln(N);

write ('vvedite x>1 :'); readln(x);

if x1; writeln;

Writeln ('--------------------');

Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10