Разноуровневые задачи Pascal

Простой уровень.

Задача 1. Дана сторона квадрата a. Найти его периметр P = 4∗a.

program Begin1;

var

P,a: Real;

begin

Write('Введите значение стороны квадрата: ');

Readln(a);

P:=4*a;

Writeln('Периметр квадрата равен: ', P);

end.

Задача 2. Дано расстояние L в сантиметрах. Используя операцию деления нацело, найти количество полных метров в нем (1 метр = 100 см).

program Integer1;

var

L,Lm: Integer;

begin

Write('Введите длину в сантиметрах: ');

Readln(L);

Lm:=L div 100;

Writeln('В этом расстоянии полных метров: ', Lm);

end.

Задача 3. Дано целое число A. Проверить истинность высказывания: «Число A является положительным».

program Boolean1;

var

A: Real;

begin

Write('Введите число A: ');

Readln(A);

Writeln(A0);

end.

Задача 4. Арифметические действия над числами пронумерованы следующим образом: 1 — сложение, 2 — вычитание, 3 — умножение, 4 — деление. Дан номер действия N (целое число в диапазоне 1–4) и вещественные числа A и B (B не равно 0). Выполнить над числами указанное действие и вывести результат.

program Case5;

var

N,A,B:Integer;

begin

Write('Введите номер действия: ');

Readln(N);

Write('Введите число A: ');

Readln(A);

Write('Введите число B: ');

Readln(B);

Case N of

1: Writeln(A+B);

2: Writeln(A-B);

3: Writeln(A*B);

4: Writeln(A/B);

end;

end.

Задача 5. Даны целые числа K и N (N 0). Вывести N раз число K.

program For1;

var

K,N, i:Integer;

begin

Write('Введите N: ');

Readln(N);

Write('Введите K: ');

Readln(K);

For i:=1 to N do Writeln(K);

end.

Средний уровень.

Задача 1. Даны три точки A, B, C на числовой оси. Точка C расположена между точками A и B. Найти произведение длин отрезков AC и BC.

program Begin18;

var

A,B,C,AC,BC,product: Real;

begin

Write('Введите значение точки A: ');

Readln(A);

Write('Введите значение точки B: ');

Readln(B);

Write('Введите значение точки C: ');

Readln(C);

AC:=Abs(A-C);

Writeln('Расстояние отрезка AC равно: ',AC);

BC:=Abs(C-B);

Writeln('Расстояние отрезка BC равно: ',BC);

product:=AC*BC;

Writeln('Произведение отрезков AC и BC равно: ',product);

end.

Задача 2. Дано трехзначное число. Вывести число, полученное при перестановке цифр сотен и десятков исходного числа (например, 123 перейдет в 213).

program Integer15;

var

A, Res: Integer;

begin

Write('Введите трёхзначное число: ');

Readln(A);

Res:=(A mod 10) + ((A mod 100) div 10 )*100+ (A div 100)*10;

//*

Writeln('Число, полученное при перестановке цифр: ',Res);

end.

Задача 3. Даны три числа. Найти сумму двух наибольших из них.

program If5;

var

A, B, C: Real;

begin

Write('Введите первое число: ');

Readln (A);

Write('Введите второе число: ');

Readln (B);

Write('Введите третье число: ');

Readln (C);

if (Aand (Athen Writeln(B+C)

else if (Band (Bthen Writeln(A+C)

else if (Cand (Cthen Writeln(A+B);

end.

Задача 4. Дано целое число N ( 0). Найти сумму 1 + 1/2 + 1/3 + … + 1/N (вещественное число).

program For10;

var

N,i:Integer;

Rez:Real;

begin

Write('Введите N: ');

Readln(N);

rez:=0;

For i:=1 to N do Rez:=Rez+1/i;

Writeln(Rez);

end.

Задача 5. Дано целое число K и набор ненулевых целых чисел; признак его завершения — число 0. Вывести номер первого числа в наборе, большего K. Если таких чисел нет, то вывести 0.

program Series15;

var

num,i,R,K:Integer;

begin

write('Введите K : ');

readln(K);

R:=1;

i:=0;

num:=0;

while(R0) do

begin

i:=i+1;

write('Введите ',i,' число из набора :');

Readln(R);

if ( RK) and (num=0) and (R0) then num:=i;

end;

Writeln(num);

end.

Задача 6. Дано целое число N и набор из N целых чисел. Найти номер первого экстремального (то есть минимального или максимального) элемента из данного набора.

program MinMax10;

var

i,N,Ni,Min,Max,MinNum,MaxNum:Integer;

begin

Write('N:');

Readln(N);

for i:=1 to N do

begin

Write(i,' элемент:');

Readln(Ni);

if i=1 then

begin

Min:=Ni;

Max:=Ni;

MinNum:=i;

MaxNum:=i;

end;

if Nithen

begin

Min:=Ni;

MinNum:=i;

end;

if NiMax then

begin

Max:=Ni;

MaxNum:=i;

end;

end;

if MinNum then Writeln(MinNum)

Else Writeln(MaxNum);

end.

Задача 7. Дано целое число N (1 ≤ N ≤ 26). Вывести N последних строчных (то есть маленьких) букв латинского алфавита в обратном порядке (начиная с буквы «z»).

program String5;

var

N,i:byte;

C:char;

begin

Write('N:');

readln (N);

for i:=122 downto 122-N+1 do Writeln(chr(i));

end.

Задача 8. Дано вещественное число X (|X| 0). Найти значение выражения X — X²/2 + X³/3 -…+ (-1)^N-1*X^N/N. Полученное число является приближенным значением функции ln в точке 1 + X.

program For25;

var

X,Rez,pow:Real;

N, i :Integer;

begin

Write('Введите X: ');

Readln(X);

Write('Введите N: ');

Readln(N);

Rez:=0;

pow:=1;

For i:=1 to N do

begin

pow:=pow*X;

Rez:=Rez+pow/i;

pow:=pow*(-1);

end;

Writeln(Rez);

end.

Задача 9. Найдите количество четных цифр в десятичной записи числа n.

program z2;

var

x, y, k:integer;

Begin

readln (x);

k:=0;

while x0 do

begin

y:=x mod 10;

if y mod 2 =0 then k:=k+1;

x:=x div 10;

end;

writeln ('k=',k);

end.

Задача 10. Дано два целых положительных числа: a и b. Требуется написать программу, которая находит цифру, на которую оканчивается число a^b.

program z7;

var

a,b,d:integer;

c:byte;

Begin

writeln ('Введите a'); readln (a);

writeln ('Введите b'); readln (b);

d:=a;

if b=1 then writeln (a)

else

begin

for c:=2 to b do

d:=d*a;

d:=d mod 10;

end;

writeln (d);

end.

Сложный уровень.

Задача 1. Напишите программу, которая вычисляет произведение членов последовательности, кратных 5. Программа получает на вход целые числа, количество введённых чисел неизвестно, последовательность чисел заканчивается числом 0 (0 - признак окончания ввода, не входит в последовательность).
Количество чисел не превышает 1000. Введённые числа по модулю не превышают 30000.
Программа должна вывести одно число: произведение членов последовательности, кратных 5.

program Ls1;

var

x, z: integer; { Переменные для ввода значений x и вычисления произведения z}

n : integer; {Счётчик цикла}

label L1; {Метка безусловного перехода}

begin

{clrscr} {Очистить экран - убрать кавычки в Turbo Pascal}

z:= 1; {Начальное значение результата}

{Создаём цикл с максимальным числом вводимых значений}

for n := 1 to 1000 do

begin {начало тела цикла}

{Получаем данные с клавиатуры}

L1: write('Vvedi X: '); readln(x);

{Проверяем условие на вводимый диапазон значений}

if (x 30000) or (x 30000) then {Если за пределами диапазона, то перейти к вводу другого зачения - к метке L1}

begin

writeln('Input error!');

goto L1;

end;5

{Если признак окончания ввода, то прервать цикл}

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('Result = ', z);

readln;

end.

Задача 2. Дано число типа byte. Проверить, является ли палиндромом его двоичное представление с учетом того, что сохранены старшие нули. Пример таких чисел: 102 (т. к. 102 = 0110 0110₂, а это палиндром), 129 (129 = 1000 0001₂) и т. д.

program z14;

var

n, a, b, c, d: byte;

Begin

readln (n);

a := n mod 2;

n := n div 2;

b := n mod 2;

n := n div 2;

c := n mod 2;

n := n div 2;

d := n mod 2;

n := n div 2;

a := 8 * a + 4 * b + 2 * c + d;

writeln (n = a);

end.

Задача 3. Сообщество роботов живет по следующим законам: один раз в год они объединяются в полностью укомплектованные группы по 3 или 5 роботов (причем число групп из 3 роботов - максимально возможное). За год группа из 3 роботов собирает 5, а группа из 5 - 9 новых собратьев. Каждый робот живет 3 года после сборки. Известно начальное количество роботов (К7), все они только что собраны. Определить сколько роботов будет через N лет. 

var k,i,n,p:integer;

s,x,y:longint;

r:array [1..3] of longint;

begin

write('Начальное количество роботов k='); readln(k);

write('Число лет n='); readln(n);

r[1]:=k; r[2]:=0; r[3]:=0; s:=k;

for i:=1 to n do

begin

x:=s div 3;

p:=s mod 3;

if p=0 then y:=0

else if p=1 then begin x:=x-3; y:=2 end

else begin x:=x-1; y:=1 end;

r[3]:=r[2]; r[2]:=r[1]; r[1]:=5*x+9*y;

s:=r[1]+r[2]+r[3];

end;

writeln('s=',s)

end.

Задача 4. На шахматной доске размером 4x4 клетки расставить 4 ладьи так, чтобы они не угрожали друг другу. Определить все такие расстановки (всего их будет 24). 

const n=4;

var x:array [1..n] of integer;

i:integer;

procedure printm;

var i:integer;

begin

for i:=1 to n do write(x[i],' ');

writeln;

end;

procedure swap(var a,b:integer);

var v:integer;

begin

v:=a; a:=b; b:=v

end;

procedure perest(k:integer);

var i:integer;

begin

if k=n-1 then printm

else

for i:=k+1 to n do

begin

swap(x[k+1],x[i]);

perest(k+1);

swap(x[k+1],x[i]);

end;

end;

begin

for i:=1 to n do x[i]:=i;

perest(0);

end.

Задача 5. Вывести на экран цифры числа 3¹⁰⁰⁰. Если попытаться получить число непосредственно умножением, компьютер выдаст сообщение об ошибке. 

const stp=1000;

var i,j,k,prn,x:integer;

a:array [1..500] of integer;

begin

a[500]:=3; prn:=0;

for i:=2 to stp do

for j:=500 downto 1 do

begin

x:=a[j]*3;

a[j]:=(x+prn) mod 10;

prn:=(x+prn) div 10;

end;

k:=1; while (a[k]=0) do k:=k+1;

for i:=k to 500 do write(a[i]:1);

writeln

end.