Шпаргалка по информатике (сборник Паскаль). Сборник_Паскаль1. 1. Найти значение выражения 1122 nn

• Название: 1. Найти значение выражения 1122 nn
• Анкор: Шпаргалка по информатике (сборник Паскаль
• Дата: 08.02.2023
• Размер: 192 Kb.
• Имя файла: Сборник_Паскаль1.doc
• Тип: Документы; #926117
• страница: 3 из 3

program z54;

{Даны 4 точки x1,y1,x2,y2,x3,y3,x4,y4 Составить программу для опред.

площади четырёхугольника,используя процедуру нахождения площади}

uses crt;

var x1,x2,x3,x4,y1,y2,y3,y4 : real;

c1,c2,c : real;

procedure treyg(a1,b1,a2,b2,a3,b3:real;var s:real);

var a,b,c,p:real;

{исходные данные а1,в1,а2,в2,а3,в3-формальные.Перед

вып.процедуры им присваивается фактические параметры

Процедура вырабатывает значения а,в,с,р,s.Перед их

именами в описании стоит служебное слово var}

begin

a:=sqrt(sqr(a1-a2)+sqr(b1-b2));

b:=sqrt(sqr(a2-a3)+sqr(b2-b3));

c:=sqrt(sqr(a3-a1)+sqr(b3-b1));

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

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

end;

begin

clrscr;

write('x1=');readln(x1);

write('y1=');readln(y1);

write('x2=');readln(x2);

write('y2=');readln(y2);

write('x3=');readln(x3);

write('y3=');readln(y3);

write('x4=');readln(x4);

write('y4=');readln(y4);

treyg(x1,y1,x2,y2,x3,y3,c1);

treyg(x3,y3,x4,y4,x1,y1,c2);

c:=c1+c2;

writeln('ОТВЕТ:',c);

readln;

end.
program z55;

{Выпуклый n-угольник(n>3) задаётся коорд. своих вершин в порядке обхода.

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

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

uses crt;

const nmax=10;

var x,y:array [1..nmax] of longint;

s : array [1..nmax] of real;

n,i,a,j : integer;

min : real;

q : boolean;

function rast(n1,n2:integer):real;

begin

rast:=sqrt(sqr(x[n1]-x[n2])+sqr(y[n1]-y[n2]));

end;

begin

clrscr;

repeat;

q:=true;

write('кол-во углов n=');readln(n);

if n>nmax then

begin

writeln('слишком большое n (n<=',nmax,').');

q:=false;

end;

if n<4 then

begin

if n<3 then writeln('Такой фигуры не существует (n>3).') else

writeln('В треугольнике нет диагоналей!!');

q:=false;

end;

until q;

for i:=1 to n do

begin

write('x[',i,']=');readln(x[i]);

write('y[',i,']=');readln(y[i]);

writeln;

end;

for i:=1 to nmax do s[i]:=0;

for i:=1 to n do

begin

for j:=1 to n-3 do

begin

a:=i+j+1;

if a>n then a:=a-n;

s[i]:=s[i]+rast(i,a);

end;

end;

min:=s[1];

a:=1;

for i:=1 to n do

begin

if min>s[i] then

begin

a:=i;

min:=s[i];

end;

end;

writeln('Ответ: из точки № ',a);

readln;

end.
program z56;

{Ввести текст телеграммы и стоимость одного слова.Опред. стоимость телеграммы

При вводе текста запятые обознач. словом ЗПТ,точки-словом Т,других знаков

припинания не исп.}

uses crt;

var a : string;

i,s,c : longint;

begin

clrscr;

write('Введите текст ');readln(a);

write('Стоимость одного слова ');readln(c);

s:=0;

repeat;

for i:=1 to length(a)do

if (a[i]=' ') or (a[i]+a[i+1]+a[i+2]='ЗПТ')

then s:=s+c;

until a[i]='Т';

s:=s+c;

write('стоимость телеграммы: ',s);

readln;

end.
program z57;

{Дана лин. таб. a[1..n].Ввести табл. b[1..n] отбросив из а каждый второй элм}

uses crt;

var a,b : array [1..10] of longint;

k,i,j,n : integer;

begin

clrscr;

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

for i:=1 to n do

begin

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

end;
k:=0; i:=1;

while i
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<=n-1 do

if a[i]=a[i+1]

then

begin

s:=s+1;

i:=i+1;

end

else

begin

k:=k+1;

b[k]:=s;

i:=i+1;

s:=1;
end;

max:=b[1];

for i:=2 to k do

if b[i]>max then max:=b[i];

write('наибольшее кол-во одинаковых элм.: ',max);

readln;

end.
program z60;

{ Дана точка. Лежит ли она в кольце. }

uses crt;

var x,y,r1,r2,a,b : real;

procedure haltpr;

begin

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

write('r1
readln;halt;

end;

begin

clrscr;

write('координаты центра окр. a=');readln(a);

write('координаты центра окр. b=');readln(b);

write('x='); readln( x);

write('y='); readln( y);

write('r1=');readln(r1);

write('r2=');readln(r2);

if r1>r2 then haltpr;

if (sqr(x-a)+sqr(y-b)sqr(r1))

then write('лежит')

else write('не лежит');

readln;

end.
program z61;

uses crt;

{Примеры типов величин}

var a : integer; { целый тип от -32768 до 32767 }

b,c : real; { вещественный }

d : longint; { длинное целое число от -2147483648 до 2147483647 }

e : byte; { целый тип длинной в один байт то есть от 0 до 255 }

s : string; { литерный тип длиной 255 символов }

f : char; { литерный тип длиной в один символ }

begin

a:=123;

b:=213.34534;

d:=12387273;

e:=123;

s:='qgjhfghfgdfghdfjg';

f:=s[1];{ в результате с f='q' }

writeln(a,' ',b);

writeln(d);

writeln(e);

writeln(s);

writeln(f);

readln;

end.
program z62;

uses crt;

{Табличные величины. Однмерный массив.}

var a : array [1..100] of integer;{ массив 100 элементов типа integer }

n,i,max,sum : integer;

{ Задача: Дан целочисленный массив А имеющий n элементов (n<=100)

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

begin

clrscr;

write('n=');

readln(n);

{ввод элементов массива}

for i:=1 to n do

begin

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

readln(a[i]);

end;

{подсчёт суммы}

sum:=0;

for i:=1 to n do

sum:=sum+a[i];

{поиск максимального элемента}

max:=a[1];

for i:=2 to n do

if a[i]>max then max:=a[i];

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

writeln('сумма=',sum);

writeln('максимальный элемент=',max);

readln;

end.
program z63;

uses crt;

{Табличные величины. Двумерный массив.}

var a : array [1..100,1..100] of integer;{ квадратный массив 100х100 с

элементами типа integer}

b : array [1..100] of integer;{см. задачу №62}

i,j,n,m,min,max : integer;

{Задача: Дана целочисленная прямоугольная таблица размером MxN.

Найти среди максимальных элементов строк минимальный}

begin

clrscr;

write('Количество строк=');

readln(m);

write('Количество столбцов в строке=');

readln(n);

{Ввод таблицы}

for i:=1 to m do

begin

writeln(i,'-ая строка:');

for j:=1 to n do

begin

write(' ',j,'-ый столбец = ');

readln(a[i,j]);

end;

end;

{поиск максимумов в строках}

for i:=1 to m do

begin

max:=a[i,1];

for j:=2 to n do if a[i,j]>max then max:=a[i,j];

b[i]:=max;

end;

{поиск минимального в полученной таблице}

min:=b[1];

for i:=2 to m do if b[i]
{Вывод результатов}

writeln('Ответ=',min);

readln;

end.
program z64;

{ На оси Оx заданы N точек с координатами x1,x2,...,xn.

Найти такую точку Z сумма расстояний от которой до

данных точек минимальная. }

uses crt;

var d,i,j,m : longint;

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

begin

clrscr;

write('Введите кол-во точек:');readln(D);

for i:=1 to D do

begin

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

end;

for i:=1 to D-1 do

for j:=i+1 to D do

if a[i]>a[j] then begin

m:=a[i];

a[i]:=a[j];

a[j]:=m;

end;

if d mod 2=0

then write('Z между ',a[d div 2],' и ',a[d div 2+1])

else write('Z=',a[d div 2+1]);

readln;

end.
program z65;

{Имеется n банок с целочисленными объёмами v1,v2,v3...,vn литров,пустой сосуд

и кран с водой.Можно ли с помощью этих банок налить в сосуд ровно v литров

воды.

Решение:Обозначим s=nod(v1,v2...,vn)

Если v делится нацело на s,то в сосуд с помощью банок можно налить v

литров воды,иначе- нет}

uses crt;

var i,n,v,nod2:integer;

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

procedure nod(a,b:integer;var nd:integer);

begin

while a<>b do

begin

if a>b

then a:=a-b

else b:=b-a;

end;

nd:=a;

end;

begin

clrscr;

write('введите кол-во банок n=');readln(n);

writeln('введите объёмы банок');

for i:=1 to n do

begin

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

end;
write('введите объём сосуда v=');readln(v);

for i:=1 to n-1 do

nod(a[i],a[i+1],a[i+1]);

if v mod a[i+1]=0

then write('ДА')

else write('НЕТ');

readln;

end.
program z66;

{ Дана последовательность натуральных чисел

Найти наименьшее нат.число,которое отсутствует

в последовательности }

uses crt;

var n,n1,n2,ii,i,j:longint;

m,a:string;er:integer;

begin

clrscr;

write('Введите последовательность:');readln(a);

n:=length(a);

for i:=1 to n-1 do

for j:=i+1 to n do

begin

val(a[i],n1,er);

val(a[j],n2,er);

if n1>n2 then begin

m:=a[i];

a[i]:=a[j];

a[j]:=m[1];

end;

end;

for i:=1 to n do

begin

val(a[i],ii,er);

if ii<>i then begin

write(i);

readln;halt;

end;

end;

write('НЕТ');

readln;

end.
program z67;

{ Дан выпуклый n-угольник и точка(х1,у1)

Определить а)является ли точка вершиной

б)принадлежит ли точка n-угольнику }

uses crt;

var x,y:array[1..30]of integer;

a,b,c,plo1,plo2,s:real;

i,j,k,n,x1,y1,fl,ii:integer;

procedure ger(a1,b1,c1:real;var s1:real);

var p:real;

begin

p:=(a1+b1+c1)/2;

s1:=sqrt(p*(p-a1)*(p-b1)*(p-c1));

end;

procedure rasst(a1,b1,a2,b2:integer;var c1:real);
begin

c1:=sqrt(sqr(a2-a1)+sqr(b2-b1));

end;

begin

clrscr;

write('Виедите координаты точки через пробел:');

readln(x1,y1);

write('Количество углов n=');readln(n);

for i:=1 to n do

begin

write('x',i,'=');readln(x[i]);

write('y',i,'=');readln(y[i]);

end;

for i:=1 to n-2 do

begin

j:=i+1;

k:=j+1;

rasst(x[1],y[1],x[j],y[j],a);

rasst(x[1],y[1],x[k],y[k],b);

rasst(x[j],y[j],x[k],y[k],c);

ger(a,b,c,s);

plo1:=plo1+s;

end;

for i:=1 to n do

begin

if i=n then ii:=1

else ii:=i+1;

rasst(x1,y1,x[i],y[i],a);

rasst(x1,y1,x[ii],y[ii],b);

rasst(x[i],y[i],x[ii],y[ii],c);

ger(a,b,c,s);

plo2:=plo2+s;

end;

for i:=1 to n do if(x[i]=x1)and(y[i]=y1)then fl:=1;

if fl=1 then writeln('a)Да точка является вершиной')

else writeln('a)Нет точка не является вершиной');

if round(plo1)=round(plo2)then writeln('б)Да точка принадежит n-угольнику')

else writeln('б)Нет точка не принадежит n-угольнику');

writeln('S1=',plo1,'S2=',plo2);

readln;

end.
{Решение систем линейных уравнений методом Гаусса

Автор: Алексей Безродный }

Uses CRT;

Const maxn = 10;
Type Data = Real;

Matrix = Array[1..maxn, 1..maxn] of Data;

Vector = Array[1..maxn] of Data;

{ Процедура ввода расширенной матрицы системы }

Procedure ReadSystem(n: Integer; var a: Matrix; var b: Vector);

Var i,j,r: Integer;

Begin

r:= WhereY;

GotoXY(2, r);

Write('A');

For i := 1 to n do begin

GotoXY(i*6+2, r);Write(i);

GotoXY(1, r+i+1);Write(i:2);

end;

GotoXY((n+1)*6+2, r);

Write('b');

For i := 1 to n do begin

For j := 1 to n do begin

GotoXY(j * 6 + 2, r + i + 1);

Read(a[i, j]);

end;

GotoXY((n + 1) * 6 + 2, r + i + 1);

Read(b[i]);

end;

End;
{ Процедура вывода результатов }

Procedure WriteX(n :Integer; x: Vector);

Var

i: Integer;

Begin

For i := 1 to n do

Writeln('x', i, ' = ', x[i]);

End;

{ Функция, реализующая метод Гаусса }

Function Gauss(n: Integer; a: Matrix; b: Vector; var x:Vector): Boolean;

Var

i, j, k, l: Integer;

q, m, t: Data;

Begin
For k := 1 to n - 1 do begin
{ Ищем строку l с максимальным элементом в k-ом столбце}

l := 0;

m := 0;

For i := k to n do

If Abs(a[i, k]) > m then begin

m := Abs(a[i, k]);

l := i;

end;
{ Если у всех строк от k до n элемент в k-м столбце нулевой,

то система не имеет однозначного решения }

If l = 0 then begin

Gauss := false;

Exit;

end;
{ Меняем местом l-ую строку с k-ой }

If l <> k then begin

For j := 1 to n do begin

t := a[k, j];

a[k, j] := a[l, j];

a[l, j] := t;

end;

t := b[k];

b[k] := b[l];

b[l] := t;

end;
{ Преобразуем матрицу }

For i := k + 1 to n do begin

q := a[i, k] / a[k, k];

For j := 1 to n do

If j = k then

a[i, j] := 0

else

a[i, j] := a[i, j] - q * a[k, j];

b[i] := b[i] - q * b[k];

end;
end;
{ Вычисляем решение }

x[n] := b[n] / a[n, n];

For i := n - 1 downto 1 do begin

t := 0;

For j := 1 to n-i do

t := t + a[i, i + j] * x[i + j];

x[i] := (1 / a[i, i]) * (b[i] - t);

end;
Gauss := true;

End;
Var

n, i: Integer;

a: Matrix ;

b, x: Vector;

Begin

ClrScr;

Writeln('Программа решения систем линейных уравнений по методу Гаусса');

Writeln;
Writeln('Введите порядок матрицы системы (макс. 10)');

Repeat

Write('>');

Read(n);

Until (n > 0) and (n <= maxn);

Writeln;
Writeln('Введите расширенную матрицу системы');

ReadSystem(n, a, b);

Writeln;
If Gauss(n, a, b, x) then begin

Writeln('Результат вычислений по методу Гаусса');

WriteX(n, x);

end

else

Writeln('Данную систему невозможно решить по методу Гаусса');

Writeln;

End.

program z69;

{Решение систем линейных уравнений подбором}

uses crt;

var a:array[1..10,1..10]of longint;

b1,b2,b3,b4,i,j:longint;

x1,x2,x3,x4:integer;

begin

clrscr;

writeln('Решить систему уравнений');

writeln('a11x1+a12x2+a13x3+a14x4=b1');

writeln('a21x1+a22x2+a23x3+a24x4=b1');

writeln('a31x1+a32x2+a33x3+a34x4=b1');

writeln('a41x1+a42x2+a43x3+a44x4=b1');

for i:=1 to 4 do

for j:=1 to 4 do

begin

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

end;

write('b1=');readln(b1);

write('b2=');readln(b2);

write('b3=');readln(b3);

write('b4=');readln(b4);

for x1:=0 to 10 do

for x2:=0 to 10 do

for x3:=0 to 10 do

for x4:=0 to 10 do

if (a[1,1]*x1+a[1,2]*x2+a[1,3]*x3+a[1,4]*x4=b1)and

(a[2,1]*x1+a[2,2]*x2+a[2,3]*x3+a[2,4]*x4=b2)and

(a[3,1]*x1+a[3,2]*x2+a[3,3]*x3+a[3,4]*x4=b3)and

(a[4,1]*x1+a[4,2]*x2+a[4,3]*x3+a[4,4]*x4=b4)then

begin

writeln('x1=',x1);

writeln('x2=',x2);

writeln('x3=',x3);

writeln('x4=',x4);

end

else if (x1=10)and(x2=10)and(x3=10)and(x4=10)then

write('корней нет');readln;

end.

program z70;

{Решение систем линейных уравнений методом Гаусса}

uses crt;

var a,b,c,d,e,f,k,l,v,s : array [1..5,1..5] of longint;

i,j,

x1,x2,x3,x4 : longint;

begin

clrscr;

writeln('Решить систему уравнений');

writeln('a11x1+a12x2+a13x3+a14x4=b1');

writeln('a21x1+a22x2+a23x3+a24x4=b1');

writeln('a31x1+a32x2+a33x3+a34x4=b1');

writeln('a41x1+a42x2+a43x3+a44x4=b1');

for j:=1 to 4 do

for i:=1 to 5 do

begin

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

end;

for i:=1 to 5 do begin

b[1,i]:=a[1,i]*a[2,1];

b[2,i]:=a[2,i]*a[1,1];

end;

for i:=1 to 5 do begin

b[2,i]:=b[1,i]-b[2,i];

end;

for i:=1 to 5 do beginwriteln('b=',b[2,i]);readln;end;

{2-я строка с нулевым 1-м элементом}

for i:=1 to 5 do begin

c[1,i]:=a[1,i]*a[3,1];

c[3,i]:=a[3,i]*a[1,1];

end;

for i:=1 to 5 do begin

c[3,i]:=c[1,i]-c[3,i];

end;

for i:=1 to 5 do beginwriteln('c=',c[3,i]);readln;end;

{третья строка снулевым 1-м элементом}

for i:=1 to 5 do begin

d[1,i]:=a[1,i]*a[4,1];

d[4,i]:=a[4,i]*a[1,1];

end;

for i:=1 to 5 do begin

d[4,i]:=d[1,i]-d[4,i];

end;

for i:=1 to 5 do beginwriteln('d=',d[4,i]);readln;end;

{4-я строка снулевым 1-м элементом}

for i:=2 to 5 do begin

e[2,i]:=b[2,i]*c[3,2];

e[3,i]:=c[3,i]*b[2,2];

end;

for i:=2 to 5 do begin

k[3,i]:=e[2,i]-e[3,i];

end;

for i:=1 to 5 do beginwriteln('k=',k[3,i]);readln;end;

{3-я строка с 0 1 и 2}

for i:=2 to 5 do begin

l[2,i]:=b[2,i]*d[4,2];

l[4,i]:=d[4,i]*b[2,2];

end;

for i:=2 to 5 do begin

l[4,i]:=l[2,i]-l[4,i];

end;

for i:=1 to 5 do beginwriteln('l=',l[4,i]);readln;end;

{4-я с 0 1 и 2}

for i:=3 to 5 do begin

v[3,i]:=k[3,i]*l[4,3];

s[4,i]:=l[4,i]*k[3,3];

end;

for i:=3 to 5 do begin

f[4,i]:=v[3,i]-s[4,i];

end;

for i:=1 to 5 do beginwriteln('f=',f[4,i]);readln;end;

{4-я с 0 1,2,3}

if (f[4,1]=0)and(f[4,2]=0)and(f[4,3]=0)then begin

x4:=f[4,5] div f[4,4];

x3:=(k[3,5]-k[3,4]*x4)div k[3,3];

x2:=(b[2,5]-b[2,3]*x3-b[2,4]*x4)div b[2,2];

x1:=(a[1,5]-a[1,2]*x2-a[1,3]*x3-a[1,4]*x4)div a[1,1];

writeln('x1=',x1);

writeln('x2=',x2);

writeln('x3=',x3);

writeln('x4=',x4);end

else write('Решений нет или очень много');

readln;

end.