Лекции по Паскалю

else if (b=a)and(a=c)or(b=c)and(c=a)then

begin max:=b;tupoi:=b*b

else begin max:=c;tupoi:=c*c

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

else if not tupoi(ab,bc,ca,max)then proverka:=max

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

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

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 j1 do if j mod b[i]=0 then

begin

n:=n+b[i];j:=j div b[i];

end

else inc(i);

if o2*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 minabs(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 mint2[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 il 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 (l12)or(l

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

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 l30 then halt;

while i

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

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(pozi) 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

определяет кол-во различных делителей числа 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 mint[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

желтого(ж) и красного(к) цветов. Найти максимальное кол-во

бусинок одного цвета, идущих подряд. }

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

max:=t2[i];poz:=i;

end;

write(max,' - ');

g:=t1[poz];

color;

for i:=1 to j do

if (t2[i]=max) and (pozi) 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 n360 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 (pozi) 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

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 20)then max:=dd[i];

i:=1;j:=0;

while st

begin

inc(j);sum:=0;i:=1;

while i

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]

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

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 20)then max:=dd[i];

i:=1;j:=0;

while st

begin

inc(j);i:=1;

while i

begin

rasst:=sqrt(sqr(st-DD[i])+sqr(dd[i+1]));

if i=1 then max1:=rasst else

if max1

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]

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

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

begin

j1:=i+1;

if fl=1 then writeln;fl:=0;

while j1

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

находим ,что у

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]

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

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