Библиотека часто встречающихся процедур и функций
1. Процедуры, вычисляющая сумму цифр числа:
Procedure sum_number(n : integer; var
s : integer);
begin
s := 0;
repeat
s := s + n mod 10;
n := n div 10
until n = 0
end;
Procedure sum_number(p : longint; var s : longint);
begin
s := 0;
while p <> 0 do
begin
s := s + p mod 10;
p := p div 10
end
end;
2. Процедура, вычисляющая количество цифр в числе:
Procedure quantity_number(n : integer; var
k : integer);
begin
k := 0;
repeat
k := k + 1;
n := n div 10
until n = 0
end;
3. Процедура, записывающая заданное число в обратном порядке, например, 3467 записывает так: 7643.
Procedure backwards(n : integer; var
a : integer);
begin
a := 0;
repeat
a := a*10 + n mod 10;
n := n div 10
until n = 0
end;
4. Процедура перестановки первой и последней цифр числа.
Procedure first_last_number(n : integer; var n1 : integer);
var
a, i, p : integer;
begin
a := n; i := 1;
p := n mod 10; {последняя цифра введенного числа}
while n >= 10 do
begin
i := i*10;
n := n div 10
end;
n1 := a - n*i - p + n + p*i
end;
5. Процедура, определяющая, является число числом - палиндромом.
Procedure palindrom(a : integer);
var
b, c, p : integer;
begin
b := a; c := 0;
repeat
p := b mod 10;
c := c*10 + p;
b := b div 10
until b = 0;
if c = a then writeln('Число ', a, ' является палиндромом')
else writeln('Число ', a, ' не явл.
29. Процедура размещений из n элементов по k элементов.
Procedure placement(n, k : integer; var
r : longint);
var
i : integer;
begin
r := 1;
for i := 1 to k do r := r*(n - i + 1)
end;
30. Процедура числа сочетаний из n элементов по k элементов.
Procedure Combination(n, k : integer; var c : longint);
var
i : longint;
begin
c := 1;
for i := 1 to k do
c := c*(n - k + i) div i
end;
41. Функция вычисляющая количество знаков после запятой.
Function t(eps : real) : integer;
var
k : integer;
begin
k := -1;
repeat
eps := eps*10;
k := k + 1
until eps > 1;
t := k
end;
42. Процедуры вычисления квадратного корня с заданной степенью точности.
1-й способ
Procedure square_root(u, eps : real; var
x : real);
begin
x := (u + 1)/2;
repeat
x := (1/2)*(x + u/x)
until abs(x*x - u) <= eps;
end;
2-й способ
Procedure square_root(u, eps : real; var
x : real);
var
x1, x2 : real;
begin
x1 := 1;
repeat
x1 := (1/2)*(x1 + u/x1);
x2 := (1/2)*(x1 + u/x1)
until abs(x2 - x1) <= eps;
x := x2
end;
Упражнения
167. Дано действительное число
Требуется получить все a1, a2, ..., меньшие или равные b.
168. Дано действительное
Найти первый отрицательный член последовательности a1, a2, ... .
169. Составить программу вычисления и вывода на экран n членов последовательности, заданной формулой n-го члена. (Предварительно составить рекуррентную формулу).
а)
е)
и)
170. Составить программу, подсчитывающую сумму n
первых членов последовательности, заданной формулой n-го члена. (Предварительно составить рекуррентную формулу).
а)
д)
з)
171. Дано действительное
Найти первый неотрицательный член последовательности.
172. Дано натуральное n. Вычислить:
173. Для чисел Фибоначчи u0, u1, ... справедлива формула Бине:
Так как
палиндромом')
end;
6. Процедура нахождения цифрового корня числа.
Цифровым корнем числа называется сумма цифр заданного числа, затем сумма цифр полученной суммы и т.д. до тех пор, пока эта сумма не станет однозначным числом.
Procedure radical_number(n : integer; var
k : integer);
var
p, s : integer;
begin
repeat
s := 0;
while n <> 0 do
begin
p := n mod 10; s := s+p; n := n div
10
end;
n := s
until n < 10;
k := n
end;
7. Процедуры нахождения наибольшего общего делителя:
1-й способ (по простому алгоритму)
Procedure nod1(a, b : integer; var
n : integer);
begin
if a > b then n := b else n := a;
n := n + 1;
repeat
n := n - 1
until (a mod n = 0) and (b mod
n = 0)
end;
2-й способ (по 1-му алгоритму Евклида)
Procedure nod2(a, b : integer; var
n : integer);
begin
while a <> b do
begin
if a > b then a := a - b else
b := b - a
end;
n := a
end;
3-й способ (по 2-му алгоритму Евклида)
Procedure nod(a, b : integer; var
n : integer);
var
r : integer;
begin
repeat
r := a mod b;
a := b; b := r
until b = 0;
n := a
end;
8. Рекурсивная процедура нахождения НОД.
Procedure nod(a, b : integer; var
n : integer);
begin
if b = 0 then n := a else nod(b, a mod
b, n)
end;
9. Процедуры нахождения наименьшего общего кратного двух целых чисел (НОК).
1-й способ
Procedure nok(a, b : integer; var
k : integer);
var
m, n : integer;
begin
k := 0;
repeat
if a > b then
begin
m := a; n := b
end
else
begin
m := b; n := a
end;
k := p + m
until k mod n = 0
end;
2-й способ (с использованием НОД).
Procedure nok1(a, b : integer; var
k : integer);
var
n : integer;
begin
n := a*b;
repeat
c := a mod b;
a := b; b := c
until b = 0;
k := n div a
end;
10. Процедура определения всех делителей заданного числа.
1-й способ
Procedure everyone_divisor(n : integer);
var
i : integer;
begin
writeln('Делители числа ', n);
for i := 1 to n div 2 do
if n mod i = 0 then write(i, ' ');
writeln(n)
end;
2-й способ
Procedure everyone_divisor(n : integer);
var
i : integer;
begin
writeln('Делители числа ', n);
for i := 1 to trunc(sqrt(n)) do
if n mod i = 0 then write(i, ' ', n div i, ' ')
end;
11. Процедура, определяющая число делителей натурального числа:
Procedure number_division(n : integer; var k : integer);
var
d : integer;
begin
k := 0;
for d := 1 to n div 2 do
if n mod d = 0 then k := k + 1;
k := k + 1
end;
12. Процедура разложения числа на простые множители:
Procedure probleme_number(n : integer);
var
i : integer;
begin
while n mod 2 = 0 do
begin
write(2, ' ');
n := n div 2
end;
i := 3;
while i <= n do
if n mod i = 0 then
begin
write(i, ' ');
n := n div i
end
else
i := i + 2
end;
13. Процедура, определяющая, является ли число простым.
первый
способ
Procedure probleme_number(p : integer);
var
i, k : integer;
begin
if p = 2 then write(p, ' ')
else
if p mod 2 <> 0
then
begin
i := 3; k := 0;
while i <= p div
2 do
begin
if p mod i = 0 then k := k + 1;
i := i + 2
end;
if k = 0 then
write(p, ' ')
end
end;
второй
способ
Procedure probleme_number(p : integer);
var
i, k : integer;
begin
if p = 2 then write(p, ' ')
else if p mod 2 <> 0
then
begin
i := 3; k := 0;
while i <= trunc(sqrt(p)) do
begin
if p mod
i = 0 then k := k + 1;
i := i + 2
end;
if k = 0 then
write(p, ' ')
end
end;
14. Процедура, определяющая, является ли число автоморфным? Автоморфным называется такое число, которое равно последним цифрам своего квадрата.
Например: 52 = 25; 252 = 625.
Procedura awtomorf(x : integer);
var
d, k : integer;
begin
d := 10;
while d <= x do d := d*10;
k := x mod 10;
if (k = 1) or (k = 5) or (k = 6)
then
if x*x mod d = x then
writeln(x, ' ', x*x)
end;
15. Процедура, устанавливающая, равно ли заданное число сумме квадратов целых чисел и каких именно, если таковые существуют:
Procedure square(n : integer);
label 1;
var
a, b, k : integer;
begin
a := 1; k := 1;
while a*a + 1 <= n do
begin
k := k + 1; a := a + 1
end;
for a := 1 to k do
for b := 1 to a do if a*a + b*b = n then
begin
writeln(n, '=', a, '*', a, '+', b, '*', b); goto 1
end;
1: end;
16. Процедура определения Пифагоровых чисел из промежутка [n; m].
Procedure pifagor(n, m : integer);
var
a, b, c : integer;
begin
writeln('Пифагоровы числа из промежутка [',n, ';', m,']');
for a := n to m do
for b := n to a do
for c := n to m do
if a*a + b*b = c*c then writeln(a, ' ', b, ' ', c)
end;
17. Процедура представления числа n в виде суммы кубов двух чисел.
Procedure sum_number_cube(n : integer; var p : integer);
var
i, j, k : integer;
begin
k := 0; i := 1;
while i*i*i + 1 <= n do
begin
k := k + 1; i := i + 1
end;
p := 0;
for i := k downto 1 do
for j := 1 to i do
if i*i*i + j*j*j = n
then
begin
p := p + 1;
writeln(i, '*', i, '*', i, '+', j, '*', j, '*', j, '=', n)
end;
if p = 0
then
begin
write('Число ', n, ' нельзя представить в виде ');
writeln('суммы кубов двух чисел')
end
else
writeln('Число способов равно ', p)
end;
18. Процедура представления целого числа n в виде суммы квадратов трех чисел.
Procedure sum_square_number(n : integer; var p : integer);
var
k, x, y, z, p : integer;
begin
k := 0; x := 1;
while x*x + 2 <= n do
begin
k := k + 1; x := x + 1
end;
p := 0;
for x := 1 to k do
for y := 1 to x do
for z := 1 to y do
if x*x + y*y + z*z = n
then
begin
p := p + 1;
writeln(x, '*', x, '+', y, '*', y, '+', z, '*', z, '=', n)
end;
if p = 0
then
begin
write('Число ',n,' нельзя представить в виде ');
writeln('суммы квадратов трех чисел')
end
else writeln('Число способов равно ', p)
end;
19. Процедура определения цифры, стоящей на n-ом месте в записи подряд чисел 1234567891011121314...
Procedure location(n : integer; var
c : integer);
var
p, s, v, m, q : integer;
Procedure number(n : integer; var k : integer);
begin
k := 0;
repeat
k := k + 1;
n := n div 10
until n = 0
end;
begin
p := 1; s := 0;
repeat
number(p, v);
s := s + v; p := p + 1
until s>=n;
m := s - n; p := p - 1; q := 1;
for i := 1 to m do q := q*10;
c := p div q;
c := c mod 10;
writeln('Последняя цифра в записи этих цифр будет ', c);
writeln('Она находится в числе ', p)
end;
20. Процедуры вычисления степени натурального числа с натуральным показателем:
с
циклом repeat ... until
...
Procedure extent(a, n : integer; var s : integer);
var
i : integer;
begin
i := 1; s := 1;
repeat
s := s*a; i := i + 1
until i = n
end;
с
циклом for ... to
... do ...
Procedure extent(a, n : integer; var s : longint);
var
i : integer;
begin
s := 1;
for i := 1 to n do s := s*a
end;
функция вычисления степени числа:
Function extent(a, n : longint) : longint;
var
i : integer;
begin
extent := 1;
for i := 1 to n do extent := extent*a
end;
21. Процедура вычисления факториала числа:
итеративная
Procedure fac(n : integer; var f : longint);
var
i : integer;
begin
if n = 0 then f := 1 else for i := 1 to n do f := f*i
end;
рекурсивная
Procedure fac(n : integer; var f : longint);
begin
if (n = 0) or (n = 1) then f := 1
else
begin
fac(n - 1, f);
f := f*n
end
end;
22. Рекурсивная процедура умножения числа a на каждую цифру числа b, начиная с единиц:
Procedure umnogenie(a, b, s : integer);
begin
if b <> 0
then
begin
s := s + a*(b mod 10);
umnogenie(a, b div 10, s div 10);
write(s mod 10:1)
end
else
if s <> 0 then write(s)
end;
23. Функции вычисления чисел ряда Фибоначчи.
итеративная
Function fib(n : integer) : integer;
var
f, f1, f2, i : integer;
begin
f1 := 1; f := 0;
for i := 1 to n do
begin
f2 := f1; f1 := f;
f := f1 + f2;
end;
fib := f
end;
рекурсивная
Function fib(n : integer) : integer;
begin
if (n = 1) or (n = 2)
then fib := 1
else fib := fib(n - 1) + fib(n - 2)
end;
24. Процедура отделения корней на заданном промежутке [a; b] для заданной функции fx, т.е. определения промежутков, на которых может находиться хотя бы один корень (h - шаг), (x1, x2 - границы полученных промежутков).
Procedure separation_root(a, b, h : real);
var
x1, x2, y1, y2 : real; k : integer;
Function fx(x : real) : real;
begin
fx := ???????????
end;
begin
k := 0; x1 := a; x2 := x1 + h;
y1 := fx(x1);
while x2 <= b do
begin
y2 := fx(x2);
if y1*y2 < 0
then
begin
k := k + 1;
writeln(k, '-й корень на [', x1:6:4, '; ', x2:6:4,']')
end;
x1 := x2; x2 := x1 + h;
y1 := y2
end
end;
25. Процедура уточнения корня некоторой функции func(x) методом деления пополам (a, b - границы промежутка, eps - точность вычисления, x - значение корня, d - погрешность вычисления).
Procedure half(a, b, eps : real; var
x, d : real);
var
c : real;
begin
while abs(b - a) > eps do
begin
c := (a + b)/2;
if func(a)*func(c) < 0 then b := c
else a := c
end;
x := (a + b)/2;
d := abs(b - a)/2
end;
26. Процедура поиском минимума функции на промежутка с помощью ряда Фибоначчи.
{ Процедура определения минимума функции на промежутке }
Procedure minfib(a, b, e : real; var x : real);
label 1;
var
aa, bb, x1, x2, y1, y2 : real;
n : integer;
{----------------------------------------------------------------------------------------}
{ Заданная исследуемая функция }
Function func(x : real) : real;
begin
func := ?????????????????
end;
{----------------------------------------------------------------------------------------}
{ Функция вычисления членов ряда Фибоначчи }
Function fib(n : integer) : real;
var
f, f1, f2 : real;
i : integer;
begin
f1 := 1; f := 0;
for i := 1 to n do
begin
f2 := f1; f1 := f;
f := f1 + f2
end;
fib := f
end;
{----------------------------------------------------------------------------------------}
{ Процедура вычисления знач. аргумента и функции }
{ approach - приближение }
Procedure approach(a, b : real; n : integer; var
x2, y2 : real);
begin
x2 := a + (b - a)*fib(n - 1)/fib(n);
y2 := func(x2)
end;
begin
n := 3;
approach(a, b, n, x2, y2);
while abs(b - a) > e do
begin
x1 := a + b - x2; y1 := func(x1);
if (x2 > x1) and (y2 > y1)
then
begin
n := n + 1;
approach(a, b, n, x2, y2);
b := x2; x2 := x1; y2 := y1; goto 1
end;
if (x2 <= x1) and (y2 > y1)
then
begin
n := n + 1;
approach(a, b, n, x2, y2);
a := x2; x2 := x1; y2 := y1; goto 1
end;
if (x2 > x1) and (y2 < y1)
then
begin
n := n + 1;
approach(a, b, n, x2, y2);
a := x1; goto 1
end;
if (x2 <= x1) and (y2 <= y1)
then
begin
n := n + 1;
approach(a, b, n, x2, y2);
b := x1; goto 1
end;
n := n + 1;
approach(a, b, n, x2, y2);
1: end;
x := (a + b)/2;
end;
27. Процедура поиском минимума функции на промежутке с помощью “золотого сечения”.
Procedure mingold(a, b, e : real; var
x : real);
var
x1, x2, y1, y2 : real;
{----------------------------------------------------------------------------------------}
Function func(x : real):real;
begin
func := ????????????
end;
{----------------------------------------------------------------------------------------}
Function f1(a, b : real) : real;
begin
f1 := 0.618*a + 0.382*b
end;
{----------------------------------------------------------------------------------------}
Function f2(a, b : real) : real;
begin
f2 := 0.382*a+0.618*b
end;
{----------------------------------------------------------------------------------------}
begin
x1 := f1(a, b); y1 := func(x1);
x2 := f2(a, b); y2 := func(x2);
while abs(b - a) > e do
if y1<y2 then
begin
b := x2; x2 := x1; y2 := y1;
x1 := f1(a, b); y1 := func(x1)
end
else
begin
a := x1; x1 := x2; y1 := y2;
x2 := f2(a, b); y2 := func(x2)
end;
x := (a + b)/2
end;
28. Процедура решения неопределённых уравнений вида ax + by = c:
Procedure
The_equation(a, b, c : integer); {Решение уравнения ax + by = c}
label 1;
var
max, x, y, n : integer;
begin
if (nod(a, b) <> 1) and
(c mod nod(a, b) = 0)
then begin n:= nod(a,b); a := a div n; b := b div n; c := c div n end
else if (nod(a, b) <> 1) and (c mod nod(a, b) <> 0)
then
writeln('Уравнение не имеет решений');
if
abs(a) > abs(b) then max := abs(a) else max := abs(b);
for x := -max to max do
for y := -max to x do
begin
if (a*x + b*y = 1) and
(a > 0) and (b > 0)
then begin writeln('Решения уравнения x = ', x*c, '+', b,'*t, y = ', y*c, '-', a, '*t,');
writeln('где t - произвольное целое число'); goto 1 end;
if
(a*x + b*y = 1) and (a < 0) and (b > 0)
then begin writeln('Решения уравнения x = ', x*c, '+', b,'*t, y = ', y*c, ' ', a, '*t,');
writeln('где t - произвольное целое число'); goto 1 end;
if
(a*x + b*y = 1) and (a > 0) and (b < 0)
then begin writeln('Решения уравнения x = ', x*c, ' ', b,'*t, y = ', y*c, '-', a, '*t,');
writeln('где t - произвольное целое число'); goto 1 end;
if
(a*x + b*y = 1) and (a < 0) and (b < 0)
then begin writeln('Решения уравнения x = ', x*c, ' ', b,'*t, y = ', y*c, ' ', a, '*t,');
writeln('где t - произвольное целое число'); goto 1 end
end;
1: end;
Вычислить и округлить до ближайшего целого все числа
а также вычислить u0, u1, ..., u15 по формулам
174. Вычислить и вывести на экран положительные значения функции
175. Вычислить значения функции
176. Вычислить члены ряда
Определить a128, если известны r и а4.
178. Вычислить и вывести на печать значения членов ряда
179. Вычислить значения функции
180. Последовательность an принимает значения
Чему равен предел an при
181. Установите, имеет ли следующая последовательность un предел?
182. Показать, что последовательность
183. Установить имеет ли последовательность, заданная формулой n-го члена предел: а)
б)
Таким образом, xn+1 получается из xn по формуле
в)
Ответы
К заданию 3
Program Task3;
uses WinCrt;
var
n : integer;
y, eps : real;
{----------------------------------------------------------------------------------------}
Function
t(eps : real) : integer;
var
k : integer;
begin
k := -1;
repeat
eps := eps*10;
k := k + 1
until
eps > 1;
t := k
end;
{----------------------------------------------------------------------------------------}
Procedure
Element_succession(eps : real; var n : integer; var y : real);
var
k : integer;
begin
n := 1;
y := 1;
k := -1;
while abs(y - 2) >= eps do
begin
n := n + 1;
k := k*(-1);
y := 2 + k/n
end
end;
{----------------------------------------------------------------------------------------}
{ Основная программа }
begin
writeln('Введите любое положительное число');
write(' Можно даже очень малое '); readln(eps);
Element_succession(eps, n, y);
writeln('Искомый член последовательности ', y:6:t(eps));
writeln('Находится на ', n , '-ом месте')
end.
К
заданию 4
Program Task4;
uses
WinCrt;
var
i, j, n : integer;
k, k1 : longint;
yn, ym, eps : real;
{----------------------------------------------------------------------------------------}
Function
t(eps : real) : integer;
var
k : integer;
begin
k := -1;
repeat
eps := eps*10;
k := k + 1
until
eps > 1;
t := k
end;
{----------------------------------------------------------------------------------------}
begin
writeln('Введите любое положительное число ');
write('Можно даже очень малое '); readln(eps);
i := 1;
yn := 1/3;
k := 2;
while
abs(yn - 1) >= eps do
begin
i := i + 1;
k := k*2;
yn := (k - 1)/(k + 1)
end;
writeln('Условию |yn - 1| < ', eps:1:t(eps), ' удовлетворяет');
writeln('член последовательности yn = ', yn:6:t(eps), ',');
writeln('находящийся под номером ', i); writeln;
write('Введите номер члена последовательности ');
write('больше ', i, ' '); readln(n);
j := i; ym := yn;
k1 := k;
while
j <= n do
begin
j := j + 1;
k1 := k1*2;
ym := (k1 - 1)/(k1 + 1);
end;
if
abs(ym - 1) < eps
then
begin
write('Неравенство abs(1 - ',ym:6:t(eps),') <', eps:1:t(eps));
writeln(' выполняется')
end
else
begin
write('Неравенство abs(1-', ym:6:t(eps),') <', eps:1:t(eps));
writeln(' не выполняется')
end
end.
К заданию 5
Program Task5;
uses
WinCrt;
var
n : longint;
u, u1, eps : real;
{----------------------------------------------------------------------------------------}
Function
s(k : integer) : longint;
var
i, z : longint;
begin
z := 1;
for
i := 1 to k do z := 3*z;
s := z
end;
{----------------------------------------------------------------------------------------}
Function
t(eps : real) : integer;
var
k : integer;
begin
k := -1;
repeat
eps := eps*10;
k := k + 1
until
eps > 1;
t := k
end;
{----------------------------------------------------------------------------------------}
{ Основная программа }
begin
writeln('Задайте положительное число eps');
write(' Можно даже очень малое '); readln(eps);
u := 0;
n := 1;
repeat
u := u + 1/(s(n) + 1);
n := n + 1;
u1 := u + 1/(s(n) + 1);
until
abs(u1 - u) < eps;
writeln('Предел последовательности равен ', u1:6:t(eps));
writeln('С точностью до ', eps:1:t(eps))
end.