Лекции по Паскалю задачи с решениями

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)

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

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 ((xb)and(yc))or((xc)and(yb)) then f:=1;

if ((xb)and(ya))or((xa)and(yb)) then f:=1;

if ((xa)and(yc))or((xc)and(ya)) 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 k0 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 (ij)and(ik)and(il)and(jk)and(jl)and(kl)and(m

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

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+bc)and(a+cb)and(c+ba)then

begin

p:=(a+b+c)/2;

s:=sqrt(p*(p-a)*(p-b)*(p-c));

s1:=round(s);

if (nk)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 nk 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 (k1)and(k64)and(l1)and(l64)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(k1)then

begin

writeln('a[',l+1,',',k,']');writeln('a[',l,',',k+1,']');

writeln('a[',l,',',k-1,']');

end;

if (l=64)and(k1)then

begin

writeln('a[',l-1,',',k,']');writeln('a[',l,',',k+1,']');

writeln('a[',l,',',k-1,']');

end;

if (l1)and(k

begin

writeln('a[',l,',',k+1,']');writeln('a[',l+1,',',k,']');

writeln('a[',l-1,',',k,']');

end;

if (l1)and(l

begin

writeln('a[',l-1,',',k,']');writeln('a[',l+1,',',k,']');

writeln('a[',l,',',k-1,']');

end;

if (k64)or(l64)then

begin

writeln('Неверные данные');writeln('1

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

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]

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

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

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

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

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 (x0)and(y0)

then begin

write(' 1-ая четверть');readln;halt;

end;

if (x0)

then begin

write(' 2-ая четверть');readln;halt;

end;

if (x

then begin

write(' 3-ая четверть');readln;halt;

end;

if (x0)and(y

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

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

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

while jtrunc(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

write('можно');readln;halt;

end;

l:=trunc(n/m);r:=m;k:=1;d:=0;{l-кол-во подпоследов.по m-эл.}

while 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]

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]

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

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

if (m3)and(m

if (m5)and(m

if m10 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(ac)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 (ij)and(ik)and(il)and(jk)and

(jl)and(kl)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

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

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 20 then l:=l-1;

while i

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=n¹/1!+n²/2!+...+n^k/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.

8