var p:real {ные формальные.При решении}.


МИНИСТЕРСТВА ВЫСШЕГО И СРЕДНЕГО И СПЕЦИАЛЬНОГО ОБРАЗОВАНИЯ РЕСПУБЛИКИ УЗБЕКИСТАН
ФЕРГАНСКИЙ ПЕДАГОГИЧЕСКИЙ
КОЛЛЕДЖ
Cборник задач по программирование и
их решение.
06794500
Одобрено кафедры «Аниқ ва табиий фанлар» в качестве учебного пособия для студентов по направление 3141620 «Ахборот ва компьютер саводхонлигини ўргатувчи тўгарак раҳбари»
№______ от __________2010 года
«Задачник программирование и их решение на языке паскаль» предназначен для студентов колледжей и академический лицеев обучающий предмет программирование. Он содержит 250 учебных заданий, охватывающих все основные разделы базового курса программирования: от скалярных типов и управляющих операторов до сложных структур данных и рекурсивных алгоритмов.
Решение изложена на языке Pascal.
В книге использованы материалы из книги и сайтов по направление программирование на языке Паскаль
Автор идеи: Преподаватель «Информатика и ВТ» Муллажонов Р.О.
Сўзбоши.
Ўзбекистон мустақилликка эришгандан сўнг, ҳамма соҳалар каби таълим соҳасида ҳам катта ишлар олиб борилди ва борилмоқда. Айниқса янги технологияларни таълим соҳасига олиб кирилиши, таълим соҳасида яхши натижаларни бермоқда.
Замонавий компьютерларни таълимга жорий этилиши натижасида ўқувчилар улардан фойдалана олиш кўникмаларни ҳосил қилишмоқда. Касб-ҳунар коллежлари ва академик лицейларда “Информатика” фанига катта эътибор берилган.
Дастурлаш асослари ҳусусан турли дастурлаш тиллари ҳақидаги тушинчалар шу фан орқали берилади. Айниқса замонавий алгоритмик тилларнинг асосларидан бири Паскал тилининг ўқитилиши, ўқувчиларда мантиқий фикрлашни кўникмаларини ҳосил қилишда катта аҳамиятга эга. Ўқувчиларнинг дастурлаш борасида билимларинг кенгайтириш, дастурлаш асосларинигина билиш эмас балки улардан фойдалана билиш кўникмаларини ҳосил қилиш учун уларда турли масалаларни ечиш муҳум ахамият касб этади.
Ўқувчиларга дастурлаш сабоқларини беришим борасида шунга амин бўлдимки, ўқувчилар дастурлаш асосларини билиши компьютерлардан фойдалананишда қўл келади.
Дастурлаш асослари қизиқарли фанлардан ҳисобланиб, ўқувчилар турли масалаларни ечишида турли усуллардан фойдаланишларига тўғри келади. Бунда эса ўқувчидан бошқа фанлардан олган билимлари ёрдам беради. Фандаги масалалар аниқ ва ижтимоий фанлар билан узвий боғланган бўлиб, уларнинг ечиш учун ўқувчидан бу билимни билишини талаб этади
Масала ечишда ўқувчиларнинг қийналиши алгоритмик тилнинг имкониятларни яхши билмасликлари ва ечиш йўлларининг турили бўлиши мукин эканлигини эътиборга олмасликлари сабабдир, шу сабабли ушбу тўпламни тўплаш фикри туғилди. Тўплам(рус тилида бўлсада унча қийинчилик туғдирмайди денган умиддаман) 250дан ортиқ масалаларни ўз ичига олган бўлиб, улар турли фанларга доир. Уларнинг Паскал дастурлаш тилида оптимал ечимлари келтирилган. Аминманки, бу тўплам ўқувчиларни дастурлаш билмларини кенгайтиришларига катта ёрдам беради.
08128000
© Муллажонов Рузимат Олимович [email protected]Муллифнинг руҳсатисиз ксерео нусха олиш ва ундан комерция ишларида фойдаланиш таъқиқланади.
§ 1
1. Найти значение выражения 1*1+2*2+...+n*n.
2. Сумма.
3. Составить из двух таблиц 3-ю упорядоченную по возраст.
4. Найти максимальное число из трёх.
5. Найти максимальное число из четырёх.
6. Количество букв "а" в тексте.
7. Среднее арифметическое таблицы.
8. Степень числа.
9. Факториал числа.
10. Подсчет кол-ва часов, минут и секунд в данном числе суток.
11. Составить программу проверки есть ли в тексте буква "s".
12. Найти значение выражения.
13. Найти значение выражения.
14. Определить лежит ли точка а на прямой y=kx+l.
15. Расположить слова в порядке убывания их длины в предложении.
16. Найти кол-во отрицательных элементов таблицы.
17. Найти максимальный элемент таблицы а[1..10].
18. Получить элементы таблицы, которые находятся между max и min.
19. Яв-ся ли треугольник равнобедренным.
20. Лежит ли точка на прямой.
21. Проверить существует ли строгое чередование.
22. Пересекаются ли отрезки.
23. Является ли n-угольник выпуклым.
24. Определить расстояния от точки до прямой.
25. Найти площадь треугольника (используя формулу Герона).
26. Даны координаты диагонали прямоугольника. Найти его площадь.
27. Найти номер максимального элемента таблицы а[1..10].
28. Составить программу упорядочивания элементов таблицы.29. Составить программу вычисления (min(a,c)-min(a,b)/(5+min(b,c))
30. Является ли число b делителем числа a.
31. Составить программу определяющую яв-ся ли число простым.
32. Составить программу нахождения НОД и НОК двух чисел a и b.
33. Составить программу решения квадратного ур-я.
34. Найти сумму элементов прямоугольной таблицы размером [n:m]
35. Найти мaксимальный элемент прямоугольной таблицы размером [n:m].
36. Найти число.
37. Найти максимальный элемент таблицы и их кол-во.
38. Дано предложение, определить кол-во слов в нём.
39. Дан текст, определить кол-во слов "кот".
40. Определить является ли данное слово перевертышем.
41. Найти количество различных чисел в одномерной таблице.
42. Каждую букву слова A поместить в таблицу.
43. Найти наименьшее однозначное число х удовлетворяющее условию x*x*x-x*x=n.
44. Составить алгоритм нахождения суммы цифр числа.
45. Найти двузначное число сумма кубов цифр которого равна n.
46. Получить из слова a, вычеркивание некоторого кол-ва букв, слово b.
47. Заданы 2 точки. Определить какой из отрезков AO или BO образует больший угол с осью OX.
48. Записать положительные элементы таблицы А в таблицу В, а отрицательные элементы таблицы А в табл С.
49. Яв-ся ли перевёртышем число.
50. Построить таблицу С в которой сначала размещаются все элементы А, затем все элементы таблицы В.
51. Решить систему ур-ий {ax+by+c=0 и a1x+b1y+c1=0.
52. Определить площадь и периметр треугольника.
53. Дана таблица содержащая группы одинаковых подряд идущих чисел. Вывести на экран "число - кол-во чисел в группе, число - кол-во чисел в группе, ... "
54. Определить площадь четырёхугольника.
55. Разбить выпуклый n-угольник на треугольники диагоналями так, чтобы...
56. Определить стоимость телеграммы.
57. Дана таблица a[1..n]. Ввести таблицу b[1..n] отбросив из а каждый второй элемент.
58. Дана таблица a[1..n] из целых чисел. Поставить сначала четные, а потом нечетные элементы.
59. Найти наибольшее кол-во одинаковых элементов.
60. Дана точка. Лежит ли она в кольце.
61. Примеры типов величин.
62. Табличные величины. Одномерный массив.
63. Табличные величины. Двумерный массив.
64. На оси Оx заданы N точек с координатами x1,x2,...,xn. Найти такую точку Z сумма расстояний от которой до данных точек минимальная.
65. Имеется n банок с целочисленными объёмами v1,v2,v3...,vn литров, пустой сосуд и кран с водой. Можно ли с помощью этих банок налить в сосуд ровно v литров воды. Решение: Обозначим s=nod(v1,v2...,vn). Если v делится нацело на s, то в сосуд с помощью банок можно налить v литров воды, иначе - нет.
66. Дана последовательность натуральных чисел. Найти наименьшее натуральное число, которое отсутствует в последовательности.
67. Дан выпуклый n-угольник и точка (х1,у1). Определить: а) является ли точка вершиной; б) принадлежит ли точка n-угольнику.
68. (1) Решение систем линейных уравнений методом Гаусса.
69. (2) Решение систем линейных уравнений подбором.
70. (3) Решение систем линейных уравнений методом Гаусса.
program z1;
{ Найти значение выражения 1*1+2*2+...+n*n }
var n,s,i : integer;
begin
write('n = ');
readln(n);
s:=0;
for i:=1 to n do
s:=s+i*i;
writeln('s = ',s);
readln;
end.
program z2;
{ Найти сумму. }
uses crt;
var a,b,s : integer;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
s:=a+b;
write('сумма s=',s);
readln;
end.
program z3;
{ Даны две таб. Составить из них 3 таб. упорядоченную по возраст. }
uses crt;
var a : array [1..10] of longint;
b : array [1..20] of longint;
c : array [1..30] of longint;
n,m,k,l,i,j,min : longint;
begin
clrscr;
write('введ.кол.эл.таб.а n=');readln(n);
write('введ.кол.эл.таб.b m=');readln(m);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to m do
begin
write('b[',i,']=');readln(b[i]);
end;
k:=n+m;{кол.эл.таб.с}
(*заносим эл.таб.а в таб.с*)
for i:=1 to n do c[i]:=a[i];
(*заносим эл.таб.в в таб.с*)
for i:=1 to m do c[i+n]:=b[i];
(*упорядочим таб.с[1..k] по возраст*)
for i:=1 to k-1 do
begin
l:=i;{номер мин.}min:=c[i];
for j:=i+1 to k do
if c[j]<min then
begin
min:=c[j];l:=j;
end;
c[l]:=c[i];{меняем местами 1-й и мин.эл.}
c[i]:=min;
end;
for i:=1 to k do writeln('Ответ:c[',i,']=',c[i]);
readln;
end.
program z4;
{ Найти максимальное число из трёх. }
uses crt;
var a,b,c,max : integer;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
if (a>b) and (a>c) then max:=a;
if (b>a) and (b>c) then max:=b;
if (c>a) and (b<c) then max:=c;
write('max=',max);
readln;
end.
program z5;
{ Найти наибольшее из четырёх чисел. }
uses crt;
var a,b,c,d,max,max1,max2 : real;
procedure bol2( aa,bb : real; var maxmax : real );
begin
if aa>bb then maxmax:=aa
else maxmax:=bb;
end;
begin
clrscr;
write('введте a,b,c,d через пробел ');
readln(a,b,c,d);
bol2(a,b,max1);
bol2(c,d,max2);
bol2(max1,max2,max);
writeln('max=',max);
readln;
end.
program z6;
{ Кол-во букв "а" в тексте. }
uses crt;
var d : string[30];
n,i : integer;
begin
write('наберите текст ');
readln(d);
n:=0;
for i:=1 to length(d) do
if d[i]='а' then n:=n+1;
write('В тексте а=',n);
readln;
end.
program z7;
{ Сост. программу определения сред. ариф. таб. а}
uses crt;
var a : array [1..10] of integer;
s : real;
sum,n,i : integer;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');
readln(a[i]);
end;
sum:=0;
for i:=1 to n do
sum:=sum+a[i];
s:=sum/n;
writeln('ср ариф= ',s);
readln;
end.
program z8;
uses crt;
{ Записать программу возвед. числа а в степень n }
var a,n,i,p : integer;
begin
clrscr;
write('n=');readln(n);
write('a=');readln(a);
p:=1;
for i:=1 to n do p:=p*a;
write('p=',p);
readln;
end.
program z9;
uses crt;
{ Сост. прог. выч. факториала числа n.
Пример: 5!=1*2*3*4*5
7!=1*2*3*4*5*6*7 }
var f,n,i : integer;
begin
clrscr;
write('n=');readln(n);
f:=1;
for i:=1 to n do f:=f*i;
write('f=',f);
readln;
end.
program z10;
{ Написать программу подсчета кол-ва часов, минут и секунд в данном числе суток }
uses crt;
var syt,has,min,sec : extended;
begin
clrscr;
write('сут = ');
readln(syt);
has:=24*syt;
min:=60*has;
sec:=60*min;
writeln('часов : ',has:0:0);
writeln('минут : ',min:0:0);
writeln('секунд : ',sec:0:0);
readln;
end.
program z11;
{ Составить программу проверки есть ли в тексте буква "s" }
uses crt;
var t : string;
i : integer;
ot : boolean;
begin
clrscr;
writeln('введите текст:');readln(t);
for i:=1 to length(t) do
if t[i]='s' then ot:=true;
if ot=true then write('да')
else write('нет');
readln;
end.
program z12;
{ Найти значение выражения ( -натуральное число, а>0, х>0,
у=1+(1/(1+(1/1+...1+1/x))..) ) n знаков "+" }
uses crt;
var x,n,i : integer;
y : real;
begin
clrscr;
write('n=');readln(n);
write('x=');readln(x);
y:=x;
for i:=1 to n do y:=1+1/y;
write('y=',y);
readln;
end.
program z13;
{ Найти значение выражения ( -нат. число, а>0, х>0,
f=sqr(a+sqr(a+sqr(a+..sqr(a))..) ) n знаков "+" }
uses crt;
var a,n,i : integer;
f : real;
begin
clrscr;
write('n=');readln(n);
write('a=');readln(a);
f:=a;
for i:=1 to n do f:=a+sqr(f);
write('f = ',f);
readln;
end.
program z14;
{ Определить лежит ли точка а на прямой y=kx+l }
uses crt;
var x,y,l,k : integer;
begin
clrscr;
write('x=');readln(x);
write('y=');readln(y);
write('k=');readln(k);
write('l=');readln(l);
if y=k*x+l then write('Да')
else write('Нет');
readln;
end.
program z15;
{ Дано предложение составить программу располагающую
слова в порядке убывания длины слов }
uses crt;
type slov = array [1..10] of string;
var p,b : string;
s : slov;
i,j,l : integer;
q : boolean;
procedure maxdl( ii,jj : integer;ss : slov; var ll : integer );
var t:integer;m:string;
begin
m:=ss[ii]; { считает max(t) }
ll:=ii; { l-номер max }
for t:=ii+1 to jj do
if length(m)<length(ss[t]) then
begin
m:=ss[t];
ll:=t;
end;
end;
begin
clrscr;
write('текст p=');readln(p);
j:=1;
for i:=1 to length(p) do
begin
b:=p[i];
if b=' ' then j:=j+1
else s[j]:=s[j]+b;{ склеивание слова и заносим в таб }
end;
b:='';
for i:=1 to j do
begin
maxdl(i,j,s,l); { находим номер мах элм }
b:=s[i]; { меняем местами мах элм: }
s[i]:=s[l];
s[l]:=b;
end;
for i:=1 to j do write(s[i],' ');
readln;
end.
program z16;
{ Дана вещ. таблица a[1..n].
Найти кол-во отрицательных элементов таблицы. }
uses crt;
var k,n,i : longint;
a : array [1..10] of longint;
begin
clrscr;
write('n = ');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n do
if a[i]<0 then inc(k);
write('k = ',k);
readln;
end.
program z17;
{ Найти максимальный элемент таблицы а[1..10] }
uses crt;
var a : array [1..10] of longint;
max,i,n : longint;
begin
clrscr;
write('n = ');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
max:=a[1];
for i:=2 to n do
if a[i]>max then max:=a[i];
write('max = ',max);
readln;
end.
program z18;
{ Дана таб a[1..n] из целых чисел. Получить элементы, которые находятся между max и min}
uses crt;
var a,b : array [1..10]of longint;
f,i,j,n,m,max,min,k,l : longint;
label met;
begin
clrscr;
write('кол-во элм. табл. n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
max:=a[1];k:=1;
for i:=2 to n do
if a[i]>max then
begin
max:=a[i];k:=i;
end;
min:=a[1];l:=1;
for i:=2 to n do
if a[i]<min then
begin
min:=a[i];l:=i;
end;
if k<l then
begin
for f:=k+1 to l-1 do
begin
j:=j+1;b[j]:=a[f];m:=m+1;
end;
goto met;
end;
if l<k then
begin
for f:=l+1 to k-1 do
begin
j:=j+1;b[j]:=a[f];m:=m+1;
end;
end;
met : writeln;
for j:=1 to m do writeln(b[j]);
readln;
end.
program z19;
{ Даны координаты вершин треугольника ABC A(x1;y1), B(x2;y2), C(x3;y3) яв-ся ли треугольник равнобедренным }
uses crt;
var x1,x2,x3,y1,y2,y3,a,b,c : real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
a:=sqrt(sqr(x1-x2)+sqr(y1-y2));
b:=sqrt(sqr(x2-x3)+sqr(y2-y3));
c:=sqrt(sqr(x1-x3)+sqr(y1-y3));
if (a=b)or(a=c)or(b=c) then write('равнобедренный')
else write('не равнобедренный');
readln;
end.
program z20;
{ Составить программу для определения лежит ли точка (x3;y3), на прямой проходящей через точки (x1;y1),C(x2;y2)}
uses crt;
var x1,x2,x3,y1,y2,y3 : real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
if (x3-x1)*(y2-y1)-(y3-y1)*(x2-x1)=0
then write('лежит')
else write('не лежит');
readln;
end.
program z21;
{ Дана таб. а[1..n],сост. из нулей и единиц.
Проверить сущ. ли строгое чередование }
uses crt;
var a:array[1..10]of integer;
flag,i,k,n:integer;
begin
clrscr;
write('кол-во элм. таб. n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
i:=1;
while i<=n-1 do
begin
flag:=0;
if ((a[i]=1)and(a[i+1]=0))or((a[i]=0)and(a[i+1]=1))
then flag:=1
else begin
write('нет');flag:=0;
readln;halt;
end;
i:=i+2;
end;
if flag=1 then write('чередование существует');
readln;
end.
program z22;
{ Пересекаются ли отрезки задаными координатами (x1;y1),(x2;y2),(x3;y3),(x4;y4).}
uses crt;
var x1,x2,x3,x4,y1,y2,y3,y4,
l,l1,l2,p,p1,p2 : real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
write('x4=');readln(x4);
write('y4=');readln(y4);
if x1<x2 then l1:=x1 else l1:=x2;
if x3<x4 then l2:=x3 else l2:=x4;
if l1>l2 then l:=l1 else l:=l2;
if x1>x2 then p1:=x1 else p1:=x2;
if x3>x4 then p2:=x3 else p2:=x4;
if p1>p2 then p:=p2 else p:=p1;
if l<=p then write('пересекаются')
else write('не пересекаются');
readln;
end.
program z23;
{ Определить яв-ся ли n-угольник выпуклым Ввод состоит из n отрезков, n>3 и n<10 }
uses crt;
var m,n,k,i,j : integer;
ot : boolean;
x,y : array[1..10] of integer;
z1,z2 : real;
procedure haltproc;
begin
writeln('Неверные данные');
writeln('n >= 3');
readln;
halt;
end;
begin
clrscr;
write('n=');readln(n);
if n<3 then haltproc;
for i:=1 to n do
begin
write('x[',i,']=');readln(x[i]);
write('y[',i,']=');readln(y[i]);
end;
ot:=true;
for i:=1 to n do
begin
j:=i+1;
k:=j+1;
if k=n+1 then k:=1;
if i=n then j:=1;
m:=i-1;
if m=n-1 then k:=2;
if i=1 then m:=n;
z1:=(x[m]-x[i])*(y[j]-y[i])-(y[m]-y[i])*(x[j]-x[i]);
z2:=(x[k]-x[i])*(y[j]-y[i])-(y[k]-y[i])*(x[j]-x[i]);
if z1*z2<0 then ot:=false;
end;
if ot=true then write('выпуклый')
else write('не выпуклый');
readln;
end.
program z24;
{ Составить программу для определения расстояния от точки (x3;y3) до прямой проходящей через точки (x1;y1),(x2;y2) }
uses crt;
var x1,x2,x3,y1,y2,y3,a,b,c,d,t : real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
a:=y2-y1;
b:=x1-x2;
c:=-x1*(y2-y1)+y1*(x2-x1);
t:=sqrt(a*a+b*b);
d:=abs((a*x3+b*y3+c)/t);
write('расстояние =',d);
readln;
end.
program z25;
{ Треугольник задан координатами вершин (x1;y1),(x2;y2),(x3;y3).
Найти площадь треугольника (используя формулу Герона) }
uses crt;
var x1,x2,x3,y1,y2,y3,a,b,c,s,p : real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
a:=sqrt(sqr(x1-x2)+sqr(y1-y2));
b:=sqrt(sqr(x2-x3)+sqr(y2-y3));
c:=sqrt(sqr(x3-x1)+sqr(y1-y3));
p:=(a+b+c)/2;
s:=sqrt(p*(p-a)*(p-b)*(p-c));
write('s=',s);
readln;
end.
program z26;
{ Даны координаты диагонали прямоугольника.
Найти его площадь. }
uses crt;
var x1,x2,y1,y2,s,a,b : real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
a:=abs(x2-x1);
b:=abs(y2-y1);
s:=a*b;
write('s=',s);
readln;
end.
program z27;
{ Найти номер максимального элемента таблицы а[1..10] }
uses crt;
var a : array [1..100] of longint;
k,i,n,max : longint;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
max:=a[1];k:=1;
for i:=2 to n do
if a[i]>max then
begin
max:=a[i];k:=i;
end;
write('номер: ',k);
readln;
end.
program z28;
{ Дан линейный массив из n эл-тов Составить программу упорядочивания элементов таблицы.}
uses crt;
var a : array [1..100] of longint;
j,i,n,max : longint;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n-1 do
for j:=i+1 to n do
if a[j]>a[i] then
begin
max:=a[j];
a[j]:=a[i];
a[i]:=max;
end;
for i:=1 to n do writeln('a[',i,']=',a[i] );
readln;
end.
program z29;
{ Даны числа a,b,c. Составить программу вычисления (min(a,c)-min(a,b)/(5+min(b,c)) }
uses crt;
var a,b,c,m1,m2,m3,w:real;
procedure min(var d,e,m : real);
begin
if d>e then m:=e else m:=d;
end;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
min(a,c,m1);
min(a,b,m2);
min(b,c,m3);
w:=(m1-m2)/(5+m3);
writeln('ОТВЕТ:',w);
readln;
end.
program z30;
{ Яв-ся ли число b делителем числа a. }
uses crt;
var a,b : integer;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
if a mod b=0 then write('делится')
else write('не делится');
readln;
end.
program z31;
{ Составить программу определяющую яв-ся ли число простым. }
uses crt;
var a : real;
p : boolean;
i : integer;
procedure haltproc;
begin
writeln('неверные данные');
writeln('a>=2');readln;
halt;
end;
begin
clrscr;
write('a=');readln(a);
if a<2 then haltproc;
if a=2 then begin
writeln2('простое');
readln;halt;
end;
p:=true;
for i:=2 to trunc(a-1) do
if a/i=trunc(a/i) then p:=false;
if p=true
then write('простое')
else write('не простое');
readln;
end.
program z32;
{ Составить программу нахождения НОД и НОК двух чисел a и b. }
uses crt;
var a,b,p : real;
nod,nok : real;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
p:=a*b;
while a<>b do
if a>b then a:=a-b
else b:=b-a;
nod:=a;
nok:=p/nod;
writeln('НОД:',a);
write('НОК:',nok);
readln;
end.
program z33;
{ Составить программу решения квадратного ур-я. }
uses crt;
var a,b,c,x1,x2,d : real;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
d:=sqr(b)-4*a*c;
if d>0 then
begin
x1:=(-b+sqrt(d))/(2*a);
x2:=(-b-sqrt(d))/(2*a);
writeln('x1=',x1);
writeln('x2=',x2);
end;
if d=0 then
begin
x1:=(-b)/(2*a);
writeln('x=',x1);
end;
if d<0 then write('корней нет');
readln;
end.
program z34;
{ Найти сумму элементов прямоугольной таблицы размером [n:m] }
uses crt;
var a : array [1..10,1..10] of longint;
i,j,n,m,s : longint;
begin
clrscr;
write('кол-во строк : ');readln(m);
write('кол-во столбцов : ');readln(n);
for i:=1 to m do
for j:=1 to n do
begin
write('a[',i,',',i,']=');readln(a[i,j]);
end;
for i:=1 to m do
for j:=1 to n do s:=s+a[i,j];
write('Сумма:',s);
readln;
end.
program z35;
{ Найти maксимальный элемент прямоугольной таблицы размером [n:m].}
uses crt;
var a : array [1..10,1..10] of longint;
i,j,n,m,max : longint;
begin
clrscr;
write('кол-во строк : ');readln(m);
write('кол-во столбцов : ');readln(n);
for i:=1 to m do
for j:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
max:=a[1,1];
for i:=1 to m do
for j:=1 to n do
if max<a[i,j] then max:=a[i,j];
write('max=',max);
readln;
end.
program z36;
{ Цифры числа хранятся в таблице b. b[1] содержит цифру
высшего разряда a=a, a2, a3...an. Найти число. }
var n,i,a : integer;
b : array[1..6] of integer;
begin
write('Введите кол-во цифр числа n=');
readln(n);
for i:=1 to n do
begin
write('b[',i,']=');readln(b[i]);
end;
a:=0;
for i:=1 to n do a:=a*10+b[i];
write('Число:',a);
readln;
end.
program z37;
{ Найти макс. элм. таб. и кол-во макс. элементов }
uses crt;
var a : array [1..10] of longint;
k,n,i,max : longint;
begin
clrscr;
write('кол-во элм таб n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
max:=a[1];
for i:=2 to n do if a[i]>max then max:=a[i];
for i:=1 to n do if a[i]=max then k:=k+1;
writeln('max=',max);
writeln('кол-во: ',k);
readln;
end.
program z38;
{ Дано предложение, определить кол-во слов в нём. }
uses crt;
var tec : string;
l,i,n : longint;
begin
clrscr;
write('введите текст:');readln(tec);
l:=length(tec)+1;tec[l]:=' ';
for i:=1 to l do if tec[i]=' 'then n:=n+1;
write('В тексте ',n,' слов');
readln;
end.
program z39;
{ Дан текст, определить кол-во слов "кот". }
uses crt;
var a : string;
i,m,k,n : longint;
begin
clrscr;
write('введите текст ');readln(a);
k:=0;m:=length(a);
a:=a[m]+' ';
for i:=1 to m do if a[i+2]='кот'then inc(k);
write('В тексте ',k,' слов кот');
readln;
end.
program z40;
{ Определить является ли данное слово перевертышем. }
uses crt;
var a,b,c : string;
i : longint;
begin
clrscr;
write('Введите слово: ');readln(a);
b:='';
for i:=1 to length(a) do b:=a[i]+b;{ переворачиваем слово }
if a=b then write('перевертыш')
else write('не перевертыш');
readln;
end.
program z41;
{Найти количество различных чисел в одномерной таблице}
(*МЕТОД:Каждый следующий элемент сравниваем со всемипредыдущими и если равных ему среди предыдущих не будетто flag оставляем неизменным и счетчик к увеличиваем*)
uses crt;
var a : array [1..10] of longint;
i,j,k,flag,n : integer;
begin
clrscr;
write('введите кол.эл.таб. а n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
k:=1;{Пусть разных чисел нет т.е.все одинак.}
for i:=2 to n do
begin
flag:=0;j:=i-1;{j -стоит перед i}
while (flag=0) and (j>=1) do
begin
if a[i]=a[j] then flag:=1;{решение}
j:=j-1;
end;
if flag=0 then k:=k+1;
end;
write('Колич.различных чисел к=',k);
readln;
end.
program z42;
{ Каждую букву слова A поместить в таблицу. }
uses crt;
var a : string;
n,i : longint;
b : array [1..10] of string;
begin
clrscr;
write('введите текст:');readln(a);
n:=length(a);
for i:=1 to n do b[i]:=a[i];
for i:=1 to n do
begin
writeln('b[',i,']=',a[i]);
end;
readln;
end.
program z43;
{ Найти наименьшее однозначное число х удолв условию x*x*x-x*x=n. }
uses crt;
var x,n : longint;
ot : boolean;
begin
clrscr;
write('n = ');readln(n);
ot:=false;
x:=1;
while (x*x*x-x*x<>n) do
begin
inc(x);
if x*x*x-x*x=n then ot:=true;
end;
if ot=false then write('нет')
else write('x=',x);
readln;
end.
program z44;
{ Составить алгоритм нахождения суммы цифр числа. }
uses crt;
var i,n,k,s : longint;
b : array [1..10] of integer;
begin
clrscr;
write('введите число ');readln(n);
k:=1;
while n>=1 do
begin
b[k]:=trunc(n) mod 10; {элм. таб}
n:=trunc(n)div 10;
k:=k+1;
end;
for i:=1 to k do s:=s+b[i];
write('s=',s);
readln;
end.
program z45;
{ Найти двузначное число сумма кубов цифр которого равна n. }
uses crt;
var j,i : integer;
z,n : longint;
begin
clrscr;
write('n=');readln(n);
for j:=1 to 9 do
for i:=1 to 9 do
if i*i*i+j*j*j=n then z:=10*i+j;
write('z=',z);
readln;
end.
program z46;
{ Заданы 2 слова a и b. Можно ли получить из слова a, вычеркивание некоторого кол-ва букв, слово b }
uses crt;
var i,j,m,n : integer;
a,b,d,e : string;
begin
clrscr;
write('введите текст a=');readln(a);
write('введите текст b=');readln(b);
n:=length(a);m:=length(b);e:=b;
if n<m then halt;
for i:=1 to n do
for j:=1 to m do
if a[i]=b[j] then begin
d:=d+a[i];
delete(b,j,1);
end;
if d=e then write('Да')
else write('Нет');
readln;
end.
program z47;
{ Заданы 2 точки. Определить какой из отрезков AO или BO образует больший угол с осью OX. }
uses crt;
var x1,x2,y1,y2 : longint;
a,b,a1,b1 : real;
begin
clrscr;
writeln('коорд. точки А');
write('x1=');readln(x1);
write('y1=');readln(y1);
writeln('коорд. точки В');
write('x2=');readln(x2);
write('y2=');readln(y2);
a:=sqrt(x1*x1+y1*y1);
b:=sqrt(x2*x2+y2*y2);
a1:=y1/a;b1:=y2/b;
if a1>b1
then write('отрезок OA обр. бол. угол ')
else write('отрезок OB обр. бол. угол');
readln;
end.
program z48;
{ Дана таблица А. Записать '+' элементы таблицы А в таблицу В '-' элементы таблицы
А в табл С.}
uses crt;
var a,b,c : array [1..10] of longint;
n,k,i,l : longint;
begin
clrscr;
write('n = ');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n do
if a[i]<0 then begin
inc(k);b[k]:=a[i];
end
else begin
inc(l);c[l]:=a[i];
end;
writeln('положительное:');
for i:=1 to l do writeln('c[',i,']=',c[i]);
writeln('отрицательное:');
for i:=1 to k do writeln('b[',i,']=',b[i]);
readln;
end.
program z49;
{ Яв-ся ли перевёртышем число. }
uses crt;
var a,b : string;
n,i : longint;
begin
clrscr;
write('введите число n=');readln(n);
str(n,a);
b:='';
for i:=1 to length(a) do b:=a[i]+b;
if a=b then write('перевёртыш')
else write('не перевёртыш');
readln;
end.
program z50;
{Даны таблицы А[1..n] ,В[1..m]. Построить таблицу С в которой сначала размещаются все элм-ты А, затем все элм-ты табл В. }
uses crt;
var a : array [1..5,1..2] of string;
m,j,i,g : longint;
b,c : array [1..5] of string;
begin
clrscr;
writeln('введ i-фамилии, j-пол');
for i:=1 to 5 do
for j:=1 to 2 do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
for i:=1 to 5 do
begin
if a[i,2]='м' then begin
m:=m+1;
b[m]:=a[i,1];
end;
if a[i,2]='ж' then begin
g:=g+1;
c[g]:=a[i,1];
end;
end;
writeln('мальчики:');
for i:=1 to m do writeln(b[m]);
writeln('девочки:');
for i:=1 to g do writeln(c[g]);
readln;
end.
program z51;
{ Решить систему ур-ий {ax+by+c=0 и a1x+b1y+c1=0 }
uses crt;
var flag,a,a1,b,b1,c,c1,x,y,s,s1 : longint;
begin
clrscr;
flag:=0;
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
write('a1=');readln(a1);
write('b1=');readln(b1);
write('c1=');readln(c1);
for x:=-10 to 10 do
for y:=-10 to 10 do
begin
s:=a*x+b*y+c;
s1:=a1*x+b1*y+c1;
if (s=0)and(s1=0)
then begin
flag:=1;
writeln('x=',x,' y=',y);
end;
end;
if flag=0 then write('в заданной области реш. нет');
readln;
end.
program z52;
{Даны 3 точки x1,y1,x2,y2,x3,y3 Составить программу для опред. площади и периметра треуг. используя процедуру для опред расстояния между двумя точками}
uses crt;
var x1,x2,x3,y1,y2,y3,s,p,
a,b,c : real;
procedure rasst( a1,b1,a2,b2 : real;var r : real );
begin
r:=sqrt(sqr(a1-a2)+sqr(b1-b2));
end;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
rasst(x1,y1,x2,y2,a);
rasst(x2,y2,x3,y3,b);
rasst(x3,y3,x1,y1,c);
p:=a+b+c;
p:=p/2;
s:=sqrt(p*(p-a)*(p-b)*(p-c));
writeln('s=',s);
readln;
end.
program z53;
{Дана лин. таб содерж. группы одинаковых подряд идущих положит. чисел.Вывести на экран "число-кол-во чисел в группе,число-кол-во чисел в группе, ... "}
uses crt;
var a : array [1..100] of longint; {кол.эл.не больше 100}
m,n,i : longint;
begin
clrscr;
write('введите кол-во элм. таб. a,n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
i:=1; m:=1;(*кол. одинак.эл.*)
while i<=n do
begin
if a[i]<>a[i+1]
then begin
(*если подряд идущие эл.разные то печать стоящий первым
и их кол. брать новое i для выполнения команды пока и счетчик m
опять взять =1 для подсчета других чисел*)
write('число: ',a[i]);
writeln(' кол-во ',m);
i:=i+1;
m:=1;
end {сдесь ; не ставить}
else
(*если подряд идущие эл.одинаковые то их считаем и берем
новое i для выполнения команды пока*)
begin
i:=i+1;
m:=m+1;
end;
end;
readln;
end.
program z54;
{Даны 4 точки x1,y1,x2,y2,x3,y3,x4,y4 Составить программу для опред. площади четырёхугольника,используя процедуру нахождения площади}
uses crt;
var x1,x2,x3,x4,y1,y2,y3,y4 : real;
c1,c2,c : real;
procedure treyg(a1,b1,a2,b2,a3,b3:real;var s:real);
var a,b,c,p:real;
{исходные данные а1,в1,а2,в2,а3,в3-формальные.Перед
вып.процедуры им присваивается фактические параметры
Процедура вырабатывает значения а,в,с,р,s.Перед их
именами в описании стоит служебное слово var}
begin
a:=sqrt(sqr(a1-a2)+sqr(b1-b2));
b:=sqrt(sqr(a2-a3)+sqr(b2-b3));
c:=sqrt(sqr(a3-a1)+sqr(b3-b1));
p:=(a+b+c)/2;
s:=sqrt(p*(p-a)*(p-b)*(p-c));
end;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
write('x4=');readln(x4);
write('y4=');readln(y4);
treyg(x1,y1,x2,y2,x3,y3,c1);
treyg(x3,y3,x4,y4,x1,y1,c2);
c:=c1+c2;
writeln('ОТВЕТ:',c);
readln;
end.
program z55;
{Выпуклый n-угольник(n>3) задаётся коорд. своих вершин в порядке обхода. Разбить его на треуг. диагоналями, не пересек.,так,чтобы сумма длин диагоналей была минимальной}
uses crt;
const nmax=10;
var x,y:array [1..nmax] of longint;
s : array [1..nmax] of real;
n,i,a,j : integer;
min : real;
q : boolean;
function rast(n1,n2:integer):real;
begin
rast:=sqrt(sqr(x[n1]-x[n2])+sqr(y[n1]-y[n2]));
end;
begin
clrscr;
repeat;
q:=true;
write('кол-во углов n=');readln(n);
if n>nmax then
begin
writeln('слишком большое n (n<=',nmax,').');
q:=false;
end;
if n<4 then
begin
if n<3 then writeln('Такой фигуры не существует (n>3).') else
writeln('В треугольнике нет диагоналей!!');
q:=false;
end;
until q;
for i:=1 to n do
begin
write('x[',i,']=');readln(x[i]);
write('y[',i,']=');readln(y[i]);
writeln;
end;
for i:=1 to nmax do s[i]:=0;
for i:=1 to n do
begin
for j:=1 to n-3 do
begin
a:=i+j+1;
if a>n then a:=a-n;
s[i]:=s[i]+rast(i,a);
end;
end;
min:=s[1];
a:=1;
for i:=1 to n do
begin
if min>s[i] then
begin
a:=i;
min:=s[i];
end;
end;
writeln('Ответ: из точки № ',a);
readln;
end.
program z56;
{Ввести текст телеграммы и стоимость одного слова.Опред. стоимость телеграммы При вводе текста запятые обознач. словом ЗПТ,точки-словом Т,других знаков припинания не исп.}
uses crt;
var a : string;
i,s,c : longint;
begin
clrscr;
write('Введите текст ');readln(a);
write('Стоимость одного слова ');readln(c);
s:=0;
repeat;
for i:=1 to length(a)do
if (a[i]=' ') or (a[i]+a[i+1]+a[i+2]='ЗПТ')
then s:=s+c;
until a[i]='Т';
s:=s+c;
write('стоимость телеграммы: ',s);
readln;
end.
program z57;
{Дана лин. таб. a[1..n].Ввести табл. b[1..n] отбросив из а каждый второй элм}
uses crt;
var a,b : array [1..10] of longint;
k,i,j,n : integer;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
k:=0; i:=1;
while i<n+1 do
begin
k:=k+1;
b[k]:=a[i];
i:=i+2;
end;
for j:=1 to k do writeln('ОТВЕТ: a[',j,']=',b[j]);
readln;
end.
program z58;
{Дана табл a[1..n] из целых чисел.Поставить сначала четные,а потом нечетные элм }
uses crt;
var a,b : array [1..10] of longint;
m,i,j,n : longint;
begin
clrscr;
write('кол-во элм. таб. n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
j:=0;m:=0;
for i:=1 to n do
begin
if a[i]mod 2=0
then
begin
j:=j+1;
b[j]:=a[i];
end
else
begin
m:=m+1;
b[n+1-m]:=a[i];
end;
end;
for j:=1 to n do
writeln('a[',j,']=',b[j]);
readln;
end.
program z59;
{ Найти наибольшее кол-во одинаковых элементов. }
uses crt;
var a,b : array [1..10] of longint;
k,i,j,min,max,n,m,s : longint;
begin
clrscr;
write('кол-во элм. табл. n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n-1 do
begin
min:=a[i];k:=i;
for j:=i+1 to n do
if a[j]<min then
begin
min:=a[j];
k:=j;
end;
a[k]:=a[i];
a[i]:=min;
end;
k:=0;s:=1;i:=1;
while i<=n-1 do
if a[i]=a[i+1]
then
begin
s:=s+1;
i:=i+1;
end
else
begin
k:=k+1;
b[k]:=s;
i:=i+1;
s:=1;
end;
max:=b[1];
for i:=2 to k do
if b[i]>max then max:=b[i];
write('наибольшее кол-во одинаковых элм.: ',max);
readln;
end.
program z60;
{ Дана точка. Лежит ли она в кольце. }
uses crt;
var x,y,r1,r2,a,b : real;
procedure haltpr;
begin
writeln('Неверные данные');
write('r1<r2');
readln;halt;
end;
begin
clrscr;
write('координаты центра окр. a=');readln(a);
write('координаты центра окр. b=');readln(b);
write('x='); readln( x);
write('y='); readln( y);
write('r1=');readln(r1);
write('r2=');readln(r2);
if r1>r2 then haltpr;
if (sqr(x-a)+sqr(y-b)<sqr(r2)) and (sqr(x-a)+sqr(y-b)>sqr(r1))
then write('лежит')
else write('не лежит');
readln;
end.
program z61;
uses crt;
{Примеры типов величин}
var a : integer; { целый тип от -32768 до 32767 }
b,c : real; { вещественный }
d : longint; { длинное целое число от -2147483648 до 2147483647 }
e : byte; { целый тип длинной в один байт то есть от 0 до 255 }
s : string; { литерный тип длиной 255 символов }
f : char; { литерный тип длиной в один символ }
begin
a:=123;
b:=213.34534;
d:=12387273;
e:=123;
s:='qgjhfghfgdfghdfjg';
f:=s[1];{ в результате с f='q' }
writeln(a,' ',b);
writeln(d);
writeln(e);
writeln(s);
writeln(f);
readln;
end.
program z62;
uses crt;
{Табличные величины. Однмерный массив.}
var a : array [1..100] of integer;{ массив 100 элементов типа integer }
n,i,max,sum : integer;
{ Задача: Дан целочисленный массив А имеющий n элементов (n<=100)
найти сумму элементов массива а так же максимальный элемент}
begin
clrscr;
write('n=');
readln(n);
{ввод элементов массива}
for i:=1 to n do
begin
write('A[',i,']=');
readln(a[i]);
end;
{подсчёт суммы}
sum:=0;
for i:=1 to n do
sum:=sum+a[i];
{поиск максимального элемента}
max:=a[1];
for i:=2 to n do
if a[i]>max then max:=a[i];
{вывод результатов}
writeln('сумма=',sum);
writeln('максимальный элемент=',max);
readln;
end.
program z63;
uses crt;
{Табличные величины. Двумерный массив.}
var a : array [1..100,1..100] of integer;{ квадратный массив 100х100 с
элементами типа integer}
b : array [1..100] of integer;{см. задачу №62}
i,j,n,m,min,max : integer;
{Задача: Дана целочисленная прямоугольная таблица размером MxN. Найти среди максимальных элементов строк минимальный}
begin
clrscr;
write('Количество строк=');
readln(m);
write('Количество столбцов в строке=');
readln(n);
{Ввод таблицы}
for i:=1 to m do
begin
writeln(i,'-ая строка:');
for j:=1 to n do
begin
write(' ',j,'-ый столбец = ');
readln(a[i,j]);
end;
end;
{поиск максимумов в строках}
for i:=1 to m do
begin
max:=a[i,1];
for j:=2 to n do if a[i,j]>max then max:=a[i,j];
b[i]:=max;
end;
{поиск минимального в полученной таблице}
min:=b[1];
for i:=2 to m do if b[i]<min then min:=b[i];
{Вывод результатов}
writeln('Ответ=',min);
readln;
end.
program z64;
{ На оси Оx заданы N точек с координатами x1,x2,...,xn. Найти такую точку Z сумма расстояний от которой до данных точек минимальная.}
uses crt;
var d,i,j,m : longint;
a : array [1..100] of longint;
begin
clrscr;
write('Введите кол-во точек:');readln(D);
for i:=1 to D do
begin
write('x',i,'=');readln(a[i]);
end;
for i:=1 to D-1 do
for j:=i+1 to D do
if a[i]>a[j] then begin
m:=a[i];
a[i]:=a[j];
a[j]:=m;
end;
if d mod 2=0
then write('Z между ',a[d div 2],' и ',a[d div 2+1])
else write('Z=',a[d div 2+1]);
readln;
end.
program z65;
{Имеется n банок с целочисленными объёмами v1,v2,v3...,vn литров,пустой сосуд и кран с водой.Можно ли с помощью этих банок налить в сосуд ровно v литров воды.
Решение:Обозначим s=nod(v1,v2...,vn)
Если v делится нацело на s,то в сосуд с помощью банок можно налить v литров воды,иначе- нет}
uses crt;
var i,n,v,nod2:integer;
a:array[1..10]of integer;
procedure nod(a,b:integer;var nd:integer);
begin
while a<>b do
begin
if a>b
then a:=a-b
else b:=b-a;
end;
nd:=a;
end;
begin
clrscr;
write('введите кол-во банок n=');readln(n);
writeln('введите объёмы банок');
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end; write('введите объём сосуда v=');readln(v);
for i:=1 to n-1 do
nod(a[i],a[i+1],a[i+1]);
if v mod a[i+1]=0
then write('ДА')
else write('НЕТ');
readln;
end.
program z66;
{ Дана последовательность натуральных чисел Найти наименьшее нат.число,которое отсутствует в последовательности }
uses crt;
var n,n1,n2,ii,i,j:longint;
m,a:string;er:integer;
begin
clrscr;
write('Введите последовательность:');readln(a);
n:=length(a);
for i:=1 to n-1 do
for j:=i+1 to n do
begin
val(a[i],n1,er);
val(a[j],n2,er);
if n1>n2 then begin
m:=a[i];
a[i]:=a[j];
a[j]:=m[1];
end;
end;
for i:=1 to n do
begin
val(a[i],ii,er);
if ii<>i then begin
write(i);
readln;halt;
end;
end;
write('НЕТ');
readln;
end.
program z67;
{ Дан выпуклый n-угольник и точка(х1,у1) Определить а)является ли точка вершиной б)принадлежит ли точка n-угольнику }
uses crt;
var x,y:array[1..30]of integer;
a,b,c,plo1,plo2,s:real;
i,j,k,n,x1,y1,fl,ii:integer;
procedure ger(a1,b1,c1:real;var s1:real);
var p:real;
begin
p:=(a1+b1+c1)/2;
s1:=sqrt(p*(p-a1)*(p-b1)*(p-c1));
end;
procedure rasst(a1,b1,a2,b2:integer;var c1:real);
begin
c1:=sqrt(sqr(a2-a1)+sqr(b2-b1));
end;
begin
clrscr;
write('Виедите координаты точки через пробел:');
readln(x1,y1);
write('Количество углов n=');readln(n);
for i:=1 to n do
begin
write('x',i,'=');readln(x[i]);
write('y',i,'=');readln(y[i]);
end;
for i:=1 to n-2 do
begin
j:=i+1;
k:=j+1;
rasst(x[1],y[1],x[j],y[j],a);
rasst(x[1],y[1],x[k],y[k],b);
rasst(x[j],y[j],x[k],y[k],c);
ger(a,b,c,s);
plo1:=plo1+s;
end;
for i:=1 to n do
begin
if i=n then ii:=1
else ii:=i+1;
rasst(x1,y1,x[i],y[i],a);
rasst(x1,y1,x[ii],y[ii],b);
rasst(x[i],y[i],x[ii],y[ii],c);
ger(a,b,c,s);
plo2:=plo2+s;
end;
for i:=1 to n do if(x[i]=x1)and(y[i]=y1)then fl:=1;
if fl=1 then writeln('a)Да точка является вершиной')
else writeln('a)Нет точка не является вершиной');
if round(plo1)=round(plo2)then writeln('б)Да точка принадежит n-угольнику')
else writeln('б)Нет точка не принадежит n-угольнику');
writeln('S1=',plo1,'S2=',plo2);
readln;
end.
{Решение систем линейных уравнений методом Гаусса Автор: Алексей Безродный }
Uses CRT;
Const maxn = 10;Type Data = Real;
Matrix = Array[1..maxn, 1..maxn] of Data;
Vector = Array[1..maxn] of Data;
{ Процедура ввода расширенной матрицы системы }
Procedure ReadSystem(n: Integer; var a: Matrix; var b: Vector);
Var i,j,r: Integer;
Begin
r:= WhereY;
GotoXY(2, r);
Write('A');
For i := 1 to n do begin
GotoXY(i*6+2, r);Write(i);
GotoXY(1, r+i+1);Write(i:2);
end;
GotoXY((n+1)*6+2, r);
Write('b');
For i := 1 to n do begin
For j := 1 to n do begin
GotoXY(j * 6 + 2, r + i + 1);
Read(a[i, j]);
end;
GotoXY((n + 1) * 6 + 2, r + i + 1);
Read(b[i]);
end;
End;
{ Процедура вывода результатов }
Procedure WriteX(n :Integer; x: Vector);
Var
i: Integer;
Begin
For i := 1 to n do
Writeln('x', i, ' = ', x[i]);
End;
{ Функция, реализующая метод Гаусса }
Function Gauss(n: Integer; a: Matrix; b: Vector; var x:Vector): Boolean;
Var
i, j, k, l: Integer;
q, m, t: Data;
Begin
For k := 1 to n - 1 do begin
{ Ищем строку l с максимальным элементом в k-ом столбце}
l := 0;
m := 0;
For i := k to n do
If Abs(a[i, k]) > m then begin
m := Abs(a[i, k]);
l := i;
end;
{ Если у всех строк от k до n элемент в k-м столбце нулевой, то система не имеет однозначного решения }
If l = 0 then begin
Gauss := false;
Exit;
end;
{ Меняем местом l-ую строку с k-ой }
If l <> k then begin
For j := 1 to n do begin
t := a[k, j];
a[k, j] := a[l, j];
a[l, j] := t;
end;
t := b[k];
b[k] := b[l];
b[l] := t;
end;
{ Преобразуем матрицу }
For i := k + 1 to n do begin
q := a[i, k] / a[k, k];
For j := 1 to n do
If j = k then
a[i, j] := 0
else
a[i, j] := a[i, j] - q * a[k, j];
b[i] := b[i] - q * b[k];
end;
end;
{ Вычисляем решение }
x[n] := b[n] / a[n, n];
For i := n - 1 downto 1 do begin
t := 0;
For j := 1 to n-i do
t := t + a[i, i + j] * x[i + j];
x[i] := (1 / a[i, i]) * (b[i] - t);
end;
Gauss := true;
End;
Var
n, i: Integer;
a: Matrix ;
b, x: Vector;
Begin
ClrScr;
Writeln('Программа решения систем линейных уравнений по методу Гаусса');
Writeln;
Writeln('Введите порядок матрицы системы (макс. 10)');
Repeat
Write('>');
Read(n);
Until (n > 0) and (n <= maxn);
Writeln;
Writeln('Введите расширенную матрицу системы');
ReadSystem(n, a, b);
Writeln;
If Gauss(n, a, b, x) then begin
Writeln('Результат вычислений по методу Гаусса');
WriteX(n, x);
end
else
Writeln('Данную систему невозможно решить по методу Гаусса');
Writeln;
End.
program z69;
{Решение систем линейных уравнений подбором}
uses crt;
var a:array[1..10,1..10]of longint;
b1,b2,b3,b4,i,j:longint;
x1,x2,x3,x4:integer;
begin
clrscr;
writeln('Решить систему уравнений');
writeln('a11x1+a12x2+a13x3+a14x4=b1');
writeln('a21x1+a22x2+a23x3+a24x4=b1');
writeln('a31x1+a32x2+a33x3+a34x4=b1');
writeln('a41x1+a42x2+a43x3+a44x4=b1');
for i:=1 to 4 do
for j:=1 to 4 do
begin
write('a[',i,' ',j,']=');readln(a[i,j]);
end;
write('b1=');readln(b1);
write('b2=');readln(b2);
write('b3=');readln(b3);
write('b4=');readln(b4);
for x1:=0 to 10 do
for x2:=0 to 10 do
for x3:=0 to 10 do
for x4:=0 to 10 do
if (a[1,1]*x1+a[1,2]*x2+a[1,3]*x3+a[1,4]*x4=b1)and
(a[2,1]*x1+a[2,2]*x2+a[2,3]*x3+a[2,4]*x4=b2)and
(a[3,1]*x1+a[3,2]*x2+a[3,3]*x3+a[3,4]*x4=b3)and
(a[4,1]*x1+a[4,2]*x2+a[4,3]*x3+a[4,4]*x4=b4)then
begin
writeln('x1=',x1);
writeln('x2=',x2);
writeln('x3=',x3);
writeln('x4=',x4);
end
else if (x1=10)and(x2=10)and(x3=10)and(x4=10)then
write('корней нет');readln;
end.
program z70;
{Решение систем линейных уравнений методом Гаусса}
uses crt;
var a,b,c,d,e,f,k,l,v,s : array [1..5,1..5] of longint;
i,j,
x1,x2,x3,x4 : longint;
begin
clrscr;
writeln('Решить систему уравнений');
writeln('a11x1+a12x2+a13x3+a14x4=b1');
writeln('a21x1+a22x2+a23x3+a24x4=b1');
writeln('a31x1+a32x2+a33x3+a34x4=b1');
writeln('a41x1+a42x2+a43x3+a44x4=b1');
for j:=1 to 4 do
for i:=1 to 5 do
begin
write('a[',j,' ',i,']=');readln(a[j,i]);
end;
for i:=1 to 5 do begin
b[1,i]:=a[1,i]*a[2,1];
b[2,i]:=a[2,i]*a[1,1];
end;
for i:=1 to 5 do begin
b[2,i]:=b[1,i]-b[2,i];
end;
for i:=1 to 5 do beginwriteln('b=',b[2,i]);readln;end;
{2-я строка с нулевым 1-м элементом}
for i:=1 to 5 do begin
c[1,i]:=a[1,i]*a[3,1];
c[3,i]:=a[3,i]*a[1,1];
end;
for i:=1 to 5 do begin
c[3,i]:=c[1,i]-c[3,i];
end;
for i:=1 to 5 do beginwriteln('c=',c[3,i]);readln;end;
{третья строка снулевым 1-м элементом}
for i:=1 to 5 do begin
d[1,i]:=a[1,i]*a[4,1];
d[4,i]:=a[4,i]*a[1,1];
end;
for i:=1 to 5 do begin
d[4,i]:=d[1,i]-d[4,i];
end;
for i:=1 to 5 do beginwriteln('d=',d[4,i]);readln;end;
{4-я строка снулевым 1-м элементом}
for i:=2 to 5 do begin
e[2,i]:=b[2,i]*c[3,2];
e[3,i]:=c[3,i]*b[2,2];
end;
for i:=2 to 5 do begin
k[3,i]:=e[2,i]-e[3,i];
end;
for i:=1 to 5 do beginwriteln('k=',k[3,i]);readln;end;
{3-я строка с 0 1 и 2}
for i:=2 to 5 do begin
l[2,i]:=b[2,i]*d[4,2];
l[4,i]:=d[4,i]*b[2,2];
end;
for i:=2 to 5 do begin
l[4,i]:=l[2,i]-l[4,i];
end;
for i:=1 to 5 do beginwriteln('l=',l[4,i]);readln;end;
{4-я с 0 1 и 2}
for i:=3 to 5 do begin
v[3,i]:=k[3,i]*l[4,3];
s[4,i]:=l[4,i]*k[3,3];
end;
for i:=3 to 5 do begin
f[4,i]:=v[3,i]-s[4,i];
end;
for i:=1 to 5 do beginwriteln('f=',f[4,i]);readln;end;
{4-я с 0 1,2,3}
if (f[4,1]=0)and(f[4,2]=0)and(f[4,3]=0)then begin
x4:=f[4,5] div f[4,4];
x3:=(k[3,5]-k[3,4]*x4)div k[3,3];
x2:=(b[2,5]-b[2,3]*x3-b[2,4]*x4)div b[2,2];
x1:=(a[1,5]-a[1,2]*x2-a[1,3]*x3-a[1,4]*x4)div a[1,1];
writeln('x1=',x1);
writeln('x2=',x2);
writeln('x3=',x3);
writeln('x4=',x4);end
else write('Решений нет или очень много');
readln;
end.
§ 2
1. Используя вспомогательную функцию нахождения sin(x)=x-x**3/3!+x**5/5!-x**7/7!+... процесс суммирования остановить если очередной член станет меньше 0.001. Вычислить для заданного N выражение: 1/sin1+1/(sin1+sin2)+1/(sin1+sin2+sin3)+...
2. Используя вспомогательную функцию нахождения cos(x)=1-x**2/2!+x**4/4!-x**6/6!+... процесс суммирования остановить если очередной член станет меньше 0.001. Вычислить для заданного N выражение: cosx+coscosx+...+coscos...cosx-n-раз
3. Дано предложение. Сколько слов яв-ся перевёртышами и будет ли это число совершенным.
4. Дано предложение заканчивающееся '.','!','?'. Разделитель слов - пробел. Определить будет ли число простых множителей числа S - кол-ва букв "т", больше заданного числа L.
5. Дано предложение заканчивающееся '.','!','?'. Разделитель слов - пробел. В скольких словах предложения имеется словосочетание "ка".
6. Дана целочисленная таблица a[1..m]. Среди её элементов есть хотя бы один отрицательный. Больше ли сумма сумм простых множителей элементов идущих после последнего отрицательного элемента заданного числа L.
7. Дана целочисленная таблица а[1..m]. Среди элементов таблицы есть хотя бы один отрицательный. Найти сумму S элементов расположенных после отрицательного элемента, затем найти сумму простых множит. числа S.
8. Слова в предложении разделены пробелом. Предложение заканчивается "." "!" "?" Определить слово с максимальным числом букв "а" и количество таких букв "а".
9. Даны вершины треугольника. Определить можно ли разместить этот треугольник в круге радиуса r.
10. Дано натуральное число. Представьте его в виде суммы степеней двойки. Кол-во слагаемых k. Будет ли удвоенная сумма простых множителей числа k больше самого k
201=128+64+8+1=2в7+2в6+2в3+2в0.
т.е k=4. Простой множитель k: 2; 2*2<4<k
11. Дано предложение. Сколько слов яв-ся перевёртышами и сколько букв "а". Найти их разность.
12. Дана вещественная таблица а[1..50] Найти среднее арифметическое положительных элементов таблицы и минимум абсолютного значения элементов. Найти их произведение.
13. Дана целочисленная таблица а[1..20] из положительных элементов. Найти среднее арифметическое элементов таблицы и выяснить является ли данное натуральное число совершенным (натур число называется совершенным если оно равно сумме своих делителей, исключая само число, например 6=1+2+3)
14. Дано предложение заканчивающееся точкой. Из слов предложения вычеркивается буква а. Определить сколько слов в новом предложении яв-ся перевертышами.
15. Дано слово. Найти сколько раз буква "a" встречается в этом слове. Будет ли это число простым.
16. Дано предложение. Найти в каком из слов, больше четырёх символов, буква "a" встречается реже.
17. Дано предложение заканчивающееся .,!,?. Разделитель слов - пробел. Определить, сколько слов в предложении является перевёртышами и будет ли это число простым.
18. Дан текст. Установить пробелы вместо символов, номера позиций которых при делении на 4 дают в остатке 3.
19. Дан текст. Удалить в нём все слова "функция".
20. Дано предложение. Расположить слова в нём в порядке возрастания числа букв в словах.
21. Заменить данную букву в слове многоточием.
22. Даны слово и буква. Сколько раз эта буква встречается в данном слове.
23. Зашифровать слово, поставив букве её номер в алфавите ("ё" не учитывать)
24. Дано предложение. Определить все слова которые начинаются с заданной буквы. Слова в предложении разделены пробелами.
25. По номеру месяца определить его название и время года к которому он относится.
26. Дан текст. Определить все слова оканчивающиеся на "ая".
27. Дан текст. Сколько в нём слов "что".
28. Дано предложение. Определить кол-во слов в нём.
29. Заполнить элементами таблицу, располагая их по спирали.
30. Определить сколькими различными способами можно подняться на десятую ступеньку, если за шаг можно подняться следующую или через одну.
31. Фишка может двигаться по полю длиной n только вперёд. Длина хода фишки не более k. Найти число различных путей, по которым фишка может пройти поле от позиции 1 до позиции n. ПРИМЕР: n=4,k=2
Ответ:1,1,1
1,2
2,1
32. В выражении ((((1?2)?3)?4)?5)?6 вместо каждого знака "?" вставить знак одной из четырех операций ( "+", "-", "*", "." ) так, чтобы результат вычислений равнялся Х ( при делении дробная часть отбрасывается ). Найти все варианты.
33. Найти кол-во n-значных чисел в десятичной системе счисления, у каждого из которых сумма цифр равна k. При этом в качестве n-значного числа мы допускаем и числа, начинающиеся с одного или нескольких нулей. Например, число 000102 рассматривается как шестизначное, сумма цифр которого равна 3.
34. Составить алгоритм определения кол-ва 2N-значных "счастливых" билетов, у которых сумма первых N цифр равна сумме последних N цифр; N - произвольное натуральное число.
35. Ввести строку длиной до 30 символов, заменить в ней двойных символов на одиночные, пробелов - на знак подчёркивания, сочетания '**' на многоточие '...'.
36. Ввести массив из 10 положительных чисел. Определить три стоящих подряд числа, сумма которых максимальна. Вывести эту сумму, а числа заменить нулями.
37. Дано целое число N<20. Составьте программу, которая определяет кол-во различных делителей числа N!.
38. Посчитать слова (слова разделены одним или несколькими пробелами) в текстовом файле и добавить информацию об этом (например: 'В этом файле .. слов' ) в конец данного файла.
39. Ввести матрицу целых чисел. Найти и вывести пару элементов матрицы, модуль разности которых минимален.
40. Дана строка текста, состоящая из слов разделенных одним из знаков [#,$,*,-]. Если кол-во слов в предложении четно, поменяйте местами два центральных слова, а если нечетно удалите одно центральное слово.
41. Имеется ожерелье, которое состоит из k (k<=20) бусинок(з), желтого(ж) и красного(к) цветов. Найти максимальное кол-во бусинок одного цвета, идущих подряд.
42. На натуральном отрезке [a,b] найдите и выведите число N с наибольшей суммой своих делителей. Само число и единицу в качестве делителей не учитывать.
43. Данные контрольной работы учащихся по информатике представлены следующим образом:
"отлично" - кол-во учащихся a
"хорошо" - кол-во учащихся b
"удовлетворительно" - кол-во учащихся c
"неудовлетворительно" - кол-во учащихся d.
Постройте или столбчатую гистрограмму с легендой, которая отражает результаты контрольной работы.
44. Результаты таблицы выигрышей денежной лотереи представлены последовательностью натуральных чисел, записанных в текстовом файле в несколько строк через пробел. Три первые цифры каждого числа - номер билета, а последние три цифры величина выигрыша. Определите и выведите номера билетов с наибольшим выигрышем. Например,
Входные данные:
10245857 1254387 132563
6377739 4237857
Выходные данные:
102 -857
423 -857.
45. Экономия в строительстве дорог при строительстве ж/д. станции.
46. Строительство ж/д. станции по принципу справедливости.
47. Фишка может двигаться по полю длиной n только вперёд. Длина хода фишки не более k. Найти число различных путей, по которым фишка может пройти поле от позиции 1 до позиции n
ПРИМЕР: n=4,k=2
Ответ:1,1,1
1,2
2,1
48. Задаётся словарь. Найти в нём все анаграммы(слова составленные из одних и тех же букв).
49. Найти числа х,у,z, удовлетворяющие условию ax+by+cz=n (пусть n=270 a=15 ,b=20,c=30 то 15x+20y+30z=270). Решение: если х=0 и у=0,то 30z=270 т.е.z<=9 аналогично находим ,что у<=14,х<=18.
50. Треугольник АВС задан координатами и точка Д(х4,у4). Лежит ли точка Д внутри АВС. МЕТОД-точка внутри если сумма площадей 3-х треугольников равна площади треугольника АВС.
51. В таблице а заменить отрицательные элементы на 0.
52. Дана таблица из n строк и n столбцов. Найти суммы элементов записанных по диагоналям.
53. Дана таблица а(n:m) Умножить каждый элм первой строки на а[1,1] (в том числе и элемент а[1,1]) а каждый элемент второй строки на а[2,2] и т.д.
54. Дана линейная таблица а. Найти максимальный элемент таблицы и найти его среди элементов таблицы b.
55. Даны n-троек a,b,c. Можно ли построить треугольник с данными сторонами.
56. Напечатать в возрастающем порядке все трёхзначные числа, в десятичной записи которых нет одинаковых цифр.
57. Являются ли числа а,b,c (<=100) пифагоровыми тройками.
58. Составить программу определения суммы цифр числа а.
59. Дан выпуклый n-угольник и точка(х1,у1). Определить: а)является ли точка вершиной; б)принадлежит ли точка n-угольнику.
60. Даны координаты 2-х точек. Найти точку на оси Х чтобы сумма расстояний до данных было минимальной.
program z1;
{ Используя вспомог. нахождения функции sin(x)=x-x**3/3!+x**5/5!-x**7/7!+...
процесс суммирования остановить если очередной член станет меньше 0.001 Вычислить для заданного N выражение:1/sin1+1/(sin1+sin2)+1/(sin1+sin2+sin3)+... }
uses crt;
var s,z : real;
i,n : longint;
function sinus( x : real ) : real;
var ot,dr,ch : real;
zn,k : longint;
begin
ot:=0;dr:=x;
zn:=1;k:=1;
while abs(dr)>0.001 do
begin
ot:=ot+dr;
ch:=-dr*x*x;
zn:=zn*(k+1)*(k+2);k:=k+2;
dr:=ch/zn;
end;
sinus:=ot;
end;
begin
clrscr;
write('n=');readln(n);
s:=0;z:=0;
for i:=1 to n do
begin
z:=z+sinus(i);
if z=0 then halt;
s:=s+1/z;
end;
writeln('Ответ:',s:5:4);
readln;
end.
program z2;
{ Используя вспомог. нахождения функции cos(x)=1-x**2/2!+x**4/4!-x**6/6!+...
процесс суммирования остановить если очередной член станет меньше 0.001 Вычислить для заданного N выражение:cosx+coscosx+...+coscos...cosx-n-раз }
uses crt;
var s,x : real;
i,n : longint;
function cosinus( x : real ) : real;
var ot,dr,ch : real;
zn,k : longint;
begin
ot:=0;dr:=x;
zn:=1;k:=1;
while abs(dr)>0.001 do
begin
ot:=ot+dr;
ch:=-dr*x*x;
zn:=zn*k*(k+1);k:=k+2;
dr:=ch/zn;
end;
cosinus:=ot;
end;
begin
clrscr;
write('n=');readln(n);
write('x=');readln(x);
s:=0;
for i:=1 to n do
begin
x:=x+cosinus(x);
s:=s+x;
end;
writeln('Ответ:',s:5:4);
readln;
end.
program z3;
{ Дано предложение. Сколько слов яв-ся перевёртышами и будет ли это число совершенным }
uses crt;
var i,j,k,l,l1,sum,k1 : longint;
a,b,c : string;
d : array [1..60] of longint;
begin
clrscr;
textcolor(11);
write('введите текст: ');
readln(a);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begin
a[l+1]:=' ';
inc(l);
end
else a[l]:=' ';
for i:=1 to l do if (a[i]=' ')
then begin
l1:=length(b);c:='';
for j:=l1 downto 1 do c:=c+b[j];
if b=c then inc(k);b:='';
end
else b:=b+a[i];
if k=1 then begin
write('совершенное');
readln;halt;
end;
sum:=0;k1:=1;
for i:=1 to k-1 do if k mod i=0 then begin
d[k1]:=i;inc(k1);
end;
for i:=1 to k1-1 do sum:=sum+d[i];
if k=sum then write('совершенное')
else write('не совершенное');
readln;
end.
program z4;
{ Дано предлож. заканчивающееся '.','!','?'.Разделитель слов - пробел. Опред будет ли число прост множителей числа S - кол-ва букв "т", больше заданого числа L }
uses crt;
var k,i,l,fl,j,ll,n,s : longint;
a : string;
b : array [1..50] of longint;
label m;
begin
clrscr;
textcolor(11);
write('введите текст: ');readln(a);
write('любое число: ' );readln(ll);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begin
a[l+1]:=' ';i
nc(l);
end
else a[l]:=' ';
for i:=1 to l do if (a[i]='т')then inc(s);
b[1]:=2;n:=3;j:=1;fl:=0;
m : while n<=k do
begin
for i:=2 to n-1 do
if n mod i=0 then fl:=1;
if fl=0 then begin
inc(j);b[j]:=n;inc(n);goto m;
end;
fl:=0;inc(n);
end;
i:=1;
while s>1 do
if s mod b[i]=0 then begin
inc(k);
s:=s div b[i];
end
else inc(i);
if ll=k then write('равно');
if ll<k then write('больше');
if ll>k then write('меньше');
readln;
end.
program z5;
{ Дано предлож. заканчивающееся '.','!','?'. Разделитель слов - пробел.В скольки словах
предложения имеется словосочетание "ка" }
uses crt;
var k,i,l,j,v : longint;
a,b : string;
t : array [1..50] of string;
label mm;
begin
clrscr;
textcolor(11);
write('введите текст: ');
readln(a);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begin
a[l+1]:=' ';
inc(l);
end
else a[l]:=' ';
for i:=1 to l do
if a[i]=' 'then begin
inc(j);t[j]:=b;b:='';
end
else b:=b+a[i];i:=1;
while i<=j do
begin
b:=t[i];l:=length(b);
for v:=1 to l-1 do
if (b[v]='к')and(b[v+1]='а')then begin inc(k);goto mm; end;
mm:inc(i);
end;
write('кол-во слов:',k);
readln;
end.
program z6;
{ Дана целтаб a[1..m]. Среди её элм есть хотя бы один отрицательный.Больше ли сумма сумм простых множ. Элм идущих после последнего оприц. элемента заданого числа L }
uses crt;
var a,b : array [1..70] of longint;
i,poz,l,m,s,k,n,fl,j : longint;
label m3,m1,m2;
begin
m1 : clrscr;
write('Введите число:');readln(l);
write('Введите кол-во элм таблицы:');readln(m);
for i:=1 to m do
begin
write('a[',i,']=');readln(a[i]);
if a[i]<0 then poz:=i;
end;
if poz=0 then begin
write('Hе обнаружен отрицательный элемент!');
readln;goto m1;
end;
for i:=poz+1 to m do if a[i]<>0 then inc(fl);
if fl=0 then halt;
b[1]:=2;
n:=3;
j:=1;
fl:=0;
m2 : while n<=100 do
begin
for i:=2 to n-1 do if n mod i=0 then fl:=1;
if fl=0 then begin
inc(j);b[j]:=n;inc(n);goto m2;
end;
fl:=0;inc(n);
end;
for k:=poz+1 to m do
begin
i:=1;
while a[k]>1 do if a[k] mod b[i]=0 then
begin
s:=s+b[i];a[k]:=a[k] div b[i];
end else inc(i);
end;
if l=s then begin write('равны');goto m3; end;
if l>s then write('меньше')
else write('больше');
m3 : readln;
end.
program z7;
{ Дана целочисл табл а[1..m].Среди элементов таб есть хотябы один отрицательный. Найти сумму S элементов расположенных после отрицательного элемента, затем найти сумму простых
множит. числа S }
uses crt;
var fl,i,m,sum,s,poz,j : longint;
a,b : array [1..60] of longint;
label met,mm;
begin
mm : clrscr;textcolor(11);
write('введите кол-во элементов таблицы: ');readln(m);
for i:=1 to m do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to m do if a[i]<0 then poz:=i;
if poz=0 then begin
write('Hе обнаружен отрицательный элемент!');
readln;goto mm;
end;
for i:=poz+1 to m do sum:=sum+a[i];
b[1]:=2;m:=3;j:=1;fl:=0;
met:while m<=sum do
begin
for i:=2 to m-1 do if m mod i=0 then fl:=1;
if fl=0 then begin
inc(j);b[j]:=m;inc(m);goto met;
end;
fl:=0;inc(m);
end; i:=1;
while sum>1 do if sum mod b[i]=0 then
begin
s:=s+b[i];sum:=sum div b[i];
end
else inc(i);
write('ответ: ',s);
readln;
end.
program z8;
{ Слова в предложении разделены пробелом.Предл. заканч. . ! ? Определить слово с максимальным числом букв "а"и количество таких букв "а". }
uses crt;
var f1 : array [1..50] of string;
f2 : array [1..50] of longint;
i,j,l,l1,l2,k,poz,max : longint;
a,b : string;
begin
clrscr;
write('введите текст:');readln(a);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begininc(l);a[l]:=' ';end
else a[l]:=' ';
for i:=1 to l do
if a[i]=' 'then begin
inc(j);f1[j]:=b;b:='';
end
else b:=b+a[i];
for i:=1 to j do begin
b:=f1[i];l1:=length(b);
for l2:=1 to l1 do if(b[l2]='a')or(b[l2]='а')
then inc(k);
f2[i]:=k;k:=0;
end;
max:=f2[1];
for i:=2 to j do if max<f2[i]then
begin
max:=f2[i];
poz:=i;
end;
writeln('слово:',f1[poz]);
writeln('это слово имеет: ',max,' буквы "а" ');
readln;
end.
program z9;
{ Даны вершины треугольника.Опред. можно ли разместить этот треуг. в круге радиуса r }
uses crt;
var x1,x2,x3,y1,y2,y3,r : longint;
d : boolean;
function dlina(x,y,x1,y1:real):real;
begin
dlina:=sqrt(sqr(x-x1)+sqr(y-y1));
end;
function square(a,b,c:real):real;
var p:real;
begin
p:=(a+b+c)/2;
square:=sqrt(p*(p-a)*(p-b)*(p-c));
end;
function tupoi(a,b,c:real;var max:real):boolean;
begin
if (a>=b)and(b>=c)or(a>=c)and(c>=b)then
begin max:=a;tupoi:=a*a<b*b+c*c; end
else if (b>=a)and(a>=c)or(b>=c)and(c>=a)then
begin max:=b;tupoi:=b*b<a*a+c*c; end
else begin max:=c;tupoi:=c*c<a*a+b*b; end;
end;
function proverka(x1,x2,x3,y1,y2,y3,r:real):boolean;
var ab,bc,ca,s,max:real;
begin
ab:=dlina(x1,y1,x2,y2);
bc:=dlina(x1,y1,x3,y3);
ca:=dlina(x3,y3,x2,y2);
if (ab+bc<=ca)or(ab+ca<=bc)or(bc+ca<=ab)then proverka:=false
else if not tupoi(ab,bc,ca,max)then proverka:=max<=r
else begin
s:=square(ab,bc,ca);
proverka:=r>=ab*bc*ca/(4*s)
end
end;
begin
clrscr;
writeln('вводите через пробел!');
write('x1,y1=');readln(x1,y1);
write('x2,y2=');readln(x2,y2);
write('x3,y3=');readln(x3,y3);
write('r=');readln(r);
d:=proverka(x1,x2,x3,y1,y2,y3,r);
if d then writeln('Да') else writeln('Нет');
readln;
end.
program z10;
{ Дано нат. число.Представьте его в виде суммы степеней двойки. Кол-во слагаемых k. Будет ли удвоеная сумма прост. множ. числа k больше самого k
201=128+64+8+1=2в7+2в6+2в3+2в0.
т.е k=4 .Прост. множ. k: 2; 2*2<4<k}
uses crt;
var b,t : array [1..70] of longint;
i,j,step,n,fl,k,o : longint;
label m;
begin
clrscr;
write('Введите число:');readln(n);
i:=1;
while n>=0 do
if i*2>=n then begin
inc(j);t[j]:=step;
n:=n-i;i:=1;step:=0;
end
else begin
i:=i*2;inc(step);
end;j:=j-1;o:=j;
b[1]:=2;n:=3;k:=1;fl:=0;
m : while n<=j do
begin
for i:=2 to n-1 do if n mod i=0 then fl:=1;
if fl=0 then begin
inc(k);b[k]:=n;inc(n);goto m;
end;
fl:=0;inc(n);
end;
n:=0;i:=1;
while j>1 do if j mod b[i]=0 then
begin
n:=n+b[i];j:=j div b[i];
end
else inc(i);
if o>2*n then write('больше')
else write('меньше');
readln;
end.
program z11;
{ Дано предложение. Сколько слов яв-ся перевёртышами и сколько букв "а".Найти их разность }
uses crt;
var i,j,k,l,l1,ka : longint;
a,b,c : string;
begin
clrscr;
textcolor(11);
write('введите текст: ');
readln(a);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begin
a[l+1]:=' ';
inc(l);
end
else a[l]:=' ';
for i:=1 to l do if (a[i]=' ')then
begin
l1:=length(b);c:='';
for j:=l1 downto 1 do c:=c+b[j];
if b=c then inc(k);b:='';
end else b:=b+a[i];
for i:=1 to l do if (a[i]='a')or(a[i]='а')then inc(ka);
if k>=ka then write('кол-во перевёртышей на ',k-ka,' больше')
else write('кол-во букв "а" на ',ka-k,' больше');
readln;
end.
program z12;
{ Дана вещтаб а[1..50] Найти среднее арифметич положит. элементов табл и минимум абсолютного знач элм . Найти их произведение }
uses crt;
var i,m,k : longint;
a : array [1..50] of real;
min,s : real;
begin
clrscr;
textcolor(10);
write('введите кол-во элементов таблицы: ');readln(m);
for i:=1 to m do
begin
write('a[',i,']=');readln(a[i]);
if a[i]>0 then begin s:=s+a[i];inc(k); end;
end;
s:=s/k;
writeln('ср. значение положительных элм.: ',s);
min:=abs(a[1]);
for i:=2 to m do if min>abs(a[i]) then min:=abs(a[i]);
write('произведение : ',s*min);
readln;
end.
program z13;
{ Дана целочисл табл а[1..20]положит элементов Найти среднее арифметич элементов табл и выяснить является ли данное натуральное число совершенным (натур число наз совершенным
если оно равно сумме своих делителей,исключая само число, например 6=1+2+3) }
uses crt;
var i,m,k,sum : longint;
a : array [1..20] of longint;
b : array [1..50] of longint;
s : real;
begin
clrscr;
textcolor(10);
write('введите кол-во элементов таблицы: ');readln(m);
for i:=1 to m do
begin
write('a[',i,']=');readln(a[i]);s:=s+a[i];
end;
s:=s/m;
writeln('среднее орифметическое: ',s);m:=round(s);
write('при округлении ');
if m=1 then begin write('совершенное');readln;halt; end;
sum:=0;k:=1;
for i:=1 to m-1 do if m mod i=0 then begin
b[k]:=i;inc(k);
end;
for i:=1 to k-1 do sum:=sum+b[i];
if m=sum then write('совершенное')
else write('не совершенное');
readln;
end.
program z14;
{ Дано предл заканчив точкой.Из слов предл вычеркивается буква а Определить сколько слов в новом предл яв-ся перевертышами. }
uses crt;
var l1,j,i,l,k : longint;
a,b,c : string;
label m,m1,m2;
begin
m: clrscr;
textcolor(10);
write('введите текст: ');
readln(a);
l:=length(a);
if a[l]<>'.'then begin
write('Поставьте "." конце предложения');
readln;goto m;
end;
m2:for i:=1 to l do if (a[i]='a')or(a[i]='а')
then begin
delete(a,i,1);
l:=l-1;
goto m2;
end;
k:=0;
for i:=1 to l do
if (a[i]=' ')and(a[i+1]=' ') then inc(k)
else a[i-k]:=a[i];
l:=l-k;k:=0;
for i:=1 to l do if (a[i]=' ')or(a[i]='.')then
begin
l1:=length(b);c:='';
for j:=l1 downto 1 do c:=c+b[j];
if b=c then inc(k);b:='';
end
else b:=b+a[i];
write('кол-во:',k);readln;
end.
program z15;
{ Дано слово.Найти сколько раз буква "a" встречается в этом слове.Будет ли это число простым }
uses crt;
var k,i,l,fl : longint;
a : string;
begin
clrscr;
textcolor(11);
write('введите текст: ');readln(a);
l:=length(a);k:=0;fl:=0;
for i:=1 to l do if (a[i]='a')or(a[i]='а')then inc(k);
writeln('кол-во:',k);
if k=2 then begin write('простое');readln;halt;end;
if k=0 then begin write('не простое');readln;halt;end;
for i:=2 to k-1 do if k mod i=0 then fl:=1;
if fl=0 then write('простое')
else write('не простое');
readln;
end.
program z16;
{ Дано предложение.Найти в каком из слов больше 4 сим. буква "a" встречается реже}
uses crt;
var i,j,k,l,l1,poz,min : longint;
a,b : string;
t1 : array [1..50] of string;
t2 : array [1..50] of longint;
label met;
begin
clrscr;
textcolor(11);
write('введите текст: ');
readln(a);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begin
a[l+1]:=' ';
inc(l);
end
else a[l]:=' ';
j:=0;
for i:=1 to l do if a[i]=' 'then
begin
l1:=length(b);
for l:=1 to l1 do
if (b[l]='a')or(b[l]='а')then
if l1>=4 then begin
inc(j);
t1[j]:=b;
goto met
end;
met : b:='';
end else b:=b+a[i];
if t1[1]=''then begin
write('нужных слов не обнаружено');
readln;halt;
end;
for i:=1 to j do begin
b:=t1[i];l1:=length(b);
for l:=1 to l1 do if (b[l]='a')or(b[l]='а')
then inc(k);t2[i]:=k;k:=0;
end;
min:=t2[1];
for i:=2 to j do if min>t2[i] then begin
min:=t2[i];
poz:=i;
end;
write('слово:',t1[poz]);readln;
end.
program z17;
{ Дано предлож. заканчивающееся .,!,?.Разделитель слов - пробел. Определить ,сколько слов в предложении является перевёртышами и будет ли это число простым. }
uses crt;
var k,i,l,fl,j,l1 : longint;
a,b,c : string;
begin
clrscr;
textcolor(11);
write('введите текст: ');
readln(a);
l:=length(a);
if (a[l]<>'.')or(a[l]<>'!')or(a[l]<>'?')
then begin
a[l+1]:=' ';
inc(l);
end
else a[l]:=' ';
for i:=1 to l do
if a[i]=' ' then begin
l1:=length(b);c:='';
for j:=l1 downto 1 do c:=c+b[j];
if b=c then inc(k);b:='';
end
else b:=b+a[i];
writeln('кол-во: ',k);
if k=2 then begin write('простое' );readln;halt end;
if k=0 then begin write('не простое');readln;halt end;
for i:=2 to k-1 do if k mod i=0 then fl:=1;
if fl=0 then write('простое')
else write('не простое');
readln;
end.
program z18;
{ Дан текст. Установить пробелы вместо символов, номера позиций которых при делении на 4 дают в остатке 3 .}
uses crt;
var a : string;
i,l : integer;
begin
clrscr;
write('введите текст: ');
readln(a);
l:=length(a);
if a=''then halt;
for i:=1 to l do
if i mod 4=3 then a[i]:=' ';
write('Итог: ',a);
readln;
end.
program z19;
{ Дан текст. Удалить в нём все слова "функция". }
uses crt;
var a : string;
i,l : longint;
label m;
begin
clrscr;
write('введите предложение: ');readln(a);
l:=length(a);
m : for i:=1 to l do
if (a[i]='ф')and(a[i+1]='у')and(a[i+2]='н')and
(a[i+3]='к')and(a[i+4]='ц')and(a[i+5]='и')and
(a[i+6]='я')then begin
l:=l-7;delete(a,i,7);goto m;
end;
write('Итог: ',a);
readln;
end.
program z20;
{ Дано предложение. Расположить слова в нём в порядке возрастания числа букв в словах. }
uses crt;
var a,d,sl1,sl2 : string;
i,l,k,j : longint;
b : array [1..50] of string;
begin
clrscr;
write('введите предложение: ');readln(a);l:=length(a);
if a=''then halt;
if a[l]<>' ' then begin inc(l);a[l]:=' '; end;
for i:=1 to l do
if a[i]=' 'then begin
inc(j);b[j]:=d;d:='';
end
else d:=d+a[i];
for i:=1 to j-1 do
for k:=i+1 to j do
begin
sl1:=b[i];
sl2:=b[k];
if length(sl1)>length(sl2) then begin
b[i]:=sl2;
b[k]:=sl1;
end;
end;
for i:=1 to j do write(' ',b[i]);
readln;
end.
program z21;
{ Заменить данную букву в слове многоточием. }
uses crt;
var aa,a,b : string;
i,l,j : longint;
begin
clrscr;
textcolor(15);
write(' введите слово: ');readln(a);
write(' введите букву: ');readln(aa);
a:=a+' ';
l:=length(a);
if length(aa)>1 then halt;
for i:=1 to l do
if a[i]=aa then begin
if i<>l then
begin
l:=l+2;
for j:=l downto i+1 do
a[j]:=a[j-2];
end;
l:=l+2;
a[i]:='.';a[i+1]:='.';a[i+2]:='.';
end;
write('Итог: ',a);
readln;
end.
program z22;
{ Даны слово и буква. Сколько раз эта буква встречается в данном слове. }
uses crt;
var a,aa,b : string;
i,l,k : longint;
begin
clrscr;
write(' введите слово: ');readln(a);
write(' введите букву: ');readln(aa);
l:=length(a);
if length(aa)>1 then halt;
for i:=1 to l do
if a[i]=aa then inc(k);
write(' Ответ: ',k);
readln;
end.
program z23;
{ Зашифровать слово, поставив букве
её номер в алф. ("ё" не учитывать) }
uses crt;
var a,aa : string;
l,i,j : longint;
begin
clrscr;
write('введите слово: ');readln(a);l:=length(a);
aa:='абвгдежзийклмнопрстуфхцчшщъыьэюя';
for i:=1 to l do
for j:=1 to 32 do
if aa[j]=a[i] then write(j,' ');
readln;
end.
program z24;
{ Дано предложение. Определить все слова которые начинаются с заданой буквы.
Слова в предложении разделены пробелами. }
uses crt;
var a,aa,b : string;
i,l,o,oo : longint;
begin
clrscr;
write('введите предложение: ');readln(a);
write('введите букву: ');readln(aa);l:=length(a);
if length(aa)>1 then halt;
if a[l]<>' 'then begin inc(l);a[l]:=' '; end;
for i:=1 to l do
if a[i]=' 'then
begin
if b[1]=aa then writeln(b) else inc(o);inc(oo);b:='';
end else b:=b+a[i];
if o=oo then write('таких слов не обнаружено!');
readln;
end.
program z25;
{ По номеру месяца определить его название и время года к которому он относится. }
uses crt;
var a,b : array [1..12] of string;
i,l : longint;
begin
clrscr;
write('введите номер месяца : ');readln(l);
if (l>12)or(l<1)then halt;
b[1]:='зима'; b[3]:='весна'; b[6]:='лето'; b[9]:='осень';
b[2]:='зима'; b[4]:='весна'; b[7]:='лето'; b[10]:='осень';
b[12]:='зима'; b[5]:='весна'; b[8]:='лето'; b[11]:='осень';
a[1]:='январь'; a[7]:='июль';
a[2]:='февраль'; a[8]:='август';
a[3]:='март'; a[9]:='сентябрь';
a[4]:='апрель'; a[10]:='октябрь';
a[5]:='май'; a[11]:='ноябрь';
a[6]:='июнь'; a[12]:='декабрь';
writeln(' месяц: ',a[l]);
write('пора года: ',b[l]);
readln;
end.
program z26;
{ Дан текст. Определить все слова оканчивающиеся на "ая". }
uses crt;
var a,b : string;
o,oo,i,l,l2 : longint;
label m;
begin
clrscr;
write('введите предложение: ');readln(a);
l:=length(a);
m : for i:=1 to l do if (a[i]=' ')and(a[i+1]=' ')
then begin
delete(a,i,1);
l:=l-1;
goto m;
end;
if a[l]<>' 'then begin inc(l);a[l]:=' '; end;
for i:=1 to l do
if a[i]=' 'then begin
l2:=length(b);
if (b[l2]='я')and(b[l2-1]='а')then
writeln(b)else inc(o);b:='';inc(oo);
end
else b:=b+a[i];
if o=oo then write('таких слов не обнаружено!');
readln;
end.
program z27;
{ Дан текст. Сколько в нём слов "что". }
uses crt;
var a : string;
i,l,k : longint;
label m;
begin
clrscr;
write('введите предложение: ');readln(a);
l:=length(a);
m : for i:=1 to l do
if (a[i]='ч')and(a[i+1]='т')and(a[i+2]='о')then
begin
l:=l-3;delete(a,i,3);
inc(k);goto m;
end;
write('кол-во слов "что": ',k);
readln;
end.
program z28;
{ Дано предложение. Определить кол-во слов в нём. }
uses crt;
var a : string;
i,l,k : longint;
label m;
begin
clrscr;
write('введите предложение: ');readln(a);l:=length(a);
if a=''then halt;
m : for i:=1 to l do
if (a[i]=' ')and(a[i+1]=' ')
then begin
delete(a,i,1);l:=l-1;goto m;
end;
if a[1]=' 'then begin delete(a,1,1);l:=l-1; end;
if a[l]<>' ' then begin inc(l);a[l]:=' '; end;
for i:=1 to l do if a[i]=' 'then inc(k);
write('кол-во слов:',k);
readln;
end.
program z29;
{ Заполнить элементами таблицу, располагая их по спирали. }
uses crt;
var i,j,m,n,l,r : integer;
tab : array [1..50,1..50] of integer;
begin
clrscr;
write('Кол-во строк : '); readln(m);
write('Кол-во столбцов : '); readln(n);
repeat
inc(r);
for i:=r to n-r+1 do begin inc(l);tab[i,r]:=l end;
for i:=r+1 to m-r+1 do begin inc(l);tab[n-r+1,i]:=l end;
for i:=n-r downto r do begin inc(l);tab[i,m-r+1]:=l end;
for i:=m-r downto r+1 do begin inc(l);tab[r,i]:=l end;
until l=m*n;
for j:=1 to m do
for i:=1 to n do
begin
write(tab[i,j]:4);
if i=n then writeln;
end;
readln;
end.
program z30;
{ Определить сколькими различными способами можно подняться на десятую ступеньку, если за шаг можно подняться следующую или через одну.}
uses crt;
var i : shortint;
k : array [1..10] of shortint;
begin
clrscr;
k[1]:=1;
k[2]:=2;
for i:=3 to 10 do
k[i]:=k[i-1]+k[i-2];
write('Число путей : ',k[10]);
readln;
end.
program z31;
{ Фишка может двигаться по полю длиной n только вперёд. Длина хода фишки не более k. Найти число различных путей, по которым фишка может пройти поле от позиции 1 до позиции n.
ПРИМЕР: n=4,k=2
Ответ: 1,1,1
1,2
2,1 }
uses crt;
label _end;
var p,i,ii,j,k,n,l,sum,_ot,_do,kol_vo : longint;
error : integer;
a : string;
tab : array [1..200] of string;
begin
clrscr;
write('k=');readln(k);
write('n=');readln(n);
if k=1 then begin
kol_vo:=1;
goto _end
end;
n:=n-1;_ot:=1;_do:=k;
if n=0 then halt;
for i:=1 to k do
begin
_ot:=_ot*10;
_do:=_do*10+k
end;
{ подбор путей : }
for i:=_ot to _do do
begin
str(i,a);
sum:=0;
l:=length(a);
for j:=1 to l do
begin
val(a[j],ii,error);
sum:=sum+ii
end;
if sum=n then
begin
inc(p);
for j:=1 to l do
if a[j]<>'0' then tab[p]:=tab[p]+a[j]+',';
end;
end;
{ убираем одинаковые пути : }
for i:=1 to p-1 do
for j:=i+1 to p do
if tab[i]=tab[j] then tab[i]:='';
{ распечатка : }
for i:=1 to p do
if tab[i]<>'' then
begin
a:=tab[i];
for j:=1 to length(a)-1 do
write(a[j]);
inc(kol_vo);writeln;
end;
_end:
write('Число путей : ',kol_vo);
readln;
end.
program z32;
{ В выражении ((((1?2)?3)?4)?5)?6 вместо каждого знака "?" вставить знак одной из четырех операций ( "+", "-", "*", "." ) так, чтобы результат вычислений равнялся Х ( при делении дробная часть
отбрасывается ). айти все варианты. }
uses crt;
var i1,i2,i3,i4,i5,j,x,otvet,ot,n : longint;
nn : string;
a : array [1..6] of string;
begin
clrscr;
write('о т в е т : ');readln(otvet);
a[1]:='((((1'; a[4]:='4)';
a[2]:='2)'; a[5]:='5)';
a[3]:='3)'; a[6]:='6=';
for i1:=1 to 4 do
for i2:=1 to 4 do
for i3:=1 to 4 do
for i4:=1 to 4 do
for i5:=1 to 4 do
begin
n:=i1*10000+i2*1000+i3*100+i4*10+i5;
str(n,nn);
ot:=1;x:=2;
for j:=1 to 5 do
begin
if nn[j]='1' then ot:=ot+x;
if nn[j]='2' then ot:=ot-x;
if nn[j]='3' then ot:=ot*x;
if nn[j]='4' then ot:=trunc(ot/x);
inc(x);
end;
if ot=otvet then begin
for j:=1 to 5 do
begin
if nn[j]='1' then write(a[j],'+');
if nn[j]='2' then write(a[j],'-');
if nn[j]='3' then write(a[j],'*');
if nn[j]='4' then write(a[j],'/');
end;
write(a[6],'',otvet);readln;
end;
end;
write('к о н е ц');
readln;
end.
program z33;
{ Найти кол-во n-значных чисел в десятичной системе счисления, у каждого из которых сумма цифр равна k. При этом в качестве n-значного числа мы допускаем и числа, начинающиеся с одного
или нескольких нулей. Например, число 000102 рассматривается как шестизначное, сумма цифр которого равна 3.}
uses crt;
var k,n,i,ii,j,_do,kol_vo,sum : longint;
text : string;
error : integer;
begin
clrscr;
write(' n=');readln(n);
write(' k=');readln(k);
if k=0 then begin
write('ОТВЕТ : 1');
readln;halt
end;
_do:=9;kol_vo:=0;
for i:=1 to n-1 do _do:=_do*10+9;
for i:=1 to _do do
begin
str(i,text);sum:=0;
for j:=1 to length(text) do
begin
val(text[j],ii,error);sum:=sum+ii
end;
if k=sum then inc(kol_vo);
end;
write('ОТВЕТ : ',kol_vo);
readln;
end.
program z34;
{ Составить алгоритм определения кол-ва 2N-значных "счастливых" билетов, у которых сумма первых N цифр равна сумме последних N цифр; N - произвольное натуральное число.}
uses crt;
var n,_ot,_do,i,ii,j,kol_vo,sum1,sum2 : longint;
error : integer;
text : string;
begin
clrscr;
write('N=');readln(N);
kol_vo:=0;
_ot:=1;
_do:=9;
for i:=1 to n*2-1 do
begin
_ot:=_ot*10;
_do:=_do*10+9
end;
for i:=_ot to _do do
begin
str(i,text);sum1:=0;sum2:=0;
for j:=1 to n*2 do
if j<=n then begin val(text[j],ii,error);sum1:=sum1+ii end
else begin val(text[j],ii,error);sum2:=sum2+ii end;
if sum1=sum2 then inc(kol_vo);
end;
writeln('ОТВЕТ : ',KOL_VO);readln;
end.
program z35;
{ Ввести строку длиной до 30 символов, заменить в ней двойных символов на одиночные, пробелов - на знак подчёркивания, сочетания '**' на многоточие '...'. }
uses crt;
label m,m2;
var i,l : longint;
a : string;
begin
clrscr;
write('Введите строку:');readln(a);
l:=length(a);
i:=1;
if l>30 then halt;
while i<=l do
begin
if (a[i]='*')and(a[i+1]='*') then begin write('...');inc(i);goto m end
else if a[i]=' ' then begin write('_');goto m end
else if a[i]=a[i+1] then begin
repeat inc(i) until a[i]<>a[i+1];
write(a[i]);inc(i);goto m2;
end;
write(a[i]);m : inc(i); m2 :
end;
readln;
end.
program z36;
{ Ввести массив из 10 положительных чисел. Определить три стоящих подряд числа, сумма которых максимальна. Вывести эту сумму, а числа заменить нулями. }
uses crt;
var i,j,max,poz : longint;
t,a,b : array [1..10] of integer;
begin
clrscr;
for i:=1 to 10 do begin write(i,'-ое число : ');readln(a[i]) end;
for i:=1 to 8 do t[i]:=a[i]+a[i+1]+a[i+2];
max:=t[1];poz:=1;
for i:=2 to 8 do if max<t[i] then begin max:=t[i];poz:=i; end;
b:=a;
a[poz]:=0;
a[poz+1]:=0;
a[poz+2]:=0;
writeln('Сумма: ',max);
for i:=1 to 10 do write(' ',a[i]);
for i:=1 to 8 do if (t[i]=max)and(poz<>i) then
begin
a:=b;a[i]:=0;a[i+1]:=0;a[i+2]:=0;writeln;
for j:=1 to 10 do write(' ',a[j]);
end;
readln;
end.
program z37;
{ Дано целое число N<20. Составьте программу, которая определяет кол-во различных делителей числа N!. }
uses crt;
var kol_vo,i,n,f : longint;
begin
clrscr;
write('N=');readln(n);
if n>=20 then halt;
f:=1;
for i:=1 to n do f:=f*i;
for i:=1 to f do
if f mod i=0 then begin inc(kol_vo);{write(i,' ')} end;
{writeln;}
write('Кол-во различных делителей числа N!=',f,' : ',kol_vo);
readln;
end.
program z38;
{ Посчитать слова ( слова разделены одним или несколькими пробелами ) в текстовом файле и добавить информацию об этом ( например : 'В этом файле .. слов' ) в конец данного файла. }
uses crt;
label m;
var i,l,k : longint;
a,s,tt,c : string;
fail : text;
begin
clrscr;
assign(fail,'file_1.pas');
reset(fail);
readln(fail,a);
{-- Кол-во слов: --}
REPEAT
c:=a;
l:=length(a);
m:for i:=1 to l do
if (a[i]=' ')and(a[i+1]=' ')
then begin
delete(a,i,1);l:=l-1;goto m;
end;
if a[1]=' 'then begin delete(a,1,1);l:=l-1; end;
if a[l]<>' ' then begin inc(l);a[l]:=' '; end;
for i:=1 to l do if a[i]=' 'then inc(k);
readln(fail,a);
UNTIL c=a;
dec(k);str(k,s);
tt:=' кол-во слов в файле: '+s;
{ write(tt);
readln;}
append(fail);
writeln(fail,tt);
close(fail);
end.
program z39;
{ Ввести матрицу целых чисел. Найти и вывести пару эл-тов матрицы, модуль разности которых минимален. }
uses crt;
label metka;
var i,j,i1,j1,poz,min,k,n,m : integer;
s1,s2 : string;
a : array [1..20,1..20] of integer;
b : array [1..150] of string;
t : array [1..150] of longint;
begin
clrscr;
write('Кол-во строк : ');readln(n);
write('Кол-во столбцов : ');readln(m);
for i:=1 to n do
for j:=1 to m do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
for i:=1 to n do
for j:=1 to m do
for i1:=1 to n do
for j1:=1 to m do
begin
if (i=i1)and(j=j1)then goto metka;
str(a[i,j],s1);
str(a[i1,j1],s2);
inc(k);
t[k]:=abs(a[i,j]-a[i1,j1]);
b[k]:=s1+' минус '+s2;
metka:
end;
min:=t[1];
poz:=1;
for i:=2 to k do
if min>t[i] then begin min:=t[i];poz:=i; end;
write('Ответ: ',b[poz]);
readln;
end.
program z40;
{ Дана строка текста, состоящая из слов разделенных одним из знаков [#,$,*,-]. Если кол-во слов в предложении четно, поменяйте местами два центральных слова, а если нечетно удалите одно центральное слово. }
uses crt;
var a,b,c : string;
i,l,s,j,r : longint;
t : array [1..30] of string;
begin
clrscr;
write('Введите строку :');readln(a);
l:=length(a);
if not ( a[l] in ['#','$','*','-'] ) then begin inc(l);a:=a+'#' end;
for i:=1 to l do
if a[i] in ['#','$','*','-']
then begin inc(j);t[j]:=b;b:='' end
else b:=b+a[i];
s:=trunc(j/2);
if j mod 2=0 then begin
c:=t[s];
t[s]:=t[s+1];
t[s+1]:=c;
end
else t[s+1]:='';
for i:=1 to j do if t[i]<>'' then write(t[i],'#');
readln;
end.
program z41;
{ Имеется ожерелье, которое состоит из k (k<=20) бусинок(з), желтого(ж) и красного(к) цветов. Найти максимальное кол-во бусинок одного цвета, идущих подряд. }
uses crt;
var a,b,g : string;
i,j,l,poz,max : integer;
t1 : array [1..20] of string;
t2 : array [1..20] of integer;
procedure color;
begin
if g[1]='з'then write('зеленого цвета');
if g[1]='ж'then write('желтого цвета');
if g[1]='к'then write('красного цвета');
end;
begin
clrscr;
write('Введите строку :');readln(a);
l:=length(a);
if l>20 then halt;
b:=a[1];j:=0;
for i:=1 to l-1 do
begin
if (a[i]<>'з')and(a[i]<>'ж')and(a[i]<>'к')then halt;
if a[i]=a[i+1] then b:=b+a[i+1]
else begin
inc(j);
t1[j]:=b;
t2[j]:=length(b);
b:=a[i+1];
end
end;
inc(j);
t1[j]:=b;
t2[j]:=length(b);
max:=t2[1];poz:=1;
for i:=1 to j do
if max<t2[i] then begin
max:=t2[i];poz:=i;
end;
write(max,' - ');
g:=t1[poz];
color;
for i:=1 to j do
if (t2[i]=max) and (poz<>i) then
begin
writeln;write(' или ');g:=t1[i];color;
end;
readln;
end.
program z42;
{ На натуральном отрезке [a,b] найдите и выведите число N с наибольшей суммой своих делителей. Само число и единицу в качестве делителей не учитывать. }
uses crt;
var a,b,i,j,max,poz,ch : longint;
t1,t2 : array [1..1000] of longint;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
if a>=b then halt;
j:=0;
for ch:=a to b do
begin
inc(j);t2[j]:=ch;
for i:=2 to ch-1 do
if ch mod i=0 then t1[j]:=t1[j]+i;
end;
max:=t1[1];poz:=1;
for i:=1 to j do
if t1[i]>max then begin max:=t1[i];poz:=i; end;
writeln('N=',t2[poz]);
write('Наибольшая сумма делителей: ',t1[poz]);
readln;
end.
program z43;
{ Данные контрольной работы учащихся по информатике представлены следующим образом:
"отлично" - кол-во учащихся a
"хорошо" - кол-во учащихся b
"удовлетворительно" - кол-во учащихся c
"неудовлетворительно" - кол-во учащихся d.
Построцте или столбчатую гистрограмму с легендой, которая отражает результаты контрольной работы. }
uses crt,graph,f_text;
var g,r : integer;
a,b,c,d,n : longint;
_1,_2,_3,_4,_5 : real;
begin
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
write('d=');readln(d);
n:=a+b+c+d;if n>360 then halt;
_1:=360/n;
_5:=a*_1;
_4:=b*_1;
_3:=c*_1;
_2:=d*_1;
d:=detect;initgraph(g,r,'');
SetBkColor(0);
setcolor(2);
rectangle(10,30,50,round(_5));
rectangle(60,30,100,round(_4));
rectangle(110,30,150,round(_3));
rectangle(160,30,200,round(_2));
rectangle(10,4,50,23);
rectangle(60,4,100,23);
rectangle(110,4,150,23);
rectangle(160,4,200,23);
setfillstyle(4,10); floodfill(11,31,2);
setfillstyle(5,10); floodfill(61,31,2);
setfillstyle(8,10); floodfill(111,31,2);
setfillstyle(9,10); floodfill(161,31,2);
setcolor(15);
moveto(20,10);{ }
OutText('"5" "4"');
moveto(120,10);{ }
OutText('"3" "2"');
setfillstyle(1,8);
setcolor(0);
FillEllipse(470,200,130,130);
PieSlice(470,200,0,round(_5),120);
PieSlice(470,200,round(_5),round(_5+_4),120);
PieSlice(470,200,round(_5+_4),round(_5+_4+_3),120);
PieSlice(470,200,round(_5+_4+_3),round(_5+_4+_3+_2),120);
readln;
closegraph;
end.
program z44;
{ Результаты таблицы выигрышей денежной лотереи представлены последовательностью натуральных чисел, записанных в текстовом файле в несколько строк через пробел. Три первые цифры каждого числа - номер билета, а последние три цифры величина выигрыша. Определите и выведите номера билетов с наибольшим выигрышем. Например,
Входные данные:
10245857 1254387 132563
6377739 4237857
Выходные данные:
102 -857
423 -857. }
uses crt;
var d,max,poz,er,i,k,l,ch1,ch2 : integer;
a,b,s1,s2,c : string;
fail : text;
t1,t2 : array [1..50] of longint;
t : array [1..50] of string;
begin
clrscr;
assign(fail,'file_2.pas');
reset(fail);
readln(fail,a);
repeat
c:=a;
l:=length(a);
if a[l]<>' ' then begin inc(l);a[l]:=' '; end;
for i:=1 to l do
if a[i]=' ' then begin
inc(k);
t[k]:=b;
b:='';
end
else b:=b+a[i];
readln(fail,a);
until c=a;
close(fail);
for i:=1 to k do
begin
a:=t[i];
d:=length(a);
s1:=a[1]+a[2]+a[3];
s2:=a[d-2]+a[d-1]+a[d];
val(s1,ch1,er); t1[i]:=ch1;
val(s2,ch2,er); t2[i]:=ch2;
end;
max:=t2[1];poz:=1;
for i:=1 to k do
if t2[i]>max then begin
max:=t2[i];poz:=i;
end;
write(t1[poz],' -',max);
for i:=1 to k do
if (t2[i]=max) and (poz<>i) then
begin
writeln;write(t1[i],' -',t2[poz]);
end;
readln;
end.
program z45;
{ Экономия в строительстве дорог при строительстве ж/д. станции. }
uses crt;
var d,i,j,max:longint;rasst,max1,sum,step,st:real;
dd:array[1..100]of longint;
s:array[1..100]of real;
coo:array[1..100]of real;
begin
clrscr;
write('Введите шаг:');readln(step);
write('Введите кол-во деревень:');readln(D);
i:=1;
while i<=D do
begin
inc(j);
writeln(j,'-ая деревня:');
write('x=');readln(DD[i]);
write('y=');readln(DD[i+1]);
i:=i+2;inc(d);
end;
max:=DD[1];
for i:=2 to D do if (dd[i]>max)and(i mod 2<>0)then max:=dd[i];
i:=1;j:=0;
while st<=max+1 do
begin
inc(j);sum:=0;i:=1;
while i<=D do
begin
rasst:=sqrt(sqr(st-DD[i])+sqr(dd[i+1]));
sum:=sum+rasst;
s[j]:=sum;coo[j]:=st;i:=i+2;
end;
st:=st+step;
end;
max1:=s[1];max:=i;
for i:=2 to j do if s[i]<max1 then begin max1:=s[i];max:=i; end;
write('Ответ: ',coo[max]);
readln;
end.
program z46;
{ Строительство ж/д. станции по приципу справедливости. }
uses crt;
var d,i,j,max:longint;rasst,max1,sum,step,st:real;
dd:array[1..100]of longint;
s:array[1..100]of real;
coo:array[1..100]of real;
begin
clrscr;
write('Введите шаг:');readln(step);
write('Введите кол-во деревень:');readln(D);
i:=1;
while i<=D do
begin
inc(j);
writeln(j,'-ая деревня:');
write('x=');readln(DD[i]);
write('y=');readln(DD[i+1]);
i:=i+2;inc(d);
end;
max:=DD[1];
for i:=2 to D do if (dd[i]>max)and(i mod 2<>0)then max:=dd[i];
i:=1;j:=0;
while st<=max+1 do
begin
inc(j);i:=1;
while i<=D do
begin
rasst:=sqrt(sqr(st-DD[i])+sqr(dd[i+1]));
if i=1 then max1:=rasst else
if max1<rasst then max1:=rasst;
s[j]:=max1;coo[j]:=st;i:=i+2;
end;
st:=st+step;
end;
max1:=s[1];max:=i;
for i:=2 to j do if s[i]<max1 then begin max1:=s[i];max:=i; end;
write('Ответ: ',coo[max]);
readln;
end.
program z47;
{Фишка может двигаться по полю длиной n только вперёд.Длина хода фишки не более k.Найти число различ. путей ,по которым фишка может пройти поле от позиции 1 до позиции n
ПРИМЕР: n=4,k=2
Ответ:1,1,1
1,2
2,1 }
var p:array[1..1000,1..10] of word;
b,a,t,k,n,i,j,sum:integer;
q:boolean;
begin
write('k=');readln(k);
write('n=');readln(n);n:=n-1;
for t:=1 to n do p[1,t]:=0;i:=1;
{все возможные и невозможные варианты}
repeat;
for t:=1 to n do p[i+1,t]:=p[i,t];
inc(i);
inc(p[i,1]);
for j:=1 to n do
begin
if p[i,j]>k then
begin
inc(p[i,j+1]);
p[i,j]:=0;
end;
end;
sum:=0;
for t:=1 to n do sum:=sum+p[i,t];
until sum=n*k;
{выбрасывает ненужные варианты}
for j:=1 to i do
begin
sum:=0;
for t:=1 to n do sum:=sum+p[j,t];
if sum<>n then
for t:=1 to n do p[j,t]:=0;
end;
a:=i;
{пристыковка к левой границе }
for i:=1 to a do
begin
for j:=1 to n do
begin
t:=j+1;q:=true;
while (t<=n)and q do
begin
if p[i,t]<>0 then
begin
q:=false;
b:=p[i,t];p[i,t]:=p[i,j];
p[i,j]:=b;
end;
inc(t);
end;
end;
end;
for i:=1 to a-1 do
begin
for j:=i+1 to a do
begin
if p[i,1]<>0 then
begin
q:=true;
for t:=1 to n do
if p[i,t]<>p[j,t] then q:=false;
if q then p[j,1]:=0;
end;
end;
end;
{вывод результата}
for i:=1 to a do
begin
if p[i,1]<>0 then
begin
for t:=1 to n-1 do write(p[i,t],',');writeln(p[i,n]);
end;
end;
readln;
end.
program z48;
{ Задаётся словарь. Найти в нём все анаграммы (слова составленные из одних и тех же букв).}
uses crt;
var a,b:array[1..30]of string;
alf,sl1,sl2 :string;
i,j1,j2,n,fl :integer;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
begin
write(i,'-ое слово:');readln(a[i]);
end;
alf:=('1234567890абвгдеёжзийклмнопрстуфхцчшщъыьэюя');
for i:=1 to n do
begin
sl1:=a[i];sl2:='';
for j1:=1 to 33 do
for j2:=1 to length(sl1) do
if alf[j1]=sl1[j2] then begin
sl2:=sl2+sl1[j2];
end;
b[i]:=sl2;
end;
i:=1;
while i<=n-1 do
begin
j1:=i+1;
if fl=1 then writeln;fl:=0;
while j1<=n do
begin
if b[i]=b[j1] then
if fl=0 then begin
write(a[i],' ',a[j1]);fl:=1;
a[i]:='';a[j1]:='';
end
else begin write(' ',a[j1]);a[j1]:=''; end;inc(j1);
end;
inc(i);
end;
readln;
end.
program z49;
{Найти числа х,у,z,удовлет.условию ax+by+cz=n (пусть n=270 a=15 ,b=20,c=30 то15x+20y+30z=270) Решение:если х=0 и у=0,то 30z=270 т.е.z<=9 аналогично находим ,что у<=14,х<=18 }
uses crt;
var x,y,z,a,b,c,d,n,flag:longint;
a1,b1,c1:real;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
write('n=');readln(n);
a1:=n/a;b1:=n/b;c1:=n/c;
flag:=0;
for x:=1 to trunc(a1) do
for y:=1 to trunc(a1) do
for z:=1 to trunc(a1) do
begin
d:=a*x+b*y+c*z;
if d=n then
begin
flag:=1;
writeln('x=',x,' y=',y,' z=',z);
end;
end;
if flag=0 then write('Решений нет');
readln;
end.
program z50;
{Треуг АВС задан координатами и точкаД(х4,у4)Лежит ли точ Д внутри АВС
МЕТОД-точка внутри если сумма площадей 3-х треуг.равна площ.треуг.АВС}
uses crt;
var a,b,c,d,e,f,s,s2,s3,s4,s5:real;
x1,y1,x2,y2,x3,y3,x4,y4:real;
procedure ger(a1,b1,c1:real;var s1:real);{В процедуре исходные дан-}
var p:real; {ные формальные.При решении}
begin {им присваиваются конкрет.значения}
p:=(a1+b1+c1)/2;{полупериметр}
s1:=sqrt(p*(p-a1)*(p-b1)*(p-c1));(*ФОРМУЛА ГЕРОНА*)
end;
procedure rasst(a1,b1,a2,b2:real;var c1:real);(*процедура-2*)
begin
c1:=sqrt(sqr(a2-a1)+sqr(b2-b1)); (*формула нахождения*)
end; (*расстояния между 2-мя точками*)
begin
clrscr; (*ввод данных*)
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
write('x4=');readln(x4);
write('y4=');readln(y4);
(**)
begin
rasst(x1,y1,x2,y2,c);(*вызов процедуры -набрать ее имя*)
rasst(x2,y2,x3,y3,a); (*первые записи координаты реальных*)
rasst(x3,y3,x1,y1,b); (*точек последняя результат выполнения*)
rasst(x1,y1,x4,y4,e); (*процедуры*)
rasst(x2,y2,x4,y4,d);
rasst(x3,y3,x4,y4,f);
end;
begin
ger(a,b,c,s);(*вызываем процед.нахождения площадей треуг*)
ger(c,e,d,s2);
ger(a,f,d,s3);
ger(b,f,e,s4);
s5:=s2+s3+s4;(*находим сумму площ.треуг.*)
writeln('s=',s);writeln('s5=',s5);
end;
if round(s)=round(s5)(*сравниваем получ. округления с площ. АВС*)
then write('точка внутри') {trunc(s)-целая часть}
else write('точка вне треугольника.');
readln;
end.
program z51;
{В таб. а заменить отриц. эл.0 }
uses crt;
var a:array[1..10]of longint;
i:longint;
begin
clrscr;
for i:=1 to 10 do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to 10 do
if a[i]<0
then a[i]:=0;
for i:=1 to 10 do
begin
writeln('Ответ: a[',i,']=',a[i]);
end;
readln;
end.
program z52;
{Дана табл.из n строк и n столбцов.Найти суммы элементов записанных по диагоналям.}
uses crt;
var a:array[1..10,1..10] of real;
s1,s2:real;i,j,k,n:integer;
begin
clrscr;
write('введите кол.строк и столб.=');
readln(n);
for i:=1 to n do
for j:=1 to n do
begin
write('a[',i,',',j,']=');
readln(a[i,j]);
end;
s1:=0;s2:=0;
for k:=1 to n do
begin
s1:=s1+a[k,k];
s2:=s2+a[k,n+1-k];
end;
write('s1=',s1);
writeln('s2=',s2);
readln;
end.
program z53;
{Дана табл а(n:m) Умножить каждый элм первой строки
на а[1,1] (в том числе и элм а[1,1]) а каждый элм второй строки
на а[2,2] и т.д.}
uses crt;
var x,y,i:real;
begin
clrscr;
y:=1;
while y*y*y*y*y<=1991 do
begin
y:=y+1;
end;
x:=y-1;
readln;
end.
program z54;
{Дана линейная табл а.Найти мах элм таблицы и найти его среди элм табл b}
uses crt;
var a:array[1..10] of real;
b:array[1..10] of real;
i,j,m,n:integer;max:real;ot:boolean;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');
readln(a[i]);
end;
write('m=');readln(m);
for j:=1 to m do
begin
write('b[',j,']=');
readln(b[j]);
end;
max:=a[1];
for i:=2 to n do
begin
if a[i]>max
then max:=a[i];
end;
ot:=false;
for j:=1 to m do
if max=b[j]
then ot:=true;
if ot=true
then write('содержится')
else write('не содержится');
readln;
end.
program z55;
{Даны n-троек a,b,c.Мщжно ли построить треуг. с данными сторонами}
uses crt;
var n,i,a,b,c,k:integer;
begin
clrscr;
write('введите кол-во троек числа n ');readln(n);
for i:=1 to n do
begin
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
if (a<b+c)and(b<a+c)and(c<a+b)
then k:=k+1;
end;
writeln('введено ',n,' троек чисел');
writeln('для построения пригодны ',k);
readln;
end.
program z56;
{Напечатать в возрастающем порядке все трёхзначные числа, в десятичной записи кот. нет одинаковых цифр}
uses crt;
var i,j,k,a,l:longint;
begin
clrscr;
for i:=1 to 9 do
for j:=0 to 9 do
for k:=0 to 9 do
begin
if (i<>j)and(i<>k)and(j<>k)then
begin
a:=100*i+10*j+k;
l:=l+1;
write(' a=',a);
end;
end;
write(' кол-во чисел ',l);
readln;
end.
Program z57;
{Являются ли числа а,b,c (<=100) пифагоровыми тройками}
uses crt;
var a,c,b,cx:longint;
fil:text;
begin
clrscr;
assign(fil,'out');
rewrite(fil);
for a:=1 to 100 do
for b:=a to 100 do
for c:=1 to trunc(sqrt(a*a+b*b))+1 do
begin
if c*c=a*a+b*b then
begin
write(fil,'Пифагор ');
write(fil,a,' ');
write(fil,b,' ');
writeln(fil,c);
write('Пифагор ');
write(a,' ');
write(b,' ');
writeln(c);
end;
end;
writeln('всё');
readln;
close(fil);
end.
program z58;
{Сост.прог.опред.суммы цифр числа а}
uses crt;
var i,c,s,sum:integer;a:string;
begin
clrscr;
write('введите число a=');readln(a);{числа как текст}
sum:=0;
for i:=1 to length(a) do
begin
val(a[i],s,c);{Преобразование текста в число}
sum:=sum+s;
end;
write('sum=',sum);
readln;
end.
program z59;
{ Дан выпуклый n-угольник и точка(х1,у1) Определить а)является ли точка вершиной
б)принадлежит ли точка n-угольнику }
uses crt;
var x,y:array[1..30]of integer;
a,b,c,plo1,plo2,s:real;
i,j,k,n,x1,y1,fl,ii:integer;
procedure ger(a1,b1,c1:real;var s1:real);
var p:real;
begin
p:=(a1+b1+c1)/2;
s1:=sqrt(p*(p-a1)*(p-b1)*(p-c1));
end;
procedure rasst(a1,b1,a2,b2:integer;var c1:real);
begin
c1:=sqrt(sqr(a2-a1)+sqr(b2-b1));
end;
begin
clrscr;
write('Виедите координаты точки через пробел:');
readln(x1,y1);
write('Количество углов n=');readln(n);
for i:=1 to n do
begin
write('x',i,'=');readln(x[i]);
write('y',i,'=');readln(y[i]);
end;
for i:=1 to n-2 do
begin
j:=i+1;
k:=j+1;
rasst(x[1],y[1],x[j],y[j],a);
rasst(x[1],y[1],x[k],y[k],b);
rasst(x[j],y[j],x[k],y[k],c);
ger(a,b,c,s);
plo1:=plo1+s;
end;
for i:=1 to n do
begin
if i=n then ii:=1
else ii:=i+1;
rasst(x1,y1,x[i],y[i],a);
rasst(x1,y1,x[ii],y[ii],b);
rasst(x[i],y[i],x[ii],y[ii],c);
ger(a,b,c,s);
plo2:=plo2+s;
end;
for i:=1 to n do if(x[i]=x1)and(y[i]=y1)then fl:=1;
if fl=1 then writeln('a)Да точка является вершиной')
else writeln('a)Нет точка не является вершиной');
if round(plo1)=round(plo2)then writeln('б)Да точка принадежит n-угольнику')
else writeln('б)Нет точка не принадежит n-угольнику');
writeln('S1=',plo1,'S2=',plo2);
readln;
end.
program z60;
{Даны коор.2х точек .Найти точку на оси Х чтобы сумма расст. до данных было миним.}
uses crt;
var x1,x2,y1,y2,x,a,b:real;
i,k:integer;
c:array[1..10] of real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
if (y1=0) and (y2=0)
then
begin
write('любая из промежутка(х1,х2)');
readln;halt;
end;
if x1=x2
then
begin
write('x=',x1);
readln;halt;
end;
y1:=abs(y1);
y2:=-abs(y2);
x:=-y1*(x2-x1)/(y2-y1)+x1;
write('x=',x);
readln;
end.
§3
1. Дано натуральное число n. Верно ли, что сумма цифр этого числа яв-ся нечётной.
2. Натуральное число из n цифр яв-ся числом Армстронга, т.е. сумма его цифр возведенная в n степень, равна самому числу (153=1*1*1+5*5*5+3*3*3). Получить все числа Армстронга для n=4 и n=3.
3. Посчитать сумму цифр всех целых чисел 1 до n.
4. Дано число n. Верно ли, что это число содержит ровно 3 одинаковых цифры.
5. Имеется n бактерий красного цвета. Через 1 такт времени красная бактерия меняется на зелёную, затем через 1 такт времени делится на красную и зелёную. Сколько будет всех бактерий через k тактов времени?
6. Дано число n. Выбросить из него все единицы и пятёрки, оставив порядок цифр
ПРИМЕР: 527012 преобразуется в 2702
7. Дано натуральное число n. Выбросить из записи числа все чётные цифры.
8. Найти все числа палиндромы в диапазоне от n до m которые при возведении в квадрат так же дают палиндром.
9. Перевести число из десятичной в двоичную систему счисления.
10. Перевести число из двоичной в десятичную систему счисления.
11. Дана таблица a[m,n] содержащая числа 0,1,5 или 11. Посчитать кол-во четвёрок a[i,j], a[i+1,j], a[i,j+1], a[i+1,j+1] в каждой из которых все элементы разные.
12. Сократимая ли дробь a/b. Дробь a/b несократимая, если НОД=1.
13. Вывести в порядке возрастания все несократимые
дроби, заключённые между 0 и 1.
14. Дано предложение составить программу располагающую слова в порядке убывания длины слов.
15. Дано натуральное число А. Составить программу определения такого наибольшего N, что N!<А (А>1)
16. Составить программу для определения пройдёт ли кирпич с рёбрами a,b,c
в прямоугольное отверстие со сторонами x,y.
17. Зашифровать слово, поставив букве её номер в алфавите.
18. Расшифровать слово, поставив соответствующей цифре букву.
19. Можно ли данное натуральное число представить в виде суммы двух квадратов чисел.
20. Расположить по краям таблицы нули.
21. (1)Получить n четырёхзначных чисел, в записи которых нет двух одинаковых цифр.
22. (2)Получить n 4-знач чисел, в записи которых нет двух одинаковых цифр.
23. Тройку чисел (а,b,c) назовём Героновой тройкой, если эти числа натуральные и площадь треугольника тоже натуральное число. Вывести n Героновых троек.
24. ПРИМЕР :
Шаг0: Пустая последовательность
Шаг1: а
Шаг2: baa
Шаг3: cbaabaa
Составить программу определения заданному числу n символ на n-ом месте.
25. По заданным координатам клетки выдать координаты клеток имеющих с ней общую сторону.
26. Ввести натуральные числа n и m, и напечатать период десятичной дроби m/n, если дробь конечна, то период=0.
27. Составить программу дешифровки сообщения, закодированному по принципу. Например:
Шифр 432513 шифруем следующим образом:
НАСТОЯЩИЙ
432513432
СГУЧПВЭЛЛ
28. Дан текст. Можно ли из данных букв составить два слова.
29. Найти минимальное число, которое представляется суммой четырёх квадратов натуральных чисел не единственным образом.
30. Даны две последовательности x и y. Найти последовательность z, которую можно
получить вычёркиванием элементов как из x, так и из y.
31. Ввод '352', вывод - 'три пять два'.
32. Дан одномерный массив. Упорядочить массив удалив нули со сдвигом влево ненулевых элементов.
33. Дан текст. Отбросить повторяющиеся слова. Вывести повторяющиеся слова и их кол-во.
34. Вычислить в какой координатной четверти расположен треугольник образованный осями координат и прямой y=kx+b.
35. Вводится текст из файла INPUT.txt. Записать в файл с именем OUTPUT.txt слова в записи которых нет одинаковых букв
36. Вводится слово из файла INPUT.txt. Удалить из слова символы так, чтобы получить палиндром. Ответ записать в файл OUTPUT.txt.
37. Имеется n-вагонов стоящих в произвольном порядке и m-путей. Необходимо отсортировать вагоны по порядку т.е. 123456789...n.
38. В послед a1,a2,a3,...an каждый член, начиная с четвёртого, равен последней цифре суммы трёх предыдущих. Найти n-ый элемент последовательности.
39. Найти фальшивую монету.
40. Определить четырехзначное число n, куб суммы цифр которого равен n.
41. Сколькими различных способами можно надеть на нить семь бусин двух цветов -синего и белого. Напечатать возможные варианты.
42. Даны купюры 1$,2$,5$,10$, их кол-во неограниченно. Выдать данную зарплату всеми возможными способами.
43. В данной последовательности найти максимальную по длине подпоследовательность так, чтобы элементы были в возрастающем порядке
44. Программа "Тестовая работа".
45. Сколькими различными способами можно раскрасить грани куба в четыре цвета. Напечатать возможные варианты.
46. Грани куба можно раскрасить: a)все в белый цвет; б)все в чёрный; в)часть в белый цвет-часть в чёрный; Напечатать возможные варианты и их кол-во.
47. Сколько различных ожерелий можно составить из 2-ух белых, 2-ух синих и
2-ух красных бусин. Напечатать возможные варианты и их кол-во.
48. Вывести на печать трехзначные числа, которые делятся на свои цифры и перевертыш этого числа тоже делится на свои цифры.
49. Напечатать словарь состоящий из четырёх букв неповторяющихся в слове.
50. Изменить таблицу а[1..m,1..n] так, чтобы в строках остались элементы которые встречаются более одного раза, остальные заменить нулём.
51. Проделав процедуру нахождения суммы квадратов цифр числа получим новое число. После нескольких повторений этой процедуры получим либо 4, либо 1. Необходимо на промежутке [1..N], N - вводится, найти кол-во чисел, которые по завершению процедуры дают результат 1.(N<=30000)
52. Зашифровать текст, поменяв соседние символы.
53. Вычислить.
54. Вычислить.
55. Вычислить.
56. Вычислить.
57. Вычислить.
58. Вычислить.
59. Вычислить.
60. Вычислить.
program z1;
{ Дано нат. число n. Верно ли, что сумма цифр этого числа яв-ся нечётной.}
uses crt;
var a : string;
t,er,n,i,s : integer;
begin
clrscr;
write('введите число ');readln(a);
s:=0;
for i:=1 to length(a) do
begin
val(a[i],t,er);
s:=s+t;
end;
if s mod 2<>0
then write('сумма яв-ся нечётной')
else write('сумма яв-ся чётной');
readln;
end.
program z2;
{ Нат. число из n цифр яв-ся числом Армстронга,т.е. сумма его цифр возвед. в n степень, равна самому числу (153=1*1*1+5*5*5+3*3*3).Получить все числа Армстронга для n=4 и n=3 }
uses crt;
var i,j,k,l : integer;
n,m : longint;
begin
clrscr;
begin
for i:=1 to 9 do
for j:=0 to 9 do
for k:=0 to 9 do
for l:=0 to 9 do
begin
n:=1000*i+100*j+10*k+l;
if i*i*i*i+j*j*j*j+k*k*k*k+l*l*l*l=n
then writeln(n);
end;
end;
begin
for i:=1 to 9 do
for j:=0 to 9 do
for k:=0 to 9 do
begin
m:=100*i+10*j+k;
if i*i*i+j*j*j+k*k*k=m
then writeln(m);
end;
end;
readln;
end.
program z3;
{ Посчитать сумму цифр всех целых чисел 1 до n }
uses crt;
var i,j,n,er,s,t : integer;
a : string;
begin
clrscr;
write('до скольки считать ');readln(n);
s:=0;
for i:=1 to n do
begin
str(i,a);
for j:=1 to length(a)do
begin
val(a[j],t,er);
s:=s+t;
end;
end;
write('сумма=',s);
readln;
end.
program z4;
{ Дано число n.Верно ли,что это число содерж. ровно 3 одинаковых цифры }
uses crt;
var a : array [1..10] of integer;
n : string;
flag,er,m,min,i,j,p,l,k : integer;
begin
clrscr;
write('n=');readln(n);
l:=length(n);
for i:=1 to l do
begin
val(n[i],m,er);
a[i]:=m;
end;
{Сортировка:}
for i:=1 to l-1 do
begin
p:=i;min:=a[i];
for j:=i+1 to l do
if a[j]<min then
begin
min:=a[j];p:=j;
end;
a[p]:=a[i];
a[i]:=min;
end;
{Решение:}
i:=1;k:=1;flag:=0;
while i<=l do
begin
if a[i]<>a[i+1]
then begin
if k=3 then
begin
writeln('верно');
writeln(a[i]);
flag:=1;
end;
i:=i+1;k:=1;{обнуляем k}
end
else begin
i:=i+1;
k:=k+1;{кол-во разных цифр}
end;
end;
if flag=0 then write('нет');
readln;
end.
program z5;
{Имеется n бактерий красного цвета. Через 1 такт времени красная бактерия меняется на зелёную,затем через 1 такт времени делится на красную и зелёную.Сколько будет всех бактерий через k тактов времени? }
uses crt;
var i,k,n,z,nz,nk:longint;
begin
clrscr;
write('кол-во бактерий:');readln(n);
write('кол-во тактов времени:');readln(k);
z:=0;
for i:=1 to k do
begin
nz:=0;
nk:=0;
nz:=nz+z;
nk:=nk+z;
nz:=nz+n;
n:=nk;
z:=nz;
end;
n:=z+n;
writeln('otvet=',n);readln;
end.
program z6;
{ Дано число n.Выбросить из него все единицы и пятёрки, оставив порядок цифр }
{ ПРИМЕР: 527012 преобразуется в 2702 }
uses crt;
var b : array[1..10]of string;
a,c : string;
i,j,k : integer;
begin
clrscr;
write('введите число ');readln(a);
j:=0;k:=0;c:='';
for i:=1 to length(a)do
if (a[i]<>'1')and(a[i]<>'5')then
begin
j:=j+1;
k:=k+1;
b[j]:=a[i];
end;
for j:=1 to k do c:=c+b[j];
write('полученое число ',c);
readln;
end.
program z7;
{ Дано натуральное число n. Выбросить из записи числа все чётные цифры. }
uses crt;
var a,d : string;
er,b : integer;
i,j,k,g : longint;
c : array [1..10] of string;
f : array [1..10] of longint;
begin
clrscr;
write('введите число ');readln(a);
j:=0;k:=0;g:=0;
for i:=1 to length(a)do
begin
val(a[i],b,er);{перевод элм. в число}
if b mod 2<>0 then
begin
str(b,d);{перевод цифр в текст}
j:=j+1;k:=k+1;
c[j]:=d;{запись букв в таб}
end;
end;
for j:=1 to k do {перевод букв в}
val(c[j],f[j],er);{таб цифр}
for j:=1 to k do
g:=g*10+f[j];{получ. числа из таб}
write('полученное число ',g);
readln;
end.
program z8;
{ Найти все числа палиндромы в диапозоне от n до m которые при возведении в квадрат так же дают палиндром. }
uses crt;
var flag,b,er : integer;
b1,g,m,n : longint;
e,c,d,a : string;
function perev( a1 : string ) : string;{перевернуть слово}
var c1 : string;
i : integer;
begin
c1:='';
for i:=1 to length(a1) do c1:=a1[i]+c1;
perev:=c1;
end;
begin
clrscr;
write('n=');readln(n);
write('m=');readln(m);
flag:=0;
for g:=n to m do
begin
str(g,a); {перевод каждой цифры в текст}
c:=perev(a);
if a=c then
begin
val(a,b,er);{перевод текста в число}
b1:=sqr(b);
str(b1,d);
e:=perev(d);
if e=d then
begin
flag:=1;
writeln('ОТВЕТ:',g);
writeln(g*g);
end;
end;
end;
if flag=0 then write('решений в этом промежутке нет');
readln;
end.
program z9;
{ Перевести число из десятичной в двоичную сист. счисления }
uses crt;
var b,c : array [1..10] of longint;
j,k,g,n : longint;
begin
clrscr;
write('введите десятичное число: ');readln(n);
j:=0;k:=0;g:=0;
while n>=15 do
begin
j:=j+1;k:=k+1;
b[j]:=n mod 2; {'2' если в двоичную}
n:=n div 2;
end;
for j:=1 to k do {соединение и переворот}
g:=g*10+b[k+1-j];
write('полученое число ',g);
readln;
end.
program z10;
{ Перевести число из двоичной в десятичную сист. счисления }
uses crt;
var i,p,s,r : longint;
a : string;
er : integer;
b : array[1..10]of integer;
label met;
procedure step(a,n:longint;var p:longint);
var i:integer;
begin
p:=1;
for i:=1 to n do p:=p*a;
end;
begin
clrscr;
write('введите двоичное число ');readln(a);
r:=length(a);
for i:=1 to r do val(a[i],b[r+1-i],er);
s:=0;
for i:=1 to r do
begin
if i=1 then
begin
p:=1;
goto met;
end;
step(2,i-1,p);{2-двоичная сист.}
met : s:=s+b[i]*p;
end;
write('десятичное число ',s);
readln;
end.
program z11;
{ Дана таб a[m,n] содерж. числа 0,1,5 или 11.Посчитать кол-во четвёрок a[i,j], a[i+1,j], a[i,j+1], a[i+1,j+1] в каждой из которых все эл-ты разные. }
uses crt;
var a : array [1..10,1..10] of integer;
i,j,m,n,k : longint;
begin
clrscr;
write('кол-во строк=');readln(m);
write('кол-во столбцов=');readln(n);
for i:=1 to m do
for j:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
k:=0;
for i:=1 to m-1 do
begin
for j:=1 to n-1 do
if a[i,j]+a[i+1,j]+a[i,j+1]+a[i+1,j+1]=17
then k:=k+1;
end;
write('кол-во четвёрок:',k);
readln;
end.
program z12;
{ Сократимая ли дробь a/b }
{ Дробь a/b несократимая, если НОД=1 }
uses crt;
var m,n,ot : longint;
procedure nod(a,b:longint;var n:longint);
begin
while a<>b do
if a>b
then a:=a-b
else b:=b-a;
n:=a;
end;
begin
clrscr;
write('числитель ');readln(m);
write('знаменатель ');readln(n);
nod(m,n,ot);
if ot=1
then write('несократимая')
else write('сократимая');
readln;
end.
program z13;
{ Вывести в порядке возраст. все несократимые дроби, заключённые между 0 и 1.}
uses crt;
var a,b,p : longint;
procedure nod(m,n:longint;var t:longint);
begin
while m<>n do
if m>n
then m:=m-n
else n:=n-m;
t:=m;
end;
begin
clrscr;
for a:=1 to 14 do
for b:=2 to 15 do
if a<b then
begin
nod(a,b,p);
if p=1 then write(a,'/',b,' ');
end;
readln;
end.
program z14;
{ Дано предложение составить программу располагающую слова в порядке убывания длины слов. }
uses crt;
type slov = array [1..10] of string;
var p,b : string;
s : slov;
i,j,l:integer;
q : boolean;
procedure maxdl(ii,jj:integer;ss:slov;var ll:integer);
var t:integer;m:string;
begin
m:=ss[ii];{считает max(t)}ll:=ii;{l-номер max}
for t:=ii+1 to jj do
if length(m)<length(ss[t]) then
begin
m:=ss[t];
ll:=t;
end;
end;
begin
clrscr;
write('текст p=');readln(p);
j:=1;
for i:=1 to length(p) do
begin
b:=p[i];
if b=' ' then j:=j+1
else s[j]:=s[j]+b;{склеивание слова и заносим в таб}
end;
b:='';
for i:=1 to j do
begin
maxdl(i,j,s,l);{находим номер мах элм}
b:=s[i]; {меняем местами мах элм:}
s[i]:=s[l];
s[l]:=b;
end;
for i:=1 to j do write(s[i],' ');
readln;
end.
program z15;
{ Дано натур. число А. Сост. прог. опред. такое наибольшее N,что N!<А (А>1) }
uses crt;
var n,a,k : longint;
begin
clrscr;
write('введите число ');readln(a);
n:=0;k:=1;
while k<a do
begin
n:=n+1;
k:=k*n;
end;
n:=n-1;
write('ОТВЕТ:',n);
readln;
end.
program z16;
{ Сост. прог. для опред. пройдёт ли кирпич с рёбрами a,b,c в прямоуг. отверстие со сторонами x,y. }
uses crt;
var a,b,c,x,y,f : longint;
begin
clrscr;
write('ребро a=');readln(a);
write('ребро b=');readln(b);
write('ребро c=');readln(c);
write('сторона x=');readln(x);
write('сторона y=');readln(y);
f:=0;
if ((x>b)and(y>c))or((x>c)and(y>b)) then f:=1;
if ((x>b)and(y>a))or((x>a)and(y>b)) then f:=1;
if ((x>a)and(y>c))or((x>c)and(y>a)) then f:=1;
if f=1
then write('пройдёт')
else write('не пройдёт');
readln;
end.
program z17;
{ Зашифровать слово,поставив букве её номер в алф.}
uses crt;
var a : array [1..33] of string;
p : string;
n,i,j : integer;
begin
clrscr;
writeln('а б в г д е ё ж з и й к л м н о п р с т у ф х ц ч ш щ ъ ы ь э ю я');
for i:=1 to 34 do
begin
write('a[',i,']=');readln(a[i]);
end;
write('введите слово ');readln(p);
n:=length(p);
for j:=1 to n do
for i:=1 to 34 do
if p[j]=a[i] then write(i,' ');
readln;
end.
program z18;
{ Расшифровать слово,поставив соот. цифре букву }
uses crt;
var t : array [1..33] of string;
a : string;
m,i,j,er,k : integer;
begin
clrscr;
write('а б в г д е ё ж з и й к л м н о');
write('п р с т у ф х ч ш щ ъ ы ь э ю я');
for j:=1 to 33 do
begin
write('t[',j,']=');readln(t[j]);
end;
write('введите шифр ');readln(a);
m:=length(a);
for i:=1 to m do
if a[i]<>',' then
for j:=1 to 33 do
begin
val(a[i],k,er);
if k=j then write(t[j]);
end;
readln;
end.
program z19;
{ Можно ли данное нат. число представить в виде суммы двух квадратов чисел. }
uses crt;
var k,g,i,j,m : longint;
begin
clrscr;
write('введите число ');readln(m);
k:=0;
for i:=1 to m do
begin
for j:=1 to m do
if i*i+j*j=m then
begin
k:=k+1;
writeln(i,'*',i,'+',j,'*',j,'=',m);
end;
end;
if k>0 then write('можно ',k,' способами')
else write('нельзя');
readln;
end.
program z20;
{ Расположить по краям таб. нули }
uses crt;
var a : array [1..100,1..100] of longint;
i,j,m,n : longint;
begin
clrscr;
write('кол-во строк ');readln(m);
write('кол-во столбцов ');readln(n);
for i:=1 to m do
for j:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
for i:=1 to m do a[i,1]:=0;
for j:=1 to n do a[m,j]:=0;
for i:=1 to m do a[i,n]:=0;
for j:=1 to n do a[1,j]:=0;
for j:=1 to n do
begin
writeln(' ');
for i:=1 to m do write(' ',a[i,j]);
end;
readln;
end.
program z21;
{ Получ. n четырёхзнач. чисел ,в записи кот. нет двух одинаковых цифр. }
uses crt;
var i,j,k,l,a : longint;
m,n : integer;
begin
clrscr;
write('введите кол-во чисел ');readln(n);
m:=0;
for i:=1 to 9 do
for j:=0 to 9 do
for k:=0 to 9 do
for l:=0 to 9 do
if (i<>j)and(i<>k)and(i<>l)and(j<>k)and(j<>l)and(k<>l)and(m<=n)then
begin
a:=1000*i+100*j+k*10+l;
write(' ',a);m:=m+1;
end;
readln;
end.
program z22;
uses crt;
{ Получ. n 4-знач чисел ,в записи кот. нет двух один. цифр}
var k,b,i,m,n : longint;
a : array[1..100]of integer;
t : string;
er : integer;
begin
clrscr;
write('введите n=');readln(n);
k:=0;
for m:=1000 to 9999 do
begin
str(m,t);
if (t[1]<>t[2]) and (t[1]<>t[3]) and (t[1]<>t[4]) and
(t[2]<>t[3]) and (t[2]<>t[4]) and (t[3]<>t[4]) and (k<n)
then begin
b:=0;
for i:=1 to 4 do
begin
val(t[i],a[i],er);
b:=b*10+a[i];
end;
write(' ',b);k:=k+1;
end;
end;
readln;
end.
program z23;
{ Тройку нат. чисел (а,b,c) назовём Героновой-3 ,если эти числа нат. и площадь треуг. тоже нат. число.Вывести n Героновых троек.}
uses crt;
var n,k,s1,a,b,c : longint;
p,s : real;
begin
clrscr;
write('ограничение ');readln(n);
k:=0;
for a:=1 to 100 do
for b:=1 to 100 do
for c:=1 to 100 do
if (a+b>c)and(a+c>b)and(c+b>a)then
begin
p:=(a+b+c)/2;
s:=sqrt(p*(p-a)*(p-b)*(p-c));
s1:=round(s);
if (n>k)and(s=s1)then
begin
k:=k+1;
writeln(k,') ',a,', ',b,', ',c,' пл:',s);
end;
end;
readln;
end.
program z24;
{ ПРИМЕР : }
{ Шаг0: Пустая последовательность }
{ Шаг1: а }
{ Шаг2: baa }
{ Шаг3: cbaabaa }
{ Сост прог опред зад числу n символ на n месте }
uses crt;
var t : string;
i,m,n,k : longint;
alf : array [1..26] of string;
begin
clrscr;
write('номер символа ');readln(n);
t:='';
alf[1]:='a'; alf[9]:='i'; alf[2]:='b';
alf[10]:='j'; alf[3]:='c'; alf[11]:='k';
alf[4]:='d'; alf[12]:='l'; alf[5]:='e';
alf[13]:='m'; alf[6]:='f'; alf[14]:='n';
alf[7]:='g'; alf[15]:='o'; alf[8]:='h';
alf[16]:='p'; alf[17]:='q'; alf[22]:='v';
alf[18]:='r'; alf[23]:='w'; alf[19]:='s';
alf[24]:='x'; alf[20]:='t'; alf[25]:='y';
alf[21]:='u'; alf[26]:='z';
for i:=1 to 26 do
if n>k then
begin
t:=alf[i]+t+t;k:=k+1;
end;
write(t[n]);
readln;
end.
program z25;
{ По зад коорд клетки выдать корд клеток имеющих с ней общ. сторону }
uses crt;
var a : array [1..64,1..64] of longint;
l,k : integer;
label r;
begin
clrscr;
r : write('введите коорд.через пробел=');readln(l,k);
if (k<>1)and(k<>64)and(l<>1)and(l<>64)then
begin
writeln('a[',l,',',k+1,']');writeln('a[',l,',',k-1,']');
writeln('a[',l+1,',',k,']');writeln('a[',l-1,',',k,']');
end;
if (k=1)and(l=1)then
begin
writeln('a[',l,',',k+1,']');writeln('a[',l+1,',',k,']');
end;
if (k=64)and(l=1)then
begin
writeln('a[',l,',',k-1,']');writeln('a[',l+1,',',k,']');
end;
if (k=1)and(l=64)then
begin
writeln('a[',l,',',k+1,']');writeln('a[',l-1,',',k,']');
end;
if (k=64)and(l=64)then
begin
writeln('a[',l,',',k-1,']');writeln('a[',l-1,',',k,']');
end;
if (l=1)and(k<64)and(k>1)then
begin
writeln('a[',l+1,',',k,']');writeln('a[',l,',',k+1,']');
writeln('a[',l,',',k-1,']');
end;
if (l=64)and(k<64)and(k>1)then
begin
writeln('a[',l-1,',',k,']');writeln('a[',l,',',k+1,']');
writeln('a[',l,',',k-1,']');
end;
if (l>1)and(k<64)and(k=1)then
begin
writeln('a[',l,',',k+1,']');writeln('a[',l+1,',',k,']');
writeln('a[',l-1,',',k,']');
end;
if (l>1)and(l<64)and(k=64)then
begin
writeln('a[',l-1,',',k,']');writeln('a[',l+1,',',k,']');
writeln('a[',l,',',k-1,']');
end;
if (k>64)or(l>64)then
begin
writeln('Неверные данные');writeln('1<=k<=64,1<=l<=64');
goto r;
end;
readln;
end.
program z26;
{Ввести нат. числа n и m,и напечатать период десятичной дроби m/n если дробь конечна, то период=0 }
uses crt;
var m,n,i,j,f,flag,l,k:longint;
e:extended;b,c,a,qqq:string;label met;
function copy1(aa:string;fir:integer;en:integer):string;
{Процедура заменяющая копирование}
var w:integer;
yy:string;
begin
yy:='';
for w:=fir to en do
begin
yy:=yy+aa[w];
end;
copy1:=yy;
end;
begin
clrscr;
write('введите числитель m=');readln(m);
write('введите знаменатель n=');readln(n);
if m=n then
begin write('период=0');readln;halt;end;
e:=m/n;writeln(e);
e:=e-trunc(e);
met:str(e,a);
delete(a,3,1);
l:=length(a);l:=round(l/2);flag:=0;
flag:=1;
for i:=1 to l do
for j:=0 to l do
begin
b:=copy1(a,i,i+j);k:=i+1+j;
c:=copy1(a,k,k+j);
if (flag=1)and(b=c) then
begin
flag:=0;
qqq:=c;
end;
end;
if flag=1 then write(' Период: 0')
else write(' Период: (',qqq,')');
readln;
end.
program z27;
{Составить пр.дешифровки сообщ.,закодированному по принципу. Например:
Шифр 432513 шифруем след.образом НАСТОЯЩИЙ 432513432 СГУЧПВЭЛЛ}
uses crt;
var c:array[1..50]of string;
m,alf,h,t,j1,a:string;
r,i,j,v,w,k:longint;
l:array[1..50]of longint;er:integer;
b:array[1..50]of string;
label p,s0;
begin
clrscr;
write('введите сообщение ');readln(t);
alf:='абвгдеёжзийклмнопрстуфхцчшщъыьэюя';
write('Введите шифр: ');readln(m);
val(m,r,er);if er<>0 then
begin
writeln('Ошибка!!! Шифр - число!!!');
readln;halt;
end;
r:=length(t); k:=0;
for i:=1 to r do
for j:=1 to 33 do
begin
p:if t[i]=' ' then
begin
k:=k+1;b[k]:=' ';i:=i+1;goto p;
end;
if t[i]=alf[j] then
begin
k:=k+1;
str(j,j1);
b[k]:=j1;
end;
end;
j:=1;
for i:=1 to r do
if t[i]<>' '
then begin
c[i]:=m[j];j:=j+1;
if j=length(m) then j:=1;
end
else c[i]:=' ';
for i:=1 to r do
begin
if c[i]=' ' then l[i]:=100;
if c[i]<>' ' then
begin
val(c[i],w,er);
val(b[i],v,er);
if v<=w then v:=33+v;
l[i]:=v-w;
end;
end;
h:='';
for i:=1 to r do
begin
if l[i]=100 then h:=h+' ';
if l[i]<>100 then
begin
h:=h+alf[l[i]];
end;
end;
write(h);
readln;
end.
program z28;
{ Дан текст можно ли из данных букв составить два слова }
uses crt;
var a,b,k : string;
kol,m : integer;
i,j,n : longint;
begin
clrscr;
write('введите буквы ');readln(k);
write('введите 1-ое слово ');readln(a);
write('введите 2-ое слово ');readln(b);
n:=0;kol:=0;
for i:=1 to length(a)do
for j:=1 to length(k)do
begin
if a[i]=k[j]then
begin
n:=n+1;
end;
end;
if n>=length(a)
then begin
kol:=kol+1;
end;
m:=0;
for i:=1 to length(b)do
for j:=1 to length(k)do
begin
if b[i]=k[j]then
begin
m:=m+1;
end;
end;
if m>=length(b)
then begin
kol:=kol+1;
end;
write('можно сост ',kol,' слов');
readln;
end.
program z29;
{Найти мин. число ,которое предст суммой четырёх квадратов нат. чисел не единственным образом}
uses crt;
var i,a,b,c,d,j,k,l,min,n,max:longint;
e:array[1..10000]of longint;
p:array[1..1000]of longint;
begin
clrscr;
i:=0;
for a:=1 to 2 do
for b:=1 to 3 do
for c:=1 to 5 do
for d:=1 to 10 do
begin
n:=sqr(a)+sqr(b)+sqr(c)+sqr(d);
i:=i+1;e[i]:=n;
end;
l:=0;
for j:=1 to i-1 do
for k:=j+1 to i do
if e[j]=e[k] then
begin
l:=l+1;p[l]:=e[j];
end;
min:=p[1];max:=p[1];
for k:=2 to l do
begin
if p[k]<min then min:=p[k];
if p[k]>max then max:=p[k];
end;
write(' ОТВЕТ:min=',min,' max=',max);
readln;
end.
program z30;
{Даны две послед. x и y. Найти послед. z, которую можно получ. вычёркиванием элм как из x, так и из y }
uses crt;
var x,y,z:string;l,i,j:longint;
label m1;
begin
clrscr;
write('первая последовательность:');readln(x);
write('вторая последовательность:');readln(y);
l:=length(y);i:=1;z:='';
m1:while i<=length(x) do
begin
for j:=1 to l do
if x[i]=y[j] then begin
z:=z+x[i];inc(i);
delete(y,j,1);l:=l-1;
goto m1;
end;
inc(i);
end;
if z='' then write('последовательность невозможна')
else write('ответ:',z);
readln;
end.
program z31;
{Ввод '352', вывод-'три пять два'}
uses crt;
var a,c:string;i,j:integer;
b:array[1..10]of string;
begin
clrscr;
a:='0123456789';
b[1]:='нуль'; b[2]:='один'; b[3]:='два'; b[4]:='три';
b[5]:='четыре'; b[6]:='пять'; b[7]:='шесть';b[8]:='семь';
b[9]:='восемь'; b[10]:='девять';
write('Введите число:');readln(c);
for i:=1 to length(c) do
for j:=1 to 10 do
if c[i]=a[j] then write(b[j],' ');
readln;
end.
program z32;
{Дан одномерный массив. Упорядочить массив удалив нули со сдвигом влево ненулевых элм}
uses crt;
var b:array[1..20]of integer;i,m,n:byte;
begin
clrscr;
write('введите кол-во элм массива:');readln(n);
for i:=1 to n do
begin
write('b[',i,']=');readln(b[i]);
end;
i:=1;m:=0;
while i<=n do
begin
if b[i]=0 then inc(m)
else b[i-m]:=b[i];
inc(i);
end;
if n=m
then begin
write('в упорядоченном массиве нет элм');
readln;halt;
end;
writeln('упорядоченный массив');
for i:=1 to n-m do
write(' ',b[i]);
readln;
end.
program z33;
{Дан текст.Отбросить повторяющиеся слова. Вывести повторяющиеся слова и их кол-во}
uses crt;
var i,j,r,k,m,l:longint;a,b:string;
c:array[1..50]of string;label m1;
begin
clrscr;
write('введите слова:');readln(a);
{заносим слова в таб}
j:=1;i:=1;r:=length(a);k:=0;b:='';
while i<=r do
begin
if a[i]=' '
then begin
if b='' then goto m1;
c[j]:=b;inc(j);b:='';inc(i);inc(k);
end
else begin
b:=b+a[i];m1:inc(i);
end;
end;
{удаляем повторяющиеся элм}
i:=1;
while i<=k do
begin
for l:=i+1 to k do
if c[i]=c[l] then c[i]:=' ';
inc(i);
end;
k:=k-m;
for i:=1 to k do
writeln(c[i],' ');
writeln('кол-во слов:',k);
readln;
end.
program z34;
{Вычислить в какой коорд. четверти расположен треуг. образованный осями коорд. и прямой y=kx+b }
uses crt;
var k,b:longint;x,y:real;
begin
clrscr;
write(' введите коэф. k=');readln(k);
write(' введите коэф. b=');readln(b);
y:=b;x:=-b/k;
if (x>0)and(y>0)
then begin
write(' 1-ая четверть');readln;halt;
end;
if (x<0)and(y>0)
then begin
write(' 2-ая четверть');readln;halt;
end;
if (x<0)and(y<0)
then begin
write(' 3-ая четверть');readln;halt;
end;
if (x>0)and(y<0)
then begin
write(' 4-ая четверть');readln;halt;
end;
end.
program z35;
{Вводится текст из файла INPUT.txt .Записать в файл с именем OUTPUT.txt слова в записи
которых нет одинаковых букв }
uses crt;
var fil,fl:text;
i,j,r,k,l,h,n:longint;b,v,q:string;
c:array[1..50]of string;label m1,m3;
begin
clrscr;
assign(fl,'output.txt');
assign(fil,'input.txt');
reset(fil);readln(fil,v);{открыть для чтения}
j:=1;i:=1;r:=length(v);k:=0;b:='';
while i<=r do
begin
if v[i]=' 'then begin
if b='' then goto m1;
c[j]:=b;inc(j);b:='';inc(i);inc(k);
end
else begin
b:=b+v[i];m1:inc(i);
end;
end;
close(fil);i:=1;b:='';n:=0;
while i<=k do
begin
b:=c[i];
for l:=1 to length(b) do n:=n+1;
if n=1 then goto m3;
for l:=1 to length(b) do
for h:=l+1 to length(b) do
if b[l]=b[h] then c[i]:=' ';
m3:inc(i);
end;
rewrite(fl); {открыть для записи}
for i:=1 to k do if c[i]<>' ' then writeln(fl,c[i]);
close(fl);
for i:=1 to k do if c[i]<>' ' then writeln(c[i]);
readln;
end.
program z36;
{Вводится слово из файла INPUT.txt ;Удалить из слова символы так чтобы получ. палиндром.Ответ записать в файл OUTPUT.txt}
uses crt;
var fil,fl:text;v,c,b:string;
r,r1,i,j,flag:longint;label m;
begin
clrscr;
assign(fl,'output.txt');
assign(fil,'input.txt');
reset(fil);
readln(fil,v);
close(fil);
r1:=length(v);
j:=r1;i:=1;
c:='';b:='';flag:=0;
while i<trunc(r1/2) do
while j>trunc(r1/2) do
if v[i]<>v[j]
then begin
inc(i);j:=j-1;
end
else begin
if i=j then begin b:=v[i]+b;goto m;end;
flag:=1;b:=v[i]+b;c:=c+v[i]; inc(i);j:=j-1;
end;
m: v:=c+b;
if flag=0 then v:='палиндром невозможен';
rewrite(fl);
write(fl,v);
close(fl);
write(v);readln;
end.
program z37;
{Имеется n-вагонов стоящих в произвольном порядкеи m-путей Необходимо отсортировать вагоны по парядку т.е.12345678910 }
uses crt;
var r,m,k,d,l,max,min,h,i,j,n:longint;
a:array[1..100]of integer;
begin
clrscr;
write('Введите кол-во вагонов: ');readln(n);
for i:=1 to n do
begin
write('вагон №');readln(a[i]);
end;
write('Введите кол-во путей: ');readln(m);
if n<=m then begin
write('можно');readln;halt;
end;
l:=trunc(n/m);r:=m;k:=1;d:=0;{l-кол-во подпоследов.по m-эл.}
while r<=l*m do {r-кол. эл. в подпоследовательностях}
begin
{сортируем каждую подпоследовательность по возрастанию}
for i:=k to r-1 do
begin
h:=i;min:=a[i];
for j:=i+1 to r do
if a[j]<min then
begin
min:=a[j];
h:=j;
end;
a[h]:=a[i];a[i]:=min;
end;
min:=a[k];{находим мин.эл.в каждой подпоследовательности}
for i:=k to r do
if a[i]<min then min:=a[i];
max:=a[k];{находим мах.эл.в каждой подпоследовательности}
for i:=k to r do
if a[i]>max then max:=a[i];
if (min=k)and(max=r) then d:=d+1;{d-кол.подпоследовательн.}
k:=k+m;r:=r+m;{исследуем следующую}{где есть все эл. в порядке}
end; {возраст. 12345}
if l=d then write('можно'){если все отсортировались12345}
else write('нельзя');{если нет т.е.12349}
readln;
end.
program z38;
{В послед a1,a2,a3,...an каждый член, начиная с четвёртого, равен последней цифер суммы трёх предыдущих.Найти n-ый элм последовательности}
uses crt;
var i,n:longint;
a:array[1..2000]of longint;
begin
clrscr;
write('введите нужный вам элм:');readln(n);
writeln('введите первые 3 элм:');
for i:=1 to 3 do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=4 to n do
a[i]:=(a[i-1]+a[i-2]+a[i-3])mod 10;
write(a[n]);
readln;
end.
program z39;
{Найти фальшивую манету}
uses crt;
var a:array[1..50]of longint;
n,i,m:longint;
begin
clrscr;
write('введите массу оригенала: m=');readln(m);
write('введите кол-во монет: n=');readln(n);
writeln('введите массу каждой монеты ');
for i:=1 to n do
begin
write(i,'-ая монета=');readln(a[i]);
end;
for i:=1 to n do
if a[i]<>m then writeln('монета № ',i,' фальшивая');
readln;
end.
program z40;
{Опред 4-х знач. число n,куб суммы цифр которого равен n}
uses crt;
var i,j,k,l,n:longint;
begin
clrscr;
for i:=1 to 9 do
for j:=0 to 9 do
for k:=0 to 9 do
for l:=0 to 9 do
begin
n:=1000*i+100*j+10*k+l;
if (i+j+k+l)*(i+j+k+l)*(i+j+k+l)=n then
begin
write(' ',n);
end;
end;
readln;
end.
program z41;
{Сколькими различ способами можно надеть на нить семь бусин двух цветов-синего и белого.
Напечатать возможные варианты.}
uses crt;
var n,a,b,c,d,e,f,k,m:longint;
begin
clrscr;
for a:=1 to 2 do
for b:=1 to 2 do
for c:=1 to 2 do
for d:=1 to 2 do
for e:=1 to 2 do
for f:=1 to 2 do
for k:=1 to 2 do
begin
m:=a*1000000+b*100000+c*10000+d*1000+e*100+f*10+k;
n:=n+1;{кол-во спос.}
write(' ',m);
end;
writeln('');write(' кол-во способов:',n);
readln;
end.
program z42;
{Даны купюры 1$,2$,5$,10$ ,их кол-во неогранич.
Выдать данную зарплату всеми возможными способами }
uses crt;
var s,s1,n,a,b,c,d:longint;
begin
clrscr;
write('введите сумму денег ');readln(s);
for a:=0 to s do
for b:=0 to trunc(s/2) do
for c:=0 to trunc(s/5) do
for d:=0 to trunc(s/10) do
begin
s1:=1*a+2*b+5*c+10*d;
if s=s1 then
begin
n:=n+1;
writeln('по 1$=',a,' по 2$=',b,' по 5$=',c,' по 10$=',d);
end;
end;
write('кол-во способов:',n);
readln;
end.
program z43;
{В данной послед. найти макс. по длине подпослед. так чтобы элм были в возрастающем порядке}
uses crt;
var a:array[1..100]of longint;
b:array[1..100]of string;
max,k,i,j,k1,c,p:longint;m,x,l:string;
er,m1,m2:integer;
begin
clrscr;
write('введите кол-во элм табл ');readln(k);
for i:=1 to k do
begin
write('a[',i,']=');readln(a[i]);
end;
j:=0;x:='';k1:=0;i:=1;p:=0;
while i<=k-1 do
begin
c:=a[i]+1;
if c=a[i+1] then begin
str(a[i],l);x:=x+l;inc(i);inc(p);
end
else begin
inc(j);inc(k1);b[j]:=x;inc(i);x:='';
end;
end;
if p=k-1 then
begin
for i:=1 to k do
begin
write(a[i]);
end;
readln;halt;
end;
max:=length(b[1]);
for i:=2 to k1 do
if length(b[i])>max then
begin
m:=b[i];max:=length(b[i]);
end;
val(m,m1,er);
m2:=m1 mod 10;
m2:=m2+1;
write('Ответ:',m1,m2);
readln;
end.
program z44;{ Тестовая работа }
uses crt;
var s,s1,a,b,m,i:longint;
begin
clrscr;
i:=1;randomize;
repeat;
a:=random(30);
b:=random(20);
s:=a+b;
write(i,') ',a,'+',b,'=');readln(s1);
if s=s1 then writeln('молодец')
else begin
writeln('плохо');inc(m);
end;
inc(i);
until i=21;
write(' оценка знаний: ');
if m=1 then write('5');
if (m>=2)and(m<=3) then write('4');
if (m>3)and(m<=5) then write('3');
if (m>5)and(m<=9) then write('2');
if m>10 then write('1');
readln;
end.
program z45;
{Сколькими различ способами можно раскрасить грани куба в четыре цвета.Напечатать возможные варианты. }
uses crt;
var n,a,b,c,d,e,f,m:longint;
begin
clrscr;
for a:=1 to 4 do
for b:=1 to 4 do
begin
for c:=1 to 4 do
for d:=1 to 4 do
for e:=1 to 4 do
for f:=1 to 4 do
begin
m:=a*100000+b*10000+c*1000+d*100+e*10+f;
n:=n+1;write(' ',m);
end;
readln;
end;
writeln('');write(' кол-во способов:',n);
readln;
end.
program z46;
{Грани куба можно раскрасить:a)все в белый цвет; б)все в чёрный; в)часть в белый цвет-часть в чёрный; Напечатать возможные варианты и их кол-во. }
uses crt;
var n,a,b,c,d,e,f,m:longint;
begin
clrscr;
for a:=1 to 2 do
for b:=1 to 2 do
for c:=1 to 2 do
for d:=1 to 2 do
for e:=1 to 2 do
for f:=1 to 2 do
begin
m:=a*100000+b*10000+c*1000+d*100+e*10+f;
n:=n+1;write(' ',m);
end;
writeln('');write(' кол-во способов:',n);
readln;
end.
program z47;
{Сколько различ. ожерелий можно сост. из 2-ух белых, 2-ух синих и 2-ух красных бусин.Напечатать возможные варианты и их кол-во. }
uses crt;
var n,n1,n2,n3,a,b,c,d,e,f,m1,i:longint;
m:string;
begin
clrscr;
n:=0;n1:=0;n2:=0;n3:=0;
for a:=1 to 3 do
for b:=1 to 3 do
for c:=1 to 3 do
for d:=1 to 3 do
for e:=1 to 3 do
for f:=1 to 3 do
begin
m1:=a*100000+b*10000+c*1000+d*100+e*10+f;
str(m1,m);
for i:=1 to 6 do
begin
if m[i]='1' then inc(n1);
if m[i]='2' then inc(n2);
if m[i]='3' then inc(n3);
end;
if (n1=2)and(n2=2)and(n3=2)then
begin
inc(n);write(' ',m1);
end;
n1:=0;n2:=0;n3:=0;
end;
writeln('');write(' кол-во способов:',n);
readln;
end.
program z48;
{Вывести на печать 3-х знач.числа,кот. делятся на свои цифры и перевертыш этого числа тоже делится на свои цифры}
uses crt;
var a,b,c,m,m1:longint;
begin
clrscr;
for a:=1 to 9 do
for b:=1 to 9 do
for c:=1 to 9 do
begin
m:=a*100+b*10+c;
m1:=c*100+b*10+a;
if (m mod a=0)and(m1 mod a=0)and
(m mod b=0)and(m1 mod b=0)and
(m mod c=0)and(m1 mod c=0)and(a<>c)then writeln(' ',m);
end;
readln;
end.
program z49;
{Напечатать словарь сост. из четырёх букв непоторяющихся в слове}
uses crt;
var i,j,k,l,n:longint;
b:array[1..4]of string;
begin
clrscr;
for i:=1 to 4 do
for j:=1 to 4 do
for k:=1 to 4 do
for l:=1 to 4 do
begin
if (i<>j)and(i<>k)and(i<>l)and(j<>k)and
(j<>l)and(k<>l)then
begin
str(i,b[1]);str(j,b[2]);
str(k,b[3]);str(l,b[4]);
for n:=1 to 4 do
begin
if b[n]='1' then write('a');
if b[n]='2' then write('b');
if b[n]='3' then write('c');
if b[n]='4' then write('d');
end;
write(' ');
end;
end;
readln;
end.
program z50;
{Изменить таб а[1..m,1..n] так чтобы в строках ост. элм кот. встреч. более одного раза,остальные зменить нулём}
uses crt;
var i,j,m,n,k,flag:longint;
a:array[1..5,1..5]of longint;
begin
clrscr;
write('введите кол-во строк ');readln(m);
write('введите кол-во столбцов ');readln(n);
for j:=1 to m do
for i:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
flag:=0;
for j:=1 to m do
for i:=1 to n do
begin
k:=1;
while k<=n do
begin
if k=i then inc(k);
if a[i,j]=a[k,j] then flag:=1;
inc(k);
end;
if flag=0 then a[i,j]:=0;
flag:=0;
end;
for j:=1 to m do
begin
writeln('');
for i:=1 to n do
write(a[i,j]);
end;
readln;
end.
program z51;
{Проделав процедуру нахождения суммы квадратов цифр числа получим новое число.После нескольких
повторений этой процедуры получ. либо 4, либо 1 . Необходимо на промежутке [1..N], N - вводится, найти кол-во чисел, которые по завершению процедуры дают результат 1.(N<=30000) }
uses crt;
var er,z,d,n,i,count:integer;
function prov(a:integer):boolean;
var s:string;
begin
repeat;
str(a,s);
a:=0;
for d:=1 to length(s) do
begin
val(s[d],z,er);
a:=a+z*z;
end;
until (a=1) or (a=4);
if a=1 then prov:=true else prov:=false;
end;
begin
clrscr;
write('ограничение:');readln(n);
for i:=1 to n do
if prov(i) then inc(count);
writeln('ответ:',count);
readln;
end.
program z52;{ Зашифровать текст, поменяв соседние символы. }
uses crt;
var i,l:longint;d,a:string;
begin
clrscr;
write('введите текст:');readln(a);
l:=length(a);i:=1;
if l mod 2<>0 then l:=l-1;
while i<=l-1 do
begin
d[1]:=a[i];
a[i]:=a[i+1];
a[i+1]:=d[1];
i:=i+2;
end;
write('Ответ:',a);
readln;
end.
program z53;{Вычислить

}
uses crt;
var m,n,i : longint;
y,s : real;
begin
clrscr;
write('n = ');readln(m);
s:=2;
for i:=1 to m do s:=s*2;
n:=m;y:=12+s/12;
for n:=m-1 downto 0 do
begin
s:=s/2;
y:=12+s/12/y;
end;
write('Ответ:',y);
readln;
end.
program z54;{Вычислить }
uses crt;
var m,n,i:longint;y,s:real;
begin
clrscr;
write('n = ');readln(m);
s:=1;
for i:=2 to m do s:=s*2;
n:=m;y:=n+s/(n+1);
for n:=m-1 downto 0 do
begin
s:=s/2;
y:=n+s/(n+1)/y;
end;
write('Ответ:',y);
readln;
end.
program z55;{Вычислить Y=n1/1!+n2/2!+...+nk/k! }
uses crt;
var k,j,n,i,s1,s2:longint;y:real;
begin
clrscr;
write('n = ');readln(n);
write('k = ');readln(k);
y:=0;
for i:=1 to k do
begin
s1:=1;s2:=1;
for j:=1 to i do s1:=s1*n;
for j:=1 to i do s2:=s2*j;
y:=s1/s2+y;
end;
write('Ответ:',y);
readln;
end.
program z56;{Вычислить }
uses crt;
var m,n:longint;y:real;
begin
clrscr;
write('n = ');readln(m);
n:=m;y:=n+(n+1)/(n+2);
for n:=m-1 downto 0 do y:=n+(n+1)/(n+2)/y;
write('Ответ:',y);
readln;
end.
program z57;{Вычислить }
uses crt;
var m,n,i:longint;y,s:real;
begin
clrscr;
write(n = ');readln(m);
s:=-1;
for i:=2 to m do s:=s*(-1);
n:=m;y:=n+s/(n+1);
for n:=m-1 downto 0 do
begin
s:=s/(-1);
y:=n+s/(n+1)/y;
end;
write('Ответ:',y);
readln;
end.
program z58;{Вычислить }
uses crt;
var m,n,a,i:longint;y,f,s:real;
begin
clrscr;
write('a = ');readln(a);
write('n = ');readln(m);
s:=-1;f:=1;
for i:=1 to m do s:=s*(-1);
for i:=1 to m do f:=f*i;
n:=m;y:=n+(s*f)/(n+1);i:=m;
for n:=m-1 downto 0 do
begin
s:=s/(-1);f:=f/i;i:=i-1;
y:=n+(s*f)/(n+1)/y;
end;
write('Ответ:',y);
readln;
end.
program z59;{Вычислить }
uses crt;
var m,n,i:longint;y,s:real;
begin
clrscr;
write('n = ');readln(m);
s:=3;
for i:=1 to m do s:=s*3;
n:=m;y:=n+s/(n+1);
for n:=m-1 downto 0 do
begin
s:=s/3;
y:=n+s/(n+1)/y;
end;
write('Ответ:',y);
readln;
end.
program z60;{Вычислить }
uses crt;
var m,n,a,i:longint;y,s:real;
begin
clrscr;
write('a = ');readln(a);
write('n = ');readln(m);
s:=1;
for i:=2 to m do s:=s*a;
n:=m;y:=n+s/(n+2);
for n:=m-1 downto 0 do
begin
s:=s/a;
y:=n+s/(s+2)/y;
end;
write('Ответ:',y);
readln;
end.
§ 4
1. Задана линейная таблица, состоящая из целых чисел. Определить есть ли в этой таблице хотя бы одно число кратное k.
2. Даны n чисел. Определить яв-ся ли они взаимно простыми т.е. имеют общий делитель отличный от единицы.
3. Встречаются ли в разложении числа на простые множители одинаковые множители.
4. Найти все простые делители натурального числа N.
5. Дан текст. Найти все палиндромы (т.е. слова-перевертыши) в этом тексте.
6. Дана строка слов разделенных пробелом, в конце строки точка. Поменять местами два центральных слова если их количество четно.
7. Определить можно ли из символов входящих в строку а, составить строку с.
8. Уплотнить линейный массив удалив нули и сдвинув влево остальные элементы.
9. Найти в одномерном числовом массиве элемент, который наибольшее кол-во раз повторяется в массиве. Вывести это число и кол-во его вхождений в массив.
10. Дан одномерный массив размерностью N из положительных и отрицательных чисел. Упорядочить его так, чтобы в начале располагались все отрицательные, а затем все положительные элементы, сохранив порядок следования и не создавая новый массив.
11. Дан прямоугольный целочисленный массив размером N*N. Определить яв-ся ли данный массив магическим квадратом, т.е. сумма элементов в строках, столбцах и на главных диагоналях равна.
12. Составить программу, которая размещает элемент s неупорядоченного массива A на место, соответствующее ему в упорядоченном массиве.
13. Женщина шла на базар и разбила яйца, лежавшие у неё в корзине. Она сказала, что не знает сколько яиц у неё было, но когда она брала по 2,3,4,5 и 6 яиц то оставалось в остатке одно. Когда же она брала по 7 яиц, то ничего не оставалось в остатке. Сколько яиц могло быть в корзине.
14. Вводится слово из N различных букв (N<10). Получить все возможные слова из S букв этого слова(S<=N)
15. Дана матрица N*N.
1)заменить нулями элементы, расположенные на главной диагонали и выше (ниже) её;
2)найти сумму элементов, расположенных на побочной диагонали и выше (ниже) её;
3)найти максимальный из элементов, расположенных на побочной диагонали и выше (ниже) её;
4) найти произведение элементов, расположенных на побочной диагонали и выше (ниже) её.
16. Из семи красных и восьми белых роз требуется составить букет из пяти роз. Перечислить все возможные варианты.
17. На клеточном листе бумаги размером MхN расположены прямоугольники. Задан массив MхN в котором элемент a[i,j]=1 если клетка листа (i,j) яв-ся частью прямоугольника, и a[i,j]=0 если это пустая клетка. Напечатать число прямоугольников.
18. Напечатать все совершенные числа меньше m}. Справка: Совершенными называются числа сумма делителей включая 1, которых равна самому числу, делители не должны быть равны самому числу.
19. Дан прямоугольный массив состоящий из различных элементов. В каждой строке выбирается минимальный элемент, а среди них максимальный элемент. Напечатать номер строки в кот расположено полученное число.
20. Дана таблица, поменять местами строки и столбцы.
21. Любую сумму больше 7 можно выплатить без сдачи трешками и пятерками т.е. для n>7 найти все целые неотрицательные а и b, что 3а+5b=n
22. Два натуральных числа называются дружественными, если каждое из них равно сумме всех делителей другого, кроме самого этого числа. Найти все пары в данном
диапазоне.
23. Найти наибольшее число из данного диапазона у которого наибольшее количество делителей.
24. Два двузначных числа, записанных одно за другим образуют четырехзначное число, которое делится на их произведение. Найти эти числа.
25. Найти натуральные числа из данного диапазона у которых количество делителей является произведением двух простых чисел.
62. Ввести список фамилий в любом порядке. Распечатать список в алфавитном порядке.
27. Определить, какая цифра находится в позиции числовой последовательности. 1011112131415...979899-подряд выписаны все двузначные числа.
28. Вывести список шестизначных чётных чисел, делящихся без остатка на сумму своих цифр в 10 колонок.
29. Вывести список трёхзначных чисел, делящихся без остатка на произведение своих цифр в 5 колонок. Поставить защиту от деления на ноль.
30. Вывести список симметричных нечётных чисел (например 34543 или 70507) в 5 колонок.
31. Вывести список шестизначных "счастливых" чисел (сумма первых трёх цифр равна сумме трёх последних), кратных семи в 10 колонок
32. Определить кол-во слов в строке. Слова отделяются одним или несколькими пробелами.
33. Определить номера позиций и кол-во повторений запрашиваемого символа в строке введённой с клавиатуры.
34. Найти и заменить определённый символ в строке введённой с клавиатуры. Программа должна запрашивать заменяемый и заменяющий символы, а также подтверждение каждой замены символа с сообщением его номера в строке.
35. Определить самое короткое и самое длинное слово в строке введённой с клавиатуры.
36. Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы вначале шли элементы меньше среднего значения по всему массиву С.
37. Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы элементы массива А имели в С нечётные номера.
38. Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы элементы массива А имели номера от 51 до 150.
39. Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы элементы А и В чередовались по 10 штук.
40. Составить программу, создающую из файла копию, но записанную задом наперёд.
41. Составить программу, удаляющую в файле текст после первой точки.
42. Найти остаток от деления числа, записываемого с помощью
k семёрок, на число а (k и a -заданные натуральные числа).
43. На интервале (1000 .. 9999) найти все простые числа, каждое из которых обладает тем свойством, что сумма первой и второй цифр записи этого числа равна сумме третьей и четвёртой цифр.
44. Среди простых чисел, не превосходящих n, найти такое, в двоичной записи которого максимальное число единиц.
45. Найти двоичное представление для чётных совершенных чисел вида 2(p-1)*((2p)-1)
46. Задана последовательность состоящая из единиц и нулей. Определить кол-во М-значных чисел, входящих в указанную последовательность, которые делятся на 21.
47. Можно ли заданное натуральное число M представить в виде суммы двух квадратов натуральных чисел.
48. Найти минимальное число, которое представляется суммой четырёх квадратов натуральных чисел не единственным образом.
49. Даны числа M,N и двумерный массив M*N. Некоторый элемент массива назовем седловой точкой, если он яв-ся одновременно наименьшим в своей строке и наибольшим в своём столбце. Напечатать координаты какой-нибудь седловой точки.
50. Дан массив А(N) и число М. Найти такое множество элементов
A(i1),A(i2),...A(ik) (1<=i1<...<ik<=N), что A(i1)+A(i2)+...+A(ik)=M.
Предполагается, что такое множество заведомо существует.
51. Получить все способы расстановки шести книг разных авторов.
52. Для участия в конкурсе из класса в 20 человек требуется выбрать троих.
Сколькими способами это можно сделать.
53. Получить все четырёхзначные числа, у которых все цифры нечётные.
54. Даны 4 точки заданные координатами. Является ли данная фигура трапецией.
55. Определить наименшее число, которое при делении на 2,3,4,5,6,7,8,9 дает одинаковые остатки - 1.
56. Определить k - кол-во трёхзначных чисел сумма цифр которых равна a. (1<=a<=27)
57. Даны стороны треугольника : a,b,c. Вычислить косинус углов по теореме косинусов : sqr(c)=sqr(a)+sqr(b)-2ab*cos(alfa)
58. Пара кроликов каждый год дает приплод двух (самку и самца) которые через 2 месяца способны давать новый приплод. Сколько кроликов будет через год.
59. Дано предложение t. Заменить в нем слово 'потоп' словом 'потопкот'.
60. Дан текст. Определить в нем кол-во слов 'кот'.
program z1;
{Зад. лин таб, сост из цел. чисел. Опред есть ли в этой таб хотя бы одно число кратное k}
uses crt;
var a : array [1..100] of longint;
i,k,n : longint;
begin
clrscr;
write('введите кол-во элм таблицы:');readln(n);
write('введите число:');readln(k);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n do if k mod a[i]=0 then write(a[i],' ');
readln;
end.
program z2;
{Даны n чисел. Опред яв-ся ли они взаимно простыми т.е. имеют общий делитель отлич. от единицы }
uses crt;
var a : array [1..100] of longint;
i,max,n,j : longint;
begin
clrscr;
write('введите кол-во чисел:');readln(n);
for i:=1 to n do
begin
write(i,') число:');readln(a[i]); end;
max:=a[1];
for i:=2 to n do if max<a[i] then max:=a[i];
for i:=2 to max do
for j:=1 to n do
if a[j] mod i=0 then beginwrite('ДА');readln;halt;end
else beginwrite('НЕТ');readln;halt;end;
readln;
end.
program z3;
{Встречаются ли в разложении числа на простые множители одинаковые множители}
uses crt;
var b:array[1..1000] of longint;
c:array[1..100] of longint;
i,j,a,k,flag:longint;label met;
begin
clrscr;
write('Введите число:');readln(k);
b[1]:=2;a:=3;j:=1;flag:=0;
met:while a<=k do
begin
for i:=2 to a-1 do
if a mod i=0 then flag:=1;
if flag=0 then begin
inc(j);b[j]:=a;inc(a);goto met;
end;
flag:=0;inc(a);
end;
j:=0;i:=1;
while k>1 do
if k mod b[i]=0 then begin
inc(j);c[j]:=b[i];k:=k div b[i];
end
else inc(i);
for i:=1 to j-1 do
for a:=i+1 to j do
if c[i]=c[a] then begin
write('повторяются');readln;halt;
end;
write('не повторяются');readln;
end.
program z4;{Найти все простые делители натурального числа N}
uses crt;
var i,n,j,a,flag:longint;
b:array[1..1000] of longint;label met;
begin
clrscr;
write('Введите число: ');readln(n);
b[1]:=2;a:=3;j:=1;flag:=0;
met:while a<=n do
begin
for i:=2 to a-1 do
if a mod i=0 then flag:=1;
if flag=0 then begin
inc(j);b[j]:=a;inc(a);goto met;
end;
flag:=0;inc(a);
end;
for i:=1 to j do if n mod b[i]=0 then write(b[i],' ');readln;
end.
program z5;
{ Дан текст. Найти все палиндромы (т.е. слова-перевертыши) в этом тексте.}
uses crt;
var
b,a,k: string;
i,j,q: longint;
c: array[1..30] of string;
begin
clrscr; {очищаем дисплей}
write('Ведите текст разделенный пробелами: ');
readln(a); {чтение введенного текста}
b:=''; {инициализация переменных}
j:=1;
k:='';
for i:=1 to length(a) do if (a[i]=' ') then begin {ищем пробелы в тексте}
c[j]:=b; {если есть ' ', то }
inc(j); { запоминаем слово }
b:='';
end else b:=b+a[i]; c[j]:=b;
for i:=1 to j do begin {проверяем, является ли слово палиндромом}
b:=c[i];
k:='';
for q:=1 to length(b) do k:=b[q]+k;
if b=k then writeln(b); {сравнение и вывод результата}
end;
write('Нажмите любую клавишу...'); readln;
end.
program z6;
{ Дана строка слов разделенных пробелом ,в конце строки точка. Поменять местами два центральных слова если их количество четно}
uses crt;
var a,b:string;i,j,l:longint;
c:array[1..30]of string;
begin
clrscr;
write('введите текст: ');readln(a);
b:='';j:=1;l:=length(a);
if (a[l]<>'.')then begin
writeln(' ОШИБКА!!!');
write(' В конце должна стоять точка');
readln;halt;
end;
for i:=1 to l do
if (a[i]=' ')or(a[i]='.')then begin
c[j]:=b;b:='';inc(j);
end
else b:=b+a[i];j:=j-1;
if j mod 2<>0 then
beginwrite('количество слов нечетно');readln;halt;end;
l:=j div 2;b:=c[l];c[l]:=c[l+1];c[l+1]:=b;
for i:=1 to j do write(c[i],' ');
readln;
end.
program z7;
{Опред можно ли из символов входящих в строку а,сост строку с}
uses crt;
var la,lc,i,j:longint;a,c:string;label m;
begin
clrscr;
write('введите строку a: ');readln(a);
write('введите строку c: ');readln(c);
la:=length(a);lc:=length(c);
if la<lc then begin writeln('ОШИБКА!!!');
write('строка а > строки c');readln;halt;end;
m:for i:=1 to la do
for j:=1 to lc do
if a[i]=c[j] then begin
delete(a,i,1);la:=la-1;
delete(c,j,1);lc:=lc-1;goto m;
end;
if c='' then write('можно')
else write('нельзя');readln;
end.
program z8;
{ Уплотнить линейный массив удалив нули и сдвинув влево остальные элм.}
uses crt;
var m,i,k:longint; a:array[1..100]of longint;
begin
clrscr;
write('введите кол-во элм таблицы: ');readln(k);
for i:=1 to k do
begin
write('a[',i,']=');readln(a[i]);
end;
m:=0;
for i:=1 to k do
if a[i]=0 then inc(m)
else a[i-m]:=a[i];k:=k-m;
for i:=1 to k do write(a[i],' ');readln;
end.
program z9; {Найти в одномерном числовом массиве элм. , который наибольшее кол-во раз повторяется в массиве.Вывести это число и кол-во его вхождений в массив }
uses crt;
var a:array[1..1000]of longint;
b:array[1..500]of longint;
i,j,n,k,l,max,min:longint;
begin
clrscr;
write('Введите кол-во элм таблицы:');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n-1 do
for j:=i+1 to n do
if a[i]>a[j] then begin
min:=a[j];a[j]:=a[i];
a[i]:=min;
end;
l:=a[1];j:=0;k:=1;
for i:=2 to n+1 do
if l=a[i] then inc(k)
else begin
inc(j);b[j]:=k;k:=1;
l:=a[i];
end;
max:=b[1];
for i:=2 to j do if max<b[i] then max:=b[i];
writeln('число:',a[1]);
write('их кол-во:',max);readln;
end.
program z10;
{Дан одномерный массив размерностью N из положительных и отрицательных чисел .Упорядочить так ,чтобы в начале располагались все отрицательные ,а затем все положительные ,сохранив порядок
следования и не создавая новый массив.}
uses crt;
var a:array[1..100]of longint;
i,j,n,k,l:longint;
begin
clrscr;
write('Введите кол-во элм таблицы:');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
j:=1;
for i:=1 to n do
if a[i]<0 then begin
l:=a[i];for k:=i downto j do
a[k]:=a[k-1];a[j]:=l;inc(j);
end;
for i:=1 to n do write(a[i],' ; ');readln;
end.
program z11; {Дан прямоугольный целочисленний массив размером N*N.Опред. яв-ся ли данный массив магическим квадратом, т.е. сумма элм в строках, столбцах и на главных диагоналях равна }
uses crt;
var a:array[1..100,1..100]of longint;
b:array[1..100]of longint; i,j,l,n:longint;
begin
clrscr;
write('n=');readln(n);
for i:=1 to n do
for j:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
j:=1;l:=1;
repeat;
for i:=1 to n do b[j]:=b[j]+a[i,l];
inc(j);inc(l);
until l>n;
l:=1;
repeat;
for i:=1 to n do b[j]:=b[j]+a[l,i];
inc(j);inc(l);
until l>n;
i:=1;l:=1;
repeat;
b[j]:=b[j]+a[i,l];
inc(i);inc(l);
until l>n;
i:=n;l:=1;inc(j);
repeat;
b[j]:=b[j]+a[i,l];
inc(l);i:=i-1;
until l>n; j:=n+n+2;l:=1;
for i:=2 to j do if b[1]=b[i] then inc(l);
if l=j then write('ДА')
else write('НЕТ');readln;
end.
program z12;
{Сост. прог. , которая размещает элм. s неупорядоченного массива A на место, соостветствующее ему в упорядоченном массиве}
uses crt;
var a:array[1..100]of longint;
b:array[1..100]of longint;
i,j,n,a1,p,ap,min:longint;
begin
clrscr;
write('Введите кол-во элм таблицы:');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);b[i]:=a[i];
end;
write('Введите число:');readln(a1);
write('Введите его позицию:');readln(ap);
for i:=1 to n-1 do
for j:=i+1 to n do
if a[i]>a[j] then begin
min:=a[j];
a[j]:=a[i];
a[i]:=min;
end;
for i:=1 to n do if a1=a[i] then p:=i;
min:=b[ap];
b[ap]:=b[p];
b[p]:=min;
for i:=1 to n do write(b[i],' ');readln;
end.
program z13;
{Женщина шла на базар и разбила яйца,лежавшие у неё в корзине Она сказала,что не знает сколько яиц у неё было,но когда она брала по 2,3,4,5 и 6 яиц то оставалось в остатке одно.Когда же она брала по 7 яиц, то ничего не оставалось в остатке. Сколько яиц могло быть в корзине}
uses crt;
var i:longint;
begin
clrscr;textcolor(10);
for i:=1 to 5000 do
if (i mod 2=1)and(i mod 3=1)and
(i mod 4=1)and(i mod 5=1)and
(i mod 6=1)and(i mod 7=0)then
begin
writeln('может быть:',i);
end;
write('Ну смотря какая у женщины корзина!!!');readln;
end.
program z14;
{Вводится слово из N различных букв (N<10). Получить все возможные слова из S букв этого слова(S<=N)}
uses crt,graph;
var do1,po1,a,i1:string;s,i2,do2,po2,i,j,k,l,m,fl1,fl2,n:longint;
er:integer;b:array[1..100]of longint;
begin
clrscr;textcolor(10);
write('Введите слово:');readln(a);
write('Введите длину нужных вам слов:');readln(s);
n:=length(a);
if n>9 then beginwrite('ОШИБКА!!! n<10 ');readln;halt;end;
if s>n then beginwrite('ОШИБКА!!! s<=n ');readln;halt;end;
for i:=1 to s do do1:=do1+'0';
for i:=1 to s do po1:=po1+'9';
do1[1]:='1';val(do1,do2,er);val(po1,po2,er);j:=0;
for i:=do2 to po2 do
begin
str(i,i1);fl1:=0;fl2:=0;
for m:=1 to length(i1) do
begin
val(i1[m],i2,er);
if (n<i2)or(i2=0)then fl2:=1;
end;
for l:=1 to s-1 do
for k:=l+1 to s do
if (i1[l]=i1[k])or(fl2=1)then fl1:=1;
if fl1=0 then begin
inc(j);b[j]:=i;
end;
end;
for i:=1 to j do
begin
str(b[i],do1);
for k:=1 to length(i1)do
begin
if do1[k]='1'then write(a[1]);
if do1[k]='2'then write(a[2]);
if do1[k]='3'then write(a[3]);
if do1[k]='4'then write(a[4]);
if do1[k]='5'then write(a[5]);
if do1[k]='6'then write(a[6]);
if do1[k]='7'then write(a[7]);
if do1[k]='8'then write(a[8]);
if do1[k]='9'then write(a[9]);
end;write(' ');
end;readln;
end.
program z15;
{ Дана матрица N*N.
1) заменить нулями элементы, расположенные на главной диагонали и выше (ниже) её;
2) найти сумму элементов, расположенных на побочной диагонали и выше (ниже) её;
3) найти максимальный из элементов, расположенных на побочной диагонали и выше (ниже) её;
4) найти произведение элементов, расположенных на побочной диагонали и выше (ниже) её. }
uses crt;
var a : array [1..50,1..50] of longint;
b : array [1..50,1..50] of longint;
i,j,n,l,max,sum : longint;
procedure prisvoi;
begin
for i:=1 to n do
for j:=1 to n do a[i,j]:=b[i,j];
end;
procedure print;
begin
textcolor(7);
for j:=1 to n do
begin
writeln;
for i:=1 to n do write(a[i,j],' ');
end;
writeln;
end;
begin
clrscr;textcolor(10);
write('Введите кол-во элементов таблицы N*N N=');readln(n);
for i:=1 to n do
for j:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);b[i,j]:=a[i,j];
end;
{1}
for i:=1 to n do
for j:=1 to i do a[i,j]:=0;
print;prisvoi;
for i:=1 to n do
for j:=i to n do a[i,j]:=0;
print;prisvoi;l:=0;sum:=0;
{2}
for i:=1 to n do
begin
for j:=n downto n-l do sum:=sum+a[i,j];
inc(l);
end;textcolor(11);
write('сумма элементов по побочной диагонали и ниже: ',sum);
writeln;l:=0;sum:=0;
for j:=1 to n do
begin
for i:=1 to n-l do sum:=sum+a[i,j];
inc(l);
end;
write('сумма элементов по побочной диагонали и выше: ',sum);
writeln('');max:=a[1,1];
{3}
for i:=1 to n do
for j:=1 to i do
if a[i,j]>max then max:=a[i,j];textcolor(9);
write('максимальный элемент по главной диагонали и выше: ',max);
writeln;max:=a[1,1];
for i:=1 to n do
for j:=i to n do
if a[i,j]>max then max:=a[i,j];
write('максимальный элемент по главной диагонали и ниже: ',max);
writeln;l:=0;sum:=1;
{4}
for i:=1 to n do
begin
for j:=n downto n-l do sum:=sum*a[i,j];
inc(l);
end;textcolor(4);
write('произведение элементов по побочной диагонали и ниже: ',sum);
writeln;l:=0;sum:=1;
for j:=1 to n do
begin
for i:=1 to n-l do sum:=sum*a[i,j];
inc(l);
end;
write('произведение элементов по побочной диагонали и выше: ',sum);
writeln;
readln;
end.
program z16;
{ Из семи красных и восьми белых роз требуется составить букет из пяти роз. Перечислить все возможные варианты. }
uses crt,f_mouse;
var m,k,i1,i2,i3,i4,i5,p3,j,s1,s2 :longint;
er :integer;
p1 :string;
p:array[1..1000]of longint;
procedure symma(g:longint;var p2:longint);
begin
p2:=0;str(g,p1);
for i3:=1 to 5 do
begin
val(p1[i3],j,er);
p2:=p2+j;
end;
end;
begin
clrscr;
for i1:=1 to 2 do
for i2:=1 to 2 do
for i3:=1 to 2 do
for i4:=1 to 2 do
for i5:=1 to 2 do
begin
m:=i5+i4*10+i3*100+i2*1000+i1*10000;
inc(k);p[k]:=m;
end;
for i1:=1 to k-1 do
for i2:=i1+1 to k do
begin
symma(p[i1],s1);
symma(p[i2],s2);
if s1=s2 then p[i2]:=0;
end;
for i2:=1 to k do
if p[i2]<>0 then write(p[i2],' ');
readln;
end.
program z17;
{ На клеточном листе бумаги размером M/N расположены прямоугольники. Задан массив M/N в котором элемент a[i,j]=1 если клетка листа (i,j) яв-ся частью прямоугольника, и a[i,j]=0 если это пустая клетка. Напечатать число прямоугольников. }
uses crt;
var i,j,m,n,k:longint;
a:array[1..100,1..100]of integer;
begin
clrscr;
write('m=');readln(m);
write('n=');readln(n);
for j:=1 to n do
for i:=1 to m do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
for j:=1 to n do
for i:=1 to m do
if a[i,j]=1 then
if (a[i+1,j]=0)and(a[i+1,j+1]=0)and(a[i,j+1]=0)then inc(k);
write('Ответ: ',k);
readln;
end.
program z18; {Напечатать все совершенные числа меньше m} { Справка: Совершенными называются числа сумма делителей включая 1, которых равна самому числу, делители не должны быть равны самому числу }
uses crt;
var i,j,k,m,sum:longint;
b:array[1..50]of longint;
begin
clrscr;
write('введите ограничение: ');readln(m);
i:=1;{write('1');}
while i<=m do
begin
sum:=0;k:=1;
for j:=1 to i-1 do if i mod j=0 then begin
b[k]:=j;inc(k);
end;
for j:=1 to k-1 do sum:=sum+b[j];
if i=sum then write(' ',i);inc(i);
end;
readln;
end.
program z19;{Дан прямоугю массив сост из различ элм. В каждой строке выбирается мин. элм., а среди них максю элм. Напечатать номер строки в кот расположено получ. число }
uses crt;
var i,j,k,m,n,min,max:longint;
a:array[1..50,1..50]of longint;
b:array[1..70]of longint;
begin
clrscr;textcolor(11);
write('введите кол-во столбцов: ');readln(m);
write('введите кол-во строк: ');readln(n);
for j:=1 to n do
for i:=1 to m do
begin
write('a[',j,',',i,']=');readln(a[j,i]);
end;
k:=1;
for j:=1 to n do
begin
min:=a[j,1];
for i:=2 to m do
if min>a[j,i] then min:=a[j,i];
b[k]:=min;inc(k);
end;
max:=b[1];
for j:=2 to k-1 do if max<b[j] then max:=b[j];
for j:=1 to n do
for i:=1 to m do
if a[j,i]=max then begin
write('№ строки:',j);
readln;halt;
end;
end.
program z20;
{Дана таблица, поменять местами строки и столбцы}
uses crt;
var i,j,m,n:longint;
a:array[1..20,1..30]of longint;
b:array[1..30,1..20]of longint;
begin
clrscr;textcolor(11);
write('введите кол-во столбцов: ');readln(m);
write('введите кол-во строк: ');readln(n);
for i:=1 to m do
for j:=1 to n do
begin
write('a[',i,',',j,']=');readln(a[i,j]);
end;
for i:=1 to m do
for j:=1 to n do b[j,i]:=a[i,j];
write('исходная таблица:');
for j:=1 to n do
begin
writeln('');
for i:=1 to m do write(' ',a[i,j]);
end;
writeln('');write('Ответ:');
for j:=1 to m do
begin
writeln('');
for i:=1 to n do write(' ',b[i,j]);
end;
readln;
end.
program z21;
{Любую сумму больше 7 можно выплатить без сдачи трешками и пятерками т.е.для n>7 найти все целые неотриц. а и в ,что 3а+5в=n}
uses crt;
var n,a,b:longint;label met;
begin
met: clrscr;
write('введите число n=');readln (n);
if n<8 then begin
write('n>7введите число n=');goto met;
end;
for a:=0 to trunc(n/2) do
for b:=0 to trunc(n/2) do
if a*3+b*5=n then writeln('a=',a,' b=',b);
readln;
end.
program z22;
{Два натур. числа наз. дружественными ,если каждое из них равно сумме всех делителей другого,
кроме самого этого числа.Найти все пары в данном диапозоне.}
uses crt;
var i,j,n,k,s,p1,p2,fl:longint;
procedure delit(l:longint;var s:longint);
var m:longint;
begin
s:=0;
for m:=1 to l-1 do
if l mod m=0 then s:=s+m;
end;
begin
clrscr;
write('введите диапозон через пробел:');readln(n,k);
for i:=n to k do
for j:=n to k do
begin
fl:=0;
delit(i,s);p1:=s;
delit(j,s);p2:=s;
if (p1=j)and (p2=i)then writeln(p1,' ',p2);
end;
readln;
end.
program z23;
{Найти наибольшее число из данного диапозона у которого наибольшее колич.делителей}
uses crt;
var i,j,n,k,kk,p,max:longint;
a:array[1..1000]of longint;
begin
clrscr;
write('введите диапозон через пробел:');readln(n,k);
for i:=n to k do
begin
kk:=0;
for j:=2 to i-1 do if i mod j=0 then inc(kk);a[i]:=kk;
end;
max:=a[n];
for i:=n+1 to k do
if max<a[i] then begin
max:=a[i];p:=i;
end;
writeln('Ответ: ',p);
readln;
end.
program z24;
{Два двузнач.числа,записанных одно за другим образуют четырехзнач.число,которое делится на
их произведение.Найти эти числа.}
uses crt;
var i,j,m,p:longint;i1,j1,m1:string;
er:integer;
begin
clrscr;
for i:=10 to 99 do
for j:=10 to 99 do
begin
str(i,i1);str(j,j1);
m1:=i1+j1;val(m1,m,er);p:=i*j;
if m mod p=0 then writeln(m);
end;
readln;
end.
program z25;
{Найти натуральные числа из данного диапозона у которых колич.делителей является произведением
двух простых чисел.}
uses crt;
var i,j,n,k,kk,a,fl,l:longint;
b:array[1..100]of longint;label m,met;
begin
clrscr;
write('введите диапозон через пробел:');readln(n,k);
b[1]:=2;a:=3;j:=1;fl:=0;
met:while a<=100 do
begin
for i:=2 to a-1 do if a mod i=0 then fl:=1;
if fl=0 then begin
inc(j);b[j]:=a;inc(a);goto met;
end; fl:=0;inc(a);
end;i:=n;
m:while i<=k do
beginkk:=0;
for j:=1 to i do if i mod j=0 then inc(kk);
for j:=1 to trunc(kk/2) do
for l:=1 to trunc(kk/2) do
if kk=b[j]*b[l] then begin
writeln(i);inc(i);goto m;
end; inc(i);
end;
readln;
end.
program z26;
{Ввести список фамилий в любом порядке. Распечатать список в алфавитном порядке.}
uses crt;
var i,j,l,n,k:longint;sl1,sl2,a:string;
alf,b:array[1..10] of string;label m;
begin
clrscr;
write('введите количество фамилий:');readln(n);
writeln('введите фамили:');
for i:=1 to n do
begin
write(i,') ');readln(b[i]);
end;
i:=1;a:='абвгдеёжзийклмнопрстуфхцчшщъыьэюя';
while i<=n-1 do
begin
j:=2;
while j<=n do
begin
sl1:=b[i];sl2:=b[j];l:=0;
for k:=1 to 33 do
begin
inc(l);
if (sl1[l]=a[k])and(sl2[l]<>a[k])or(length(sl1)<l)or(length(sl2)<l)
then goto m;
if (sl1[l]<>a[k])and(sl2[l]=a[k])then
begin
alf[1]:=b[j];
b[j]:=b[i];
b[i]:=alf[1];
goto m;
end;
end;
m:inc(j);
end;
inc(i);
end;clrscr;
for i:=1 to n do writeln(i,') ',b[i]);
readln;
end.
program z27;
{Определить,какая цифра находится в позиции числовой последовательности-1011112131415...
...979899-подряд выписаны все двузнач.числа}
uses crt;
var i,k:longint;j,a:string;
begin
clrscr;
write('введите номер :');readln(k);
for i:=10 to 99 do
begin
str(i,j);
a:=a+j;
end;
write('Ответ:',a[k]);
readln;
end.
program z28;
{ Вывести список шестизначных чётных чисел,делящихся без остатка на сумму своих цифр в 10 колонок}
uses crt;
var i,j,k,m,j1,l:longint;
i1:string;er:integer;
begin
clrscr;
textcolor(10);i:=100000;
while i<=999998 do
begin
m:=0;str(i,i1);
for j:=1 to 6 do
begin
val(i1[j],j1,er);m:=m+j1;
end;
if i mod m=0 then
begin
inc(l);inc(k);
if k=11 then begin writeln('');k:=1; end;
if l=240 then begin l:=0;readln; end;
write(i,' ');
end;i:=i+2;
end;
readln;
end.
program z29;
{ Вывести список трёхзначных чисел ,делящихся без остатка на произведение своих цифр в 5 колонок
Поставить защиту от деления на ноль}
uses crt;
var i,j,k,m,j1:longint;
i1:string;er:integer;label mmm;
begin
clrscr;
textcolor(11);i:=10;
while i<=999 do
begin
m:=1;str(i,i1);
for j:=1 to 3 do
begin
val(i1[j],j1,er);m:=m*j1;
end;
if m=0 then goto mmm;
if i mod m=0 then
begin
inc(k);if k=6 then begin writeln('');k:=1; end;
write(i,' ');
end;mmm: inc(i);
end;
readln;
end.
program z30;
{ Вывести список симмитричных нечётных чисел (например 34543 или 70507) в 5 колонок}
uses crt;
var i,j,k,m,j1,l:longint;
i1:string;er:integer;
begin
clrscr;
textcolor(10);i:=10001;
while i<=99999 do
begin
m:=0;str(i,i1);
for j:=5 downto 1 do
begin
val(i1[j],j1,er);m:=m*10+j1;
end;
if i=m then begin
inc(l);inc(k);
if k=6 then begin writeln('');k:=1; end;
if l=125 then begin l:=0;readln; end;
write(i,' ');
end;i:=i+2;
end;
readln;
end.
program z31;
{ Вывести список шестизначных "счасливых" чисел (сумма первых трёх цифр равна сумме трёх последних), кратных семи в 10 колонок}
uses crt;
var i,j,k,m1,m2,j1,l:longint;
i1:string;er:integer;
begin
clrscr;
textcolor(11);i:=100000;
while i<=999999 do
begin
m1:=0;m2:=0;str(i,i1);
for j:=1 to 3 do
begin
val(i1[j],j1,er);m1:=m1+j1;
val(i1[j+3],j1,er);m2:=m2+j1;
end;
if (m1=m2)and(i mod 7=0)then
begin
inc(l);inc(k);
if k=11 then begin writeln('');k:=1; end;
if l=250 then begin l:=0;readln; end;
write(i,' ');
end;inc(i);
end;
readln;
end.
program z32;
{ Определить кол-во слов в строке. Слова отделяются одним или несколькими пробелами }
uses crt;
var i,l,k,j:longint;a:string;
begin
clrscr;textcolor(11);
write('введите текст: ');readln(a);l:=length(a);
for i:=1 to l do
if (a[i]=' ')and(a[i+1]=' ')
then inc(j)
else a[i-j]:=a[i];l:=l-j;
if a[1]=' 'then begin delete(a,1,1);l:=l-1; end;
if a[l]<>' ' then begin inc(l);a[l]:=' '; end;
for i:=1 to l do if a[i]=' 'then inc(k);
write(' кол-во слов: ',k);
readln;
end.
program z33;{ Определить номера позиций и кол-во повторений запрашиваемого символа в строке введённой с клавиатуры}
uses crt;
var i,l,kol:longint;a,aa:string;
begin
clrscr;textcolor(11);
write('введите текст: ');readln(a);
write('введите символ: ');readln(aa);
if length(aa)>1 then halt;l:=length(a);
for i:=1 to l do
if a[i]=aa then
begin
inc(kol);write(' ',i);
end;
writeln('');write(' кол-во символов: ',kol);
readln;
end.
program z34;
{ Найти и заменить определённый символ в строке введённой с клавиатуры. Программа должна запрашивать заменяемый и заменяющий символы, а также подтверждение каждой замены символа с сообщением его номера в строке.}
uses crt;
var i,l:longint;a,a1,a2,p:string;
begin
clrscr;textcolor(11);
write('введите текст: ');readln(a);
write('заменяемый символ: ');readln(a1);
write('заменяющий символ: ');readln(a2);
if (length(a1)>1)or(length(a2)>1) then halt;l:=length(a);
for i:=1 to l do
if a[i]=a1 then
begin
clrscr;a[i]:='_';writeln(a);
writeln('Вы подтверждаете замену ',i,'-ого символа? (y/n)');
readln(p);
if p='y' then a[i]:=a2[1]
else a[i]:=a1[1];
end;
clrscr;write(a);readln;
end.
program z35;{ Определить самое короткое и самое длинное слово в строке введённой с клавиатуры }
uses crt;
var i,l,min,max,p1,p2,j:longint;a,b:string;
t1:array[1..60]of string;
t2:array[1..60]of longint;
begin
clrscr;textcolor(11);
write('введите текст: ');readln(a);
l:=length(a)+1;a[l]:=' ';
for i:=1 to l do
if a[i]=' ' then begin
inc(j);t1[j]:=b;
t2[j]:=length(b);b:='';
end
else b:=b+a[i];
max:=t2[1];min:=t2[1];p1:=1;p2:=1;
for i:=1 to j do
begin
if max<t2[i] then begin max:=t2[i];p1:=i; end;
if min>t2[i] then begin min:=t2[i];p2:=i; end;
end;
writeln('самое длинное слово: ',t1[p1]);
writeln('самое короткое слово: ',t1[p2]);
textcolor(13);write('P.S.');
writeln(' Если слово не выведено на печать, то вы ');
write(' поставили несколько подряд идущих пробелов!');
readln;
end.
program z36;
{ Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы вначале шли элементы меньше среднего значения по всему массиву С }
uses crt;
var i,j,aa,bb,d,s:longint;
a:array[1..100]of longint;sr:real;
b:array[1..100]of longint;
c:array[1..200]of longint;
begin
clrscr;textcolor(11);
{write('диапазон: ');readln(d);}
for i:=1 to 100 do
begin
a[i]:=1;{random(d);}
b[i]:=3;{random(d);}
end;
for i:=1 to 100 do sr:=sr+a[i]+b[i];sr:=sr/200;
while j<100 do
begin
inc(j);
if a[j]<sr then begin inc(s);c[s]:=a[j]; end;
if b[j]<sr then begin inc(s);c[s]:=b[j]; end;
end;j:=0;
while j<100 do
begin
inc(j);
if a[j]>=sr then begin inc(s);c[s]:=a[j]; end;
if b[j]>=sr then begin inc(s);c[s]:=b[j]; end;
end;
for i:=1 to 200 do write(c[i],' ');
readln;
end.
program z37;
{Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы элементы массива А
имели в С нечётные номера }
uses crt;
var i,j,k,aa,bb,d:longint;
a:array[1..100]of longint;
b:array[1..100]of longint;
c:array[1..200]of longint;
begin
clrscr;textcolor(11);
{write('диапазон: ');readln(d);}
for i:=1 to 100 do
begin
a[i]:=1;{random(d);}
b[i]:=2;{random(d);}
end;
for i:=1 to 200 do
if i mod 2=0 then begin inc(bb);c[i]:=b[bb]; end
else begin inc(aa);c[i]:=a[aa]; end;
for i:=1 to 200 do write(c[i],' ');
readln;
end.
program z38;
{Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы элементы массива А
имели номера от 51 до 150 }
uses crt;
var i,j,k,aa,bb,d:longint;
a:array[1..100]of longint;
b:array[1..100]of longint;
c:array[1..200]of longint;
begin
clrscr;textcolor(11);
{write('диапазон: ');readln(d);}
for i:=1 to 100 do
begin
a[i]:=0;{random(d);}
b[i]:=1;{random(d);}
end;
for i:=1 to 50 do c[i]:=b[i];bb:=49;
for i:=51 to 150 do begin inc(aa);c[i]:=a[aa]; end;
for i:=151 to 200 do begin inc(bb);c[i]:=b[bb];end;
for i:=1 to 200 do write(c[i],' ');
readln;
end.
program z39;
{ Слить массивы А и В по 100 элементов в массив С из 200 элементов так, чтобы элементы А и В чередовались по 10 штук}
uses crt;
var i,j,aa,bb,d,jj,s:longint;
a:array[1..100]of longint;sr:real;
b:array[1..100]of longint;
c:array[1..200]of longint;
begin
clrscr;textcolor(11);
{write('диапазон: ');readln(d);}
for i:=1 to 100 do
begin
a[i]:=1;{random(d);}
b[i]:=2;{random(d);}
end;
bb:=1;
for i:=1 to 200 do
begin
if aa=10 then begin aa:=0;inc(bb);
if bb mod 2=0 then s:=1 else s:=0;end;
if s=0 then begin inc(j);c[i]:=a[j]; end;
if s=1 then begin inc(jj);c[i]:=b[jj]; end;
inc(aa);
end;
for i:=1 to 200 do write(c[i],' ');
readln;
end.
program z40;
{ Составить программу, создающую из файла копию, но записаную задом наперёд. }
uses crt;
var fl1,fl2:text;a,b:string;
i,l:longint;
begin
clrscr;
assign(fl1,'input.txt');
assign(fl2,'output.txt');
reset(fl1);
readln(fl1,a);
close(fl1);
l:=length(a);
for i:=l downto 1 do b:=b+a[i];
rewrite(fl2);
write(fl2,b);
close(fl2);
write(b);
readln;
end.
program z41;
{Составить программу, удаляющую в файле текст после первой точки.}
uses crt;
var fl1:text;a:string;
i,l,poz:longint;label m;
begin
clrscr;
assign(fl1,'input.txt');
reset(fl1);
readln(fl1,a);
close(fl1);
l:=length(a);
rewrite(fl1);
for i:=1 to l do if a[i]='.'then begin poz:=i;goto m; end;
m:for i:=1 to poz do write(fl1,a[i]);
close(fl1);
end.
program z42;
{ Найти остаток от деления числа, записываемого с помощью k семёрок, на число а (k и a -заданые натуральные числа) }
uses crt;
var i,k,a,ss:longint;er:integer;s:string;
begin
clrscr;
write('k=');readln(k);
write('a=');readln(a);
for i:=1 to k do s:=s+'7';
val(s,ss,er);
ss:=ss mod a;
write('Ответ: ',ss);
readln;
end.
program z43;
{ На интервале (1000 ; 9999) найти все простые числа, каждое из которых обладает тем свойством, что сумма первой и второй цифр записи этого числа равна сумме третьей и четвёртой цифр }
uses crt;
var b:array[1..1000] of longint;er:integer;
i,j,fl,h,s1,s2,s3,s4:longint;
ii:string;label met1,met2;
begin
clrscr;
i:=1000;
met1:while i<=9999 do
begin
for j:=2 to i-1 do
if i mod j=0 then begin fl:=1;goto met2; end;
met2:if fl=0 then begin
str(i,ii);
val(ii[1],s1,er);val(ii[3],s3,er);
val(ii[2],s2,er);val(ii[4],s4,er);
if s1+s2=s3+s4 then
begin
inc(h);b[h]:=i;inc(i);goto met1;
end;
end;
fl:=0;inc(i);
end;
for i:=1 to h do write(b[i],' ');
readln;
end.
program z44;
{ Среди простых чисел, не превосходящих n, найти такое, в двоичной записи которого максимальное число единиц. }
uses crt;
var b:array[1..1000]of longint;
c:array[1..1000]of longint;
kol,i,j,h,fl,m,g,max,poz:longint;
label met1,met2;
procedure sistema(n:longint;var kol:longint);
var a:array[1..10]of longint;
var l,k:longint;gg:string;
begin
j:=0;k:=0;
while n>=1 do
begin
inc(k);inc(j);
a[j]:=n mod 2;
n:=n div 2;
end;
for j:=1 to k do g:=g*10+a[k+1-j];
str(g,gg);kol:=0;
for l:=1 to length(gg) do
if gg[l]='1' then inc(kol);
end;
begin
clrscr;
write('n=');readln(m);
sistema(2,kol);c[1]:=2;b[1]:=kol;i:=3;h:=1;
met1:while i<=m do
begin
for j:=2 to i-1 do
if i mod j=0 then begin fl:=1;goto met2; end;
met2:if fl=0 then begin
inc(h);c[h]:=i;
sistema(i,kol);
inc(i);b[h]:=kol;goto met1;
end; fl:=0;inc(i);
end;
max:=b[1];
for i:=2 to h do
if max<b[h] then begin max:=b[h];poz:=h; end;
write('Ответ:',c[poz]);
readln;
end.
program z45;
{ Найти двоичное представление для чётных совершенных чисел вида 2 в степени (p-1) умножить на ((2 в степени p)-1) }
uses crt;
var ch,p,s,sum,i,j,f,m,g:longint;
procedure sistema(n:longint;var g:longint);
var t:array[1..10]of longint;k:longint;
begin
j:=0;k:=0;
while n>=1 do
begin
inc(k);inc(j);t[j]:=n mod 2;n:=n div 2;
end;
for j:=1 to k do g:=g*10+t[k+1-j];
end;
begin
clrscr;
write('ограничение: m=');readln(m);
p:=1;s:=2;
while p<=m do
begin
ch:=(s div 2)*(s-1);
if ch mod 2=0 then
begin sum:=0;
for j:=1 to ch-1 do if ch mod j=0 then sum:=sum+j;
if ch=sum then
begin sistema(ch,g);writeln(g); end;
end;
inc(p);s:=s*2;
end;
readln;
end.
program z46;
{ Задана последовательность состоящая из единиц и нулей. Определить кол-во М-значных чисел, входящих в указанную последовательность, которые делятся на 21. }
uses crt;
var i,j,m,s,l,kol,y:longint;g,a:string;er:integer;
procedure step(a,n:longint;var p:longint);
var t:integer;
begin
p:=1;
for t:=1 to n do p:=p*a;
end;
procedure sistema(g:string;m:longint;var s:longint);
var b:array[1..1000]of longint;
var k,t,p:longint;label met;
begin
for t:=1 to m do
val(g[t],b[m+1-t],er);
s:=0;
for t:=1 to m do
begin
if t=1 then begin
p:=1;goto met;
end;
step(2,t-1,p);{2}
met:s:=s+b[t]*p;
end;
end;
begin
clrscr;
write('кол-во знаков: ');readln(m);
write('последовательность:');readln(a);
l:=length(a);if m>l then halt;
for i:=1 to l+1-m do
begin
g:='';for j:=i to m+y do g:=g+a[j];inc(y);
sistema(g,m,s);if (s mod 21=0)and(s<>0)then begin writeln(s);inc(kol); end;
end;
write('Ответ:',kol);
readln;
end.
program z47;
{ Можно ли заданное натуральное число M представить в виде суммы двух квадратов натуральных чисел. }
uses crt;
var i,j,m:longint;
begin
clrscr;
write('Введите число:');readln(m);
for i:=1 to round(sqrt(m))+1 do
for j:=1 to round(sqrt(m))+1 do
if i*i+j*j=m then begin
write('Можно! Числа: ',i,' и ',j);
readln;halt;
end;
write('нельзя');
readln;
end.
program z48;
{ Найти минимальное число, которое представляется суммой четырёх квадратов натуральных чисел не единственным образом }
uses crt;
var ch,a,b,c,d,k,cc:longint;
begin
clrscr;
for ch:=1 to 100 do
for a:=1 to 100 do
for b:=1 to 10 do
for c:=1 to 10 do
for d:=1 to 10 do
begin
if cc<>ch then k:=0;
if a*a+b*b+c*c+d*d=ch then begin cc:=ch;inc(k); end;
if k>1 then begin
write(ch,' - ',a,',',b,',',c,',',d);
readln;halt;
end;
end;
end.
program z49;
{ Даны числа M,N и двумерный массив M*N. Некоторый элемент массива назовем седловой точкой, если он яв-ся одновременно наименьшим в своей строке и наибольшим в своём столбце. Напечатать координаты какой нибудь седловой точки. }
uses crt;
var i,j,fl,n,m,st,min,jj:longint;
t:array[1..100,1..100]of integer;
begin
clrscr;
write('n=');readln(n);
write('m=');readln(m);
for j:=1 to m do
for i:=1 to n do
begin
write('t[',i,',',j,']=');readln(t[i,j]);
end;
for j:=1 to m do
begin
min:=t[1,j];st:=1;fl:=0;
for i:=1 to n do if t[i,j]<min then begin
min:=t[i,j];st:=i;
end;
for jj:=1 to m do if (min<t[st,jj])and(j<>jj)then fl:=1;
if fl=0 then begin
write('-t[',st,',',j,']- число: ',t[st,j]);
readln;halt;
end;
end;
write('нету');readln;
end.
program z50;
{ Дан массив А(N) и число М. Найти такое множество элементов A(i1),A(i2),...A(ik) (1<=i1<...<ik<=N), что A(i1)+A(i2)+...+A(ik)=M Предполагается, что такое множество заведамо существует. }
uses crt;
var i,j,s,m,n:longint;
a:array[1..30]of integer;
begin
clrscr;
write('m=');readln(m);
write('n=');readln(n);
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
for i:=1 to n do
begin
s:=s+a[i];
if s=m then for j:=1 to i do write(' ',a[j]);
end;
readln;
end.
program z51;
{ Получить все способы расстановки шести книг разных авторов. }
uses crt;
var k,i1,i2,i3,i4,i5,i6,i7,i8,m,fl:longint;
mm:string;
begin
clrscr;
for i1:=1 to 6 do
for i2:=1 to 6 do
for i3:=1 to 6 do
for i4:=1 to 6 do
for i5:=1 to 6 do
for i6:=1 to 6 do
begin
m:=i6+i5*10+i4*100+i3*1000+i2*10000+i1*100000;
str(m,mm);fl:=0;
for i7:=1 to 5 do
for i8:=i7+1 to 6 do
if mm[i7]=mm[i8]then fl:=1;
if fl=0 then begin write(m,' ');inc(k); end;
end;
write(' кол-во:',k);
readln;
end.
program z52;
{ Для участия в конкурсе из класса в 20 человек требуется выбрать троих. Сколькими способами это можно сделать.}
uses crt;
var k,i1,i2,i3,i4,i5,fl:longint;
mm:array[1..3]of longint;
begin
clrscr;
for i1:=1 to 20 do
for i2:=1 to 20 do
for i3:=1 to 20 do
begin
mm[1]:=i3;
mm[2]:=i2;
mm[3]:=i1;
fl:=0;
for i4:=1 to 2 do
for i5:=i4+1 to 3 do
if mm[i4]=mm[i5]then fl:=1;
if fl=0 then begin writeln(i3,',',i2,',',i1);inc(k); end;
end;
write(' кол-во:',k);
readln;
end.
program z53;
{ Получить все четырёхзначные числа, у которых все цифры нечётные. }
uses crt;
var k,i1,i2,i3,i4,i5,fl:longint;
mm:array[1..4]of longint;
begin
clrscr;
for i1:=1 to 9 do
for i2:=0 to 9 do
for i3:=0 to 9 do
for i4:=0 to 9 do
begin
mm[1]:=i4;
mm[2]:=i3;
mm[3]:=i2;
mm[4]:=i1;
fl:=0;
for i5:=1 to 4 do
if mm[i5] mod 2=0 then fl:=1;
if fl=0 then begin write(i4,i3,i2,i1,' ');inc(k); end;
end;
write(' кол-во:',k);
readln;
end.
program z54;
{Даны 4 точки заданные координатами .Является ли данная фигура трапецией.}
uses crt;
var x1,x2,x3,x4,y1,y2,y3,y4:real;
a,b,c,d,a1,b1,c1,d1,m,n,k,f:real;
begin
clrscr;
write('x1=');readln(x1);
write('y1=');readln(y1);
write('x2=');readln(x2);
write('y2=');readln(y2);
write('x3=');readln(x3);
write('y3=');readln(y3);
write('x4=');readln(x4);
write('y4=');readln(y4);
a:=x2-x1;b:=y2-y1;a1:=x4-x3;b1:=y4-y3;
c:=x4-x1;d:=y4-y1;c1:=x3-x2;d1:=y3-y2;
m:=abs(a)/abs(a1);n:=abs(b)/abs(b1);k:=abs(c)/abs(c1);
f:=abs(d)/abs(d1);
if (m=n) or (k=f)
then write('трапеция')
else write('Hе трапеция');
readln;
end.
program z55;
{Опред.наимен.число,кот.при делении на 2,3,4,5,6,7,8,9 дает одинаковые остатки-1}
uses crt;
var i,j,n,a,k:longint;{ввод 3000 и больше отв 2521}
begin
clrscr;
write('введите n=');readln(n);
for i:=10 to n do
begin
k:=0;
for j:=2 to 9 do
begin
a:=i mod j;
if a=1
then k:=k+1;
if k=8 then
begin
writeln('число=',i);
readln;halt;
end;
end;
end;
readln;
end.
program z56;
{Определить k-кол-во трёхзначных чисел сумма цифр которых равна a(1<=a<=27)}
uses crt;
var i,j,k,a,b:longint;
begin
clrscr;
for i:=1 to 9 do
for j:=0 to 9 do
for k:=0 to 9 do
begin
b:=100*i+10*j+k; {Запись трёхзначного числа}
a:=i+j+k;
if (a>=1)and(a<=27)then
begin
writeln('число: ',b);
k:=k+1;
end;
end;
write('k= ',k);
readln;
end.
program z57;
{Даны стороны треуг.:a,b,c. Выч. cos углов по теореме косинусов:sqr(c)=sqr(a)+sqr(b)-2ab*cos(alfa)}
uses crt;
var a,b,c,cosa,cosb,cosc:real;
procedure cos(a1,b1,c1:real;var cosa1:real);
begin
cosa1:=(c1*c1+b1*b1-a1*a1)/(2*c1*b1);
end;
begin
clrscr;
write('a=');readln(a);
write('b=');readln(b);
write('c=');readln(c);
cos(a,b,c,cosa);
cos(b,c,a,cosb);
cos(c,a,b,cosc);
writeln('cosa=',cosa);
writeln('cosb=',cosb);
write('cosc=',cosc);
readln;
end.
program z58;
{Пара кроликов каждый год дает приплод двух (самку и самца)кот.через 2месяца способны давать новый приплод.Ск-ко кроликов будет через год.}
uses crt;
var k : integer;
function f(n:integer):integer;
begin
if n=0
then f:=1
else if n=1
then f:=2
else f:=f(n-2)+f(n-1);
end;
begin
for k:=10 to 12 do
writeln(f(k));
readln;
end.
program z59;
{Дано предл. t заменить в нем слово 'потоп' словом 'потопкот'}
uses crt;
var t,a:string;i:integer;
begin
clrscr;
write('введите текст t=');readln(t);
for i:=1 to length(t) do
begin
a:=copy(t,i,i+4);{кооп. буквы с i по i+4}
if a='потоп'
then insert('кот',t,i+5);{вставка'кот'в тек.t с i+5 поз.}
end;
write('ОТВЕТ: ',t);
readln;
end.
program z60;
{Дан текст опред.в нем кол. слов 'кот'}
uses crt;
var t,a:string;i,m,k:integer;
begin
clrscr;
write('введите текст t=');readln(t);
k:=0;m:=length(t);
for i:=1 to m+3 do
begin
a:=copy(t,i,i+2);{кооп. буквы с i по i+2}
if (a='кот')
then k:=k+1;
end;
write('слов кот ',k);
readln;
end.

Приложенные файлы

  • docx 6985020
    Размер файла: 244 kB Загрузок: 0

Добавить комментарий