Задача 1
const
N = 5; { степень многочлена }
Type
{ тип для хранения коэффициентов многочлена }
TCoefs = array [0..N] of integer;
const
{ коэффициенты многочлена }
Coefs : TCoefs = ( -1, 5, 2, -2, -1, 3 );
Var
x : real; { значение аргумента }
y : real; { значение полинома }
{ Функция вычисления значения многочлена }
function Poly(x : real; const Coefs : TCoefs) : real;
var
i : integer;
res : real;
begin
res := 0;
for i:=N downto 0 do
res := res * x + Coefs[i];
Poly := res;
end;
begin
Write('Введите значение x: ');
ReadLn(x);
y := Poly(x, Coefs);
WriteLn('y = ', y:0:4);
end.
Задача 2
const
N = 10; { количество элементов массива }
Type
TArr = array [1..N] of integer;
const
{ коэффициенты многочлена }
Data : TArr = ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 );
Var
k : integer; { количество сдвигов }
i : integer; { параметр цикла }
{ Процедура циклического сдвига элементов }
procedure Rotate(k : integer; var Data : TArr);
var
e : integer;
i, j : integer;
begin
k := k mod N; { нормализация количества сдвигов }
for i := 1 to k div 2 do begin
e := Data[i];
Data[i] := Data[k-i+1];
Data[k-i+1] := e;
end;
for i := 1 to (n-k) div 2 do begin
e := Data[k+i];
Data[k+i] := Data[n-i+1];
Data[n-i+1] := e;
end;
for i := 1 to n div 2 do begin
e := Data[i];
Data[i] := Data[n-i+1];
Data[n-i+1] := e;
end;
end;
begin
repeat
Write('Введите количество сдвигов: ');
ReadLn(k);
until k > 0;
Rotate(k, Data);
for i:=1 to N do
Write(Data[i]:3);
WriteLn;
end.
Задача 3
const
n = 10;
Type
color = (white, red, black);
TColorArray = array[1..n] of color;
const
{ массив цветов }
Colors : TColorArray = (
white, red, black, black, red, white, red, black, white, red
);
{ названия цветов }
ColorNames : array[color] of string = ( 'white', 'red', 'black' );
var
i : integer;
Temp : color;
W, R, B : Integer;
begin
writeln('Исходный массив:');
for i:=1 to N do write(ColorNames[Colors[i]], ' ');
writeln;
{ метод 4-зон }
W := 0;
R := 0;
B := n + 1;
for i := 1 to n do
Case Colors[R+1] of
White : begin
Temp := colors[W+1];
Colors[W+1] := Colors[R+1];
Colors[R+1] := Temp;
W := W+1;
R := R+1;
end;
Red : R := R+1;
Black : begin
Temp := colors[B-1];
Colors[B-1] := Colors[R+1];
Colors[R+1] := Temp;
B := B-1;
end;
end;
writeln('Результат:');
for i:=1 to N do write(ColorNames[Colors[i]], ' ');
writeln;
end.
Задача 4
const
MAX = 100;
type
TArray = array [1..MAX] of integer;
var
I : integer;
k, l, m : integer;
X, Y, Z : TArray;
p1 : integer; { индекс элемента в массиве X }
p2 : integer; { индекс элемента в массиве Y }
p3 : integer; { индекс элемента в массиве Z }
begin
write('Количество элементов массива X: ');
readln(k);
writeln('Ввод элементов:');
for i:=1 to K do read(X[i]);
write('Количество элементов массива Y: ');
readln(L);
writeln('Ввод элементов:');
for i:=1 to L do read(Y[i]);
m := k + l; { количество элементов в массиве Z }
{ вывод исходных значений }
writeln('Массив X:');
for p1 := 1 to K do write(X[p1], ' ');
writeln;
writeln('Массив Y:');
for p2 := 1 to L do write(Y[p2], ' ');
writeln;
p1 := 1;
p2 := 1;
p3 := 1;
while (p1 <= K) and (p2 <= L) do
begin
if X[p1] < Y[p2] then begin
Z[p3] := X[p1];
p1 := p1 + 1;
end
else begin
Z[p3] := Y[p2];
p2 := p2 + 1;
end;
p3 := p3 + 1;
end;
{ копируем оставшиеся элементы из массива X }
while p1 <= K do
begin
Z[p3] := X[p1];
p1 := p1 + 1;
p3 := p3 + 1;
end;
{ копируем оставшиеся элементы из массива Y }
while p2 <= L do
begin
Z[p3] := Y[p2];
p2 := p2 + 1;
p3 := p3 + 1;
end;
writeln('Массив Z (результат слияния X и Y):');
for p3:=1 to M do write(Z[p3], ' ');
writeln;
end.
Задача 5.
const
MAX = 100;
type
TCoefs = array[0..MAX] of real;
var
N : integer;
I : integer;
A : TCoefs;
b : real;
s : real;
x : real;
kX : Integer;
kS : Real;
begin
repeat
write('Введите количество коэффициентов: ');
readln(N);
until (n > 0) and (n <= 100);
writeln('Ввод коэффициентов');
for i:=1 to N do read(A[i]);
write('Введите значение b: ');
readln(b);
{sort(A, n);}
s := 0;
For i := 1 to n do s := s + a[i];
kX := -n;
kS := s;
a[0] := -(abs(b)-kS)/n - 1;
a[n+1] := (abs(b)+kS)/n + 1;
For i := 0 to n do begin
If kX <> 0 then begin
x := (b - kS)/kX;
If (x > a[i]) and (x <= a[i+1])
then writeln(' X = ', x:0:4)
end
else if b = kS
then Writeln(' X in (', a[i], ',',a[i+1], ']');
kX := kX + 2;
kS := kS - 2*a[i+1]
end;
end.
Задача 6.
const
MAX = 100; { максимальное количество отрезков }
type
{ тип - отрезок }
Segment = record
a, b : integer;
end;
{ тип - массив отрезков }
Segments = array[1..MAX] of Segment;
{ Нормализация отрезка s }
procedure norm(var s : Segment);
var
a : integer;
begin
if s.a > s.b then
begin
a := s.a;
s.a := s.b;
s.b := a;
end;
end;
{ Функция определяющая пересечение отрезков s1 и s2 }
function intersec(s1, s2 : Segment) : boolean;
begin
if s1.b < s2.a then
intersec := False
else
if s1.a > s2.b then
intersec := False
Else
intersec := True
end;
var
N : integer; { количество отрезков }
I, j : integer;
Segs : Segments; { массив отрезков }
k : integer; { количество пересекаемых отрезков для i-го отрезка }
Kmax : integer; { максимальное значение для k }
begin
repeat
write('Количество отрезков N: ');
readln(N);
until (n > 1) and (n <= MAX);
{ ввод отрезков }
for i:=1 to N do
begin
write('Введите значения a и b для отрезка ', i, ': ');
readln(Segs[i].a, Segs[i].b); { ввод отрезка }
norm(Segs[i]); { нормализация отрезка }
end;
{ вывод введенных отрезков }
for i:=1 to N do write('(', Segs[i].a, ', ', Segs[i].b, ') ');
writeln;
Kmax := 0; { начальное значение для максимального k }
for i:=1 to N do
begin
k := 0; { количество пересекаемых отрезков для i-го отрезка }
{ цикл нахождения k для i-го отрезка }
for j:=1 to N do
if intersec(Segs[i], Segs[j]) then
k := k + 1;
if k > Kmax then Kmax := k;
end;
writeln('Максимальное число k равно ', Kmax);
end.
Задача 8.
const
MAX = 10;
type
Matr = array[1..MAX, 1..MAX] of integer;
var
n : integer;