Задачи Pascal

1. Даны натуральные числа m и n. Найти наименьшее общее кратное этих чисел.

var

m, n, s: word;

begin

readln(m, n);

s := m * n;

while m <> n do

begin

if m > n then

begin

m := m - n

end

else

begin

n := n - m

end

end;

writeln(s div m)

end.

2. Напечатать все простые числа до 1000.

var

x:integer;

j:integer;

b:boolean;

begin

x:=2;

While x<=1000 do

begin

b:=true;

for j:=2 to x-1 do

begin

if (x mod j)=0 then

begin b:=false; break;

end;

end;

if b then

begin

Writeln(x);

end;

inc(x);

end;

end.

3. Дана последовательность целых чисел a1; a2; ...; an. Выяснить, каких чисел встречается больше положительных или отрицательных.

Var

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

n,i:integer;

begin

writeln('VVEDITE KOL-VO ELEMENTOV');

read(n);

for i:=1 to n do

read(a[i]);

if a[1]>0 then writeln('Положительное')else writeln('Отрицательное');

end.

4. В целочисленной последовательности есть нулевые элементы. Создать массив из номеров этих элементов.

Var

a :array [1..100] of real;

i,n,j : integer;

x : array [1..100] of real;

Begin

write('n=');readln(n);

for i:=1 to n do

readln(a[i]);

j:=1;

for i:=1 to n do

if a[i]=0 then

begin

x[j]:=i;

j:=j+1

end;

for i:=1 to j-1 do

write(x[i],' ');

End.

5. Задана квадратная матрица. Получить транспонированную матрицу, т.е. матрицу, где столбцы и строки меняются местами.

Const

row=4;

col=4;

var

a,b:array[1..row,1..col] of integer;

i,j:integer;

begin

randomize;

writeln('Ishodnaya matriza sluchainih chisel: ');

for i:=1 to row do

begin

for j:=1 to col do

begin

a[i,j]:=random(100);

b[i,j]:=a[i,j];

write(a[i,j]:8);

end;

writeln;

end;

writeln;

writeln;

for i:=1 to row do

for j:=1 to col do

begin

if (i<>j) and (i<j) then a[i,j]:=a[j,i];

if (i<>j) and (i>j) then a[i,j]:=b[j,i];

end;

for i:=1 to row do

begin

for j:=1 to col do write(a[i,j]:8);

writeln;

end;

readln;

end.

6. Натуральные числа a, b, c называются числами Пифагора, если выполняется условие a2+b2=c2. Напечатать все числа Пифагора, меньшие N.

var

a,b,n:integer;

begin

readln(n);

for a:=1 to n-1 do

for b:=1 to n-1 do

if (sqrt (a*a+b*b)=int( sqrt (a*a+b*b))) and( sqrt (a*a+b*b)<n) then

writeln (a,' ',b,' ',trunc(sqrt(a*a+b*b)));

end.

7. Дано целое n > 2. Напечатать все простые числа из диапазона [2,n].

Var

n,i,k,d:integer;

Begin

Readln(n);

for i:=2 to n do

begin

for k:=2 to (i)+1 do if i mod k = 0 then inc(d);

if d=1 then Write(i,' ');

d:=0;

end;

readln;

End.

8. Дана последовательность действительных чисел a1; a2; ...; an. Подсчитать сколько ее членов, большие заданного числа M.

9. Даны целые числа a1; a2; ...; an. Вывести на печать только те числа, для которых выполняется ai < i.

10. Даны натуральные числа a1; a2; ...; an. Указать те, у которых остаток от деления на M равен L (0 <= L <= M - 1).

Var

i,n,m,l,f:integer;

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

begin

writeln('Введите кол-во элементов вектора');

readln(n);

writeln('Ввод элементов вектора');

for i:=1 to n do

begin

write('a[',i,']=');

readln(a[i]);

end;

writeln('Вывод элементов вектора');

for i:=1 to n do

write(a[i],' ');

writeln;

writeln('Введите делитель');

readln(m);

writeln('Введите остаток');

readln(l);

writeln('Числа, которые от деления на ',m,' дают остаток ',l);

if (l>=0) and (l<=m-1) then

begin

for i:=1 to n do

if (a[i] mod m)=l then

begin

writeln(a[i]);

f:=1;

end;

end;

if f=0 then

writeln('Таких чисел в массиве нет!');

end.

11. Дана строка, содержащая английский текст. Найти количество слов, начинающихся с буквы ‘b’.

const pr: set of char=[' ','(',',','.',';',':','-'];

var s: string;

i,k: byte;

begin

write('s=');

readln(s);

if (s[1]='B') or (s[1]='b') then inc(k);

for i:=2 to length(s) do

if ((s[i]='B') or (s[i]='b')) and (s[i-1] in pr) then inc(k);

writeln('Слов на B(b): ',k);

readln;

end.

12. В строке имеется одна точка с запятой ’;’. Подсчитать количество символов до точки с запятой и после нее.

var

s1,s2:string;

i,k:integer;

begin

writeln('vvedite stroku ');

readln(s1);

s2:=';';

i:=Pos(s2,s1);

if i<>0 then

begin

k:=length(s1)-i;

i:=i-1;

writeln('kol simvolov do = ',i,'kol simvolov posle = ',k);

end

else writeln('podstroka ne naidena');

end.

13. Проверить, одинаковое ли число открывающихся и закрывающихся скобок в данной строке.

Var

str:string;

i,k1,k2:byte;

begin

writeln('vvedite stroku');

readln(str);

for i:=1 to length(str) do

begin

if str[i]='(' then inc(k1);

if str[i]=')' then inc(k2);

end;

if k1=k2 then writeln('da') else writeln('net');

readln;

end.

14. Дана строка. Подсчитать количество букв b в последнем ее слове.

Var

s,s1:string;

i,b:byte;

begin

write('Введите строку: ');readln(s);

b:=0;s1:='';

for i:=Length(s) downto 1 do

if not(s[i] in [' ',',','-']) then s1:=s1+s[i]

else break;

for i:=1 to Length(s1) do

if s1[i]='b' then inc(b);

if b>0 then write('В последнем слове букв "b"= ',b)

else write('В последнем слове буква "b" не встречаются');

end.

15. Дана строка. Удалить из нее все лишние пробелы, оставив между словами не более одного. Результат поместить в новую строку.

var

s:string;

begin

writeln('Введите строку...');

readln(s);

while pos(' ',s)>0 do

delete(s,pos(' ',s),1);

writeln('Результат:');

writeln(s)

end.

16. Написать программу нахождения наибольшего общего делителя(НОД) трех чисел, используя функцию нахождения НОД двух чисел.

17. Дан треугольник, вершины которого имеют координаты (x1, y1), (x2,y2), (x3,y3). Определить площадь треугольника, используя функцию, определяющую расстояние между двумя заданными точками.

Var

xa,ya,xb,yb,xc,yc: integer;

ab,bc,ca,s: real;

function Dlina(x1,y1,x2,y2: integer):real;

var d: real;

begin

d:= sqrt(sqr(y1-y2)+sqr(x1-x2));

Dlina:=d;

end;

function Square (a,b,c: real): real;

var sq: real;

begin

sq:=0.25*(sqrt((a+b+c)*(b+c-a)*(a+c-b)*(a+b-c)));

Square:=sq;

end;

begin

writeln ('Координаты вершины A ');

readln (xa,ya);

writeln ('Координаты вершины B ');

readln (xb,yb);

writeln ('Координаты вершины C ');

readln (xc,yc);

ab:=Dlina(xa,ya,xb,yb);

bc:=Dlina(xb,yb,xc,yc);

ca:=Dlina(xc,yc,xa,ya);

s:=Square(ab,bc,ca);

write ('Площадь треугольника = ',s:7:2);

end.

18. Написать программу использующую функцию определения симметричности матрицы

int sim(int **a);

Результат: 1 - если матрица симметрична, и 0 - в противном случае.

19. Дан текстовый файл. Заменить все символы ’0’ на символ '1' и наоборот;

Var

f1,f2:text;

ch:char;

begin

assign(f1,'C:\F.txt');

reset(f1);

assign(f2,'C:\G.txt');

rewrite(f2);

while not eof(f1) do

begin

read(f1,ch);

if ch='0' then ch:='1'

else if ch='1' then ch:='0';

write(f2,ch);

end;

close(f1);

close(f2);

end.

20. Пусть дан текстовый файл. Распечатайте, строки, начинающиеся с заданного слова.