Шпаргалка по информатике (сборник Паскаль). Сборник_Паскаль1. 1. Найти значение выражения 1122 nn
Скачать 192 Kb.
|
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) 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. |