program msv;
uses crt;
const n = 10; {dlina massiva}
var a: array[1..n] of integer; i, max, j, k, mi: integer; begin clrscr; randomize;
for i := 1 to n do begin a[i] := random(51);
write(a[i], ' '); end;
max := a[1];
k := 2; {t.k. uslovie zadachi "preobarzovat' za odin prosmotr massiva", to}
{k ne mozhet bit' bol'she N, chem mi vospol'zuemsya v cikle}
for i := 2 to n do begin if k > n then break;
if a[i] <= max then {esli a[i] <= max to udalyaem etot element}
begin for j := i to n - 1 do {etogo cikl mog bi ne viiti, no u nas est' K}
a[j] := a[j + 1];
dec(i); end;
if a[i] > max then begin max := a[i];
mi := i; {MI - poziciya maksimuma v massive} end;
inc(k); {uvelichivaem K, k = [2..n]} End;
Write (#10#13, a[1], ' ');
For i: = 2 to mi do Write (a[i], ' ');
readkey;
end.
11. Описание: В массиве X из n элементов каждый из элементов равен 0, 1 или 2. Переставить элементы массива так, чтобы сначала располагались нули, затем единицы и двойки. Дополнительный массив не использовать.
Программа расширена для возможности переставлять элементы массива, являющимися любыми числами (не только 0, 1, 2)
Program msv;
Const n = 10; {кол-вл элементов массива}
var a, b, t : integer; X: array[1..n] of integer; {сам массив из n элементов}
BEGIN For a := 1 to n do {ввод массива X} Begin Write ('Введите X [', a, ']: ');
Readln(X[a]); End;
for a := 1 to n do begin t := X[a];
b := a - 1;
While (b>=0) and (t<X[b]) do Begin X [b+1]:= X[b];
B: = b - 1; End;
X [b+1]:= t; end;
for a := 1 to n do {вывод результата}
Write(X[a]:2);
END. {конец программы}
12. Описание: Операции с массивом, сортировка суммирование.В одномерном массиве, состоящем из N вещественных элементов, вычислить:1) количество элементов массива, равных 0;2) сумму элементов массива, расположенных после минимального элемента.
Упорядочить элементы массива по возрастанию модулей элементов.
Program msv;
Uses CRT;
Const N = 10; {сколько всего элементов}
Var a: Array[1..N] of Real; i, j: Byte; Zero: Byte; Min: Real; Summ: Real;
Procedure Print;
Begin For i := 1 to N do Write(a[i]:0:1,' ');
Writeln;End;
Procedure CreateMassive;
BeginWriteln('Исходная последовательность');
For i := 1 to N do Begin a[i] := Random(4);
a[i] := a[i] - 2; {Этот и предыдущий операторы можно объединить}
End;
Print;
Writeln;End;
Begin ClrScr;Randomize;
CreateMassive;
Min := a[1];
For i := 2 to N do Begin Summ := Summ + a[i];
If (a[i] < Min) then Begin Min := a[i];
Summ := 0; End; End;
Writeln('Минимальный элемент ',Min:0:1,'. Сумма элементов после: ',Summ:0:1);
For i := 1 to N do Begin For j := i + 1 to N do If (abs(a[j]) < abs(a[i])) then Begin a[i] := a[i] + a[j];
a[j] := a[i] - a[j];
a[i] := a[i] - a[j]; End; End;
Writeln(#13#10,'Отсортировання последовательность'); Print;
For i := 1 to N do If a[i] = 0 then Inc(Zero);
Write(#13#10,'Нулевых элементов: ',Zero);ReadKey;
End.
13. Описание: Вычислить угол между двумя заданными векторами размерности 8, используя функцию скалярного произведения a = arccos((x,y)/((x,x)*(y,y)))
program msv;
uses crt;
type TVector = array[1..8] of Real;
function scal(var Vec1, Vec2 : TVector):real; var p : Real; i : integer;
begin p:=0;
for i:=1 to 8 do p:=p+(Vec1[i]*Vec2[i]);
scal := p;end;
var Vec1, Vec2 : TVector; i : integer; sc, a, angle : Real;
BEGIN writeln('Условие:');
writeln(' вычислить угол между двумя заданными векторами размерности 8,');
writeln(' используя функцию скалярного произведения');
writeln;
Writeln('Ввод первого вектора');
for i := 1 to 8 do begin Write('Vec1[', i, '] : ');
Readln(Vec1[i]); end;
Writeln('Ввод второго вектора');
for i := 1 to 8 do begin Write('Vec2[', i, '] : ');
Readln(Vec2[i]); end;
sc := scal(Vec1, Vec2);
a:= sc/sqrt(scal(Vec1,Vec1)*scal(Vec2,Vec2)); {Вычисляется косинус}
if a=0 then angle:=90 else angle:=arctan(sqrt(1-a*a)/a)*180/pi;
if a=-1 then angle:=180;
if angle<0 then angle:=180+angle;
writeln('Угол между векторами: ',angle:7:3,' градусов');
END.
14. Описание: Вычислить сумму двух векторов, первый из которых вводится, а элементы второго вычисляются по формуле b[i]:=sin(i*x), где 0<=x<=3.14
program msv;
const Nm = 10; {размерность вектора}
var Vec1, Vec2, ResVec : array[1..Nm] of Real; i : integer; x : Real; N : integer;
BEGIN writeln('Условие :');
writeln(' вычислить сумму двух векторов, первый из которых вводится, а элементы');
writeln(' второго вычисляются по формуле b[i]:=sin(i*x), где 0<=x<=3.14');
writeln;
Write('введите размерность вектора (N<', Nm, '): ');
Readln(N);
if n <= Nm then begin Writeln('Ввод вектора');
for i := 1 to N do begin Write('Vec1[', i, '] : ');
Readln(Vec1[i]); end;
Write('Введите X (от 0 до 3.14) : '); Readln(x);
if (X <= 3.14) and (X >= 0) then begin for i := 1 to N do begin Vec2[i] := sin(Vec1[i]*X); ResVec[i] := Vec1[i]*Vec2[i]; {сразу же вычисляем произведние} end;
Write('Результирующий вектор : '); {выводим на экран результат}
for i := 1 to N do Write(ResVec[i]:6:2); end else Writeln('Введено неверное X');
end else Writeln('неверная размерность');
END.
15. Описание: Создается случайный массив из 5 элементов. Заменить все четные значения на 1, нечетные – на 0.
Program msv;
uses crt;
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;