Задачи с решениями по Паскалю (70 шт)

Задачи с решениями по Паскалю (70 шт).

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-угольнику.

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]

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 (ab) and (ac) then max:=a;

if (ba) and (bc) then max:=b;

if (ca) and (b

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 aabb 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)

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]

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]

begin

min:=a[i];l:=i;

end;

if k

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

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

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

if x3

if l1l2 then l:=l1 else l:=l2;

if x1x2 then p1:=x1 else p1:=x2;

if x3x4 then p2:=x3 else p2:=x4;

if p1p2 then p:=p2 else p:=p1;

if lпересекаются')

else write('не пересекаются');

readln;

end.

program z23;

{ Определить яв-ся ли n-угольник выпуклым

Ввод состоит из n отрезков, n3 и n

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

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

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 de 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

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 ab do

if ab 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 d0 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корней нет');

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

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*xn) 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

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 a1b1

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]

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 z14;

{Дана лин. таб содерж. группы одинаковых подряд идущих положит. чисел.Вывести

на экран "число-кол-во чисел в группе,число-кол-во чисел в группе, ... "}

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

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-угольник(n3) задаётся коорд. своих вершин в порядке обхода.

Разбить его на треуг. диагоналями, не пересек.,так,чтобы сумма длин

диагоналей была минимальной}

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 nnmax then

begin

writeln('слишком большое n (n

q:=false;

end;

if n

begin

if n3).') 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 an 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 mins[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

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]

begin

min:=a[j];

k:=j;

end;

a[k]:=a[i];

a[i]:=min;

end;

k:=0;s:=1;i:=1;

while i

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

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 r1r2 then haltpr;

if (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

найти сумму элементов массива а так же максимальный элемент}

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]

{Вывод результатов}

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 ab do

begin

if ab

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 n1n2 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 iii then begin

write(i);

readln;halt;

end;

end;

write('НЕТ');

readln;

end.