Примеры решения задач на языке Паскаль

Задачи на языке Паскаль
Задача 1
Напишите программу ввода трёх произвольных чисел X, Y и Z с клавиатуры. Если X больше Z, то вывести на экран сумму X и Y, иначе вывести на экран значение Z.
Решение:
program Project1;
var
x,y,z,rez:real;
begin
{Ввод значений с клавиатуры}
Write('Введите X:'); readln(x);
Write('Введите Y:'); readln(y);
Write('Введите Z:'); readln(z);
{Сравним значения по условию задачи}
if xz then rez:=x+y else rez:=z;
{Выводим результат на экран}
Writeln(rez:0:2);
readln; {Задержка закрытия программы}
end.

Задача 2
Напишите программу ввода с клавиатуры трёх произвольных чисел X,Y,Z. Программа должна найти наименьшее число из введённых, и вывести его на экран.
Решение:
program Project1;
var
x,y,z,min:real;
begin
Write ('Введите X:'); readln(x);
Write ('Введите Y:'); readln(y);
Write ('Введите Z:'); readln(z);
min:=x;
if miny then min:=y;
if minz then min:=z;
Writeln('Минимум=',min);
Readln;
end.
Задача 3
Длина прямоугольного участка земли равна X метров,а ширина равна Y метров. Напишите программу вычисления количества досок для забора на заданном участке, если ширина доски равна 10 сантиметров. 
Решение:
program Project1;
var
x,y,rez:real;
begin
Write('Введите длину X:'); readln(x);
Write('Введите ширину Y:'); readln(y);
rez:=2*x+2*y;
rez:=rez/0.1;
Writeln('Число досок=',rez:0:2);
Readln;
end.

Задача 4
Чиновник, ежемесячно берёт взятки в размере X рублей. Величина Х непостоянная и колеблется от 0 до 150000 рублей. Автомобиль BMW 3, который хочет купить на взятки чиновник, стоит 1700000 рублей. Напишите программу, которая вычислит, сколько месяцев потребуется чиновнику на сбор нужной суммы.
Решение:
program Project1;
var
x:longint;
mes:integer;
begin
mes:=0;
x:=0;
{Организуем цикл, который завершится при сумме взяток равной или больше 1700000}
Repeat
{Организуем случайные числа для величины X}
randomize;
x:=x+random(150000);
Writeln(x);
{Организуем счетчик месяцев}
mes:=mes+1; {inc(mes)}
until x=1700000;
Writeln('Месяц=',mes);
Readln;
end.
Задача 5
Напишите программу, которая вычисляет произведение членов последовательности, кратных 5. Программа получает на вход целые числа, количество введенных чисел неизвестно, последовательность чисел заканчивается числом 0 ( 0-признак окончания ввода, не входит в последовательность).
Количество чисел не превышает 1000. Введенные числа по модулю не превышают 30000.
Программа должна вывести одно число: произведение членов последовательности, кратных 5.
Решение:
program Ls1;
var
x,z:integer;
n:integer;
label L1; {Метка безусловного перехода}
begin
{clrscr}{Отчистить экран - убрать кавычки в Turbo Pascal}
z:=1;
{Создаем цикл с максимальным числом вводимых значений}
for n:=1 to 1000 do
begin
{Получаем данные с клавиатуры}
L1: write ('Введите X:'); readln(x);
{Проверяем условие на вводимый диапазон значений}
if (xor (x30000) then {Если за пределами диапазона, то перейти к вводу другого значения - к метке L1}
begin
Writeln('Input error!');
goto L1;
end;
{Если признак окончания ввода, то прервать цикл}
if x=0 then break else
{если введенное число кратно 5, то наращиваем произведение членов z. Функция frac возвращает остаток от деления x/5}
if frac(x/5)=0 then z:=z*x;
end;
{Проверяем, были ли во водимых значениях числа кратные 5, если нет выводим 0 иначе выводим произведение}
if z=1 then z:=0;
Writeln ('Результат=',z);
Readln;
end.

Задача 6
Дана матрица А размерностью 5х5.
Заполнить ее следующим образом:
1 2 3 4 5
2 3 4 5 1
3 4 5 1 2
4 5 1 2 3
5 1 2 3 4
и вывести на экран.
Решение:
program Chislo;
var A:array[1..5,1..5] of Byte;
i,j:integer;
begin
for i:=1 to 5 do
for j:=1 to 5 do
A[i,j]:=1+(i+j-2) mod 5;
for i:=1 to 5 do
begin
for j:=1 to 5 do
Write(A[i,j]:2);
WriteLn;
end;{for}
end.

Задача 7
Дана матрица А размерностью 3х3, состоящая из целых чисел.
Найти разность между максимальным и минимальным элементами данной матрицы.
Решение:
program Promegytok;
var A:array[1..3,1..3]of integer;
i,j,Max,Min:integer;
begin
if i:=1 to 3 do
if j:=1 to 3 do
begin Write('A[',i,',',j,']=');
Readln(A[i,j]);
end;
Max:=A[1,1];
Min:=A[1,1];
for i:=1 to 3 do
for j:=1 to 3 do
begin
if Max if Min end;
Writeln(Max-Min);
end.

Задача 8
Дан Массив Х(N). Найти в массиве количество отрицательных и положительных элементов. Если больше отрицательных, то положительные элементы заменяются на нули. В противном случае - отрицательные.
Решение:
program p1; 
var A:array[1..100] of integer; {переменная массива } 
i,n:integer;{переменная цикла и размера массива} 
countPOSIT,countNEG:integer; 
begin 
write ('Введите размер массива A: '); {вывод на экран фразы } 
readln (n); {считываем с клавы размер массива} 
for i:=1 to n do begin 
write ('A[',i,']='); readln (A[i]); end;{ считываем с клавы элементы массива } 
write ('Вот введенный вами массив A: '); {вывод на экран фразы } 
for i:=1 to n do write (A[i],' '); {вывод на экран элементов массива } 
writeln; 
countPOSIT:=0;countNEG:=0; {обнуляем переменные кол-ва } 
for i:=1 to n do {циклом идём по массиву } 
if A[i]then 
inc(countPOSIT) {+1 для положительных} 
else 
inc(countNEG); {+1 для отрицательных} 
if countNEGcountPOSIT then {Если больше отрицательных } 
begin 
for i:=1 to n do 
if A[i]0 then A[i]:=0 {то положительные элементы заменяются на нули} 
end 
else {В противном случае } 
begin 
for i:=1 to n do 
if A[i]then A[i]:=0 {то отрицательные элементы заменяются на нули} 
end; 
write ('Вот преобразованный массив A: '); {вывод на экран фразы } 
for i:=1 to n do write (A[i],' '); {вывод на экран элементов массива } 
readln; 
end.

Задача 9
Составить функцию, которая в одномерном массиве подсчитывает количество чисел, превышающих среднее геометрическое значение всех чисел массива. Если среди элементов есть нулевые или отрицательные элементы, среднее геометрическое считать равным нулю. Использовать составленную функцию для определения в матрице D(l, m), lm.
Решение:
program PascalGuru;
type vector=array [1..14] of real;
{******************************************}
function sr_geom(x:vector;n:integer):real; {функция нахождения среднего геометрического в массиве}
var p,k:real;
i:integer;
begin
p:=1;
k:=0;
for i:=1 to n do
if(x[i]then
begin
sr_geom :=0;
exit;
end
else
begin
p:=p*x[i];
k:= k+1;
end;
sr_geom := exp(ln(p)*1/k);
end;
{******************************************}
var D:array [1..12,1..14] of integer; {инициализация переменных}
i,j,count,min,max:integer;
tA :vector;
tC :array [1..14] of integer;
sg:real;
begin
{ниже ввод элементов массива}
for i:=1 to 12 do
for j:=1 to 14 do D[i,j]:=-1+random(32);{begin write('D[',i,',',j,']='); readln(D[i,j]); end;}
{ниже вывод элементов массива на экран}
for i:=1 to 12 do begin writeln;
for j:=1 to 14 do write (D[i,j]:8); end;
{******************************************}
writeln;writeln;
for i:=1 to 12 do {пройдёмся по всем строкам массива}
begin
{определение среденего геом}
for j:=1 to 14 do tA[j]:=D[i,j];
sg:=sr_geom(tA,14) ;
{определение количества элементов, превышающих среднее геометрическое значение элементов строки}
count:=0;
for j:=1 to 14 do
if D[i,j]sg then inc(count);
tC[i]:=count;
writeln(i,' stroka ~ s.g.= ',sg:0:2,' count= ',count) ; {вывод количества элементов на экран}
end;
{******************************************}
{ниже определение МАКС и МИН элемента}
min:=tC[1];
max:=tC[1];
for i:=2 to 12 do
begin
if tC[i]max then max:=tC[i];
if tC[i]min then min:=tC[i];
end;
{ниже вывод результата на экран}
writeln;
writeln('minCount = ',min);
writeln('maxCount = ',max);
readln;
end.