ifs>c then

Type

PKnigi = ^Knigi;

Knigi = record

Avtor: String;

data: integer;

cena: integer;

next: PKnigi;

end;

var a, nach, kon: PKnigi; n, i, stm, count: integer;

BEGIN

writeln('Vvedite koll knig ');

readln(n);

new (a);

nach: =a;

for i: =1 to n do

Begin

Writeln('Автор книги');

readln(a^.Avtor);

Writeln('Год издания');

readln(a^.data);

Writeln('Цена');

readln(a^.cena);

a^.next: =nil;

kon: =a;

Ifi< > n then begin

new (a);

kon^.next: =a;

end; end;

a: = nach;

Whilea< > nil do begin

Writeln(a^.Avtor);

Writeln(a^.data);

Writeln(a^.cena);

a: =a^.next;

writeln;

end;

count: = 0;

writeln('введите стоимость');

readln(stm);

a: =nach;

Whilea< > nil do begin

if a^.cena < stm then inc(count);

a: = a^.next;

end;

writeln('Колличество товаров, стоимость которых меньше заданной, равно', count);

END.

(стек)

Program z2;

uses crt;

Type

PKnigi = ^Knigi;

Knigi = record

Avtor: String;

data: integer;

cena: integer;

next: PKnigi;

end;

var a, nach, kon: PKnigi; n, i, stm, count: integer;

BEGIN

writeln('Vvedite koll knig ');

readln(n);

new (a);

nach: =nil;

for i: =1 to n do

Begin

Writeln('Автор книги');

readln(a^.Avtor);

Writeln('Год издания');

readln(a^.data);

Writeln('Цена');

readln(a^.cena);

a^.next: =nach;

nach: =a;

Whilea< > nil do begin

Writeln(a^.Avtor);

Writeln(a^.data);

Writeln(a^.cena);

a: =a^.next;

writeln;

end;

count: = 0;

writeln('введите стоимость');

readln(stm);

a: =nach;

Whilea< > nil do begin

if a^.cena < stm then inc(count);

a: = a^.next;

end; end;

writeln('Колличество товаров, стоимость которых меньше заданной, равно', count);

END.

Задание 2. Задан файл f компоненты которого являются целыми числами. Получите в файле g все компоненты файла f, которые являются четными числами.

Program z2;

uses crt;

var f, g: file of integer;

a: integer;

c: char;

Begin

clrscr;

assign(f, 'filef');

rewrite(f);

assign(g, 'fileg');

rewrite(g);

writeln('Vvedite v fail F celye chisla, okonchanie vvoda Esc: ');

Repeat

write('a=');

readln(a);

write(f, a);

c: =readkey;

until c=#27;

reset(f);

writeln('Ishodnyj fail: ');

While noteof(f) do

Begin

read(f, a);

write(a, ' ');

if a mod 2 = 0 then write(g, a)

end;

close(f);

writeln;

reset(g);

writeln('Fail chetnih chisel: ');

While noteof(g) do

Begin

read(g, a);

write(a, ' ');

end;

close(g);

writeln;

readln

end.

Задание 1. Заданы координаты вершин треугольника и координаты некоторой точки внутри его. Определите расстояние от данной точки к ближайшей стороне треугольника. При решении задачи используйте процедуру пользователя и учитывайте то обстоятельство, что площадь треугольника может быть вычислена разными формулами.

program gl;

uses crt;

const t=0.00001; {погрешность вычислений при сравнении 2х вещественных чисел}

type Point= record {точку представим как запись с полями-координатами}

x, y: real;

end;

function Dlina(a, b: Point): real; {определение длины линий}

Begin

Dlina: =sqrt(sqr(a.x-b.x)+sqr(a.y-b.y));

end;

function Plosh(a, b, c: Point): real; {определение площади треугольника}

var p: real;

Begin

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

Plosh: =(sqrt(p*(p-Dlina(a, b))*(p-Dlina(b, c))*(p-Dlina(a, c))));

end;

function Proverka(a, b, c, d: Point): boolean; {проверка, попадает ли точка в треугольник}

var s, s1, s2, s3: real;

Begin

s: =Plosh(a, b, c); {площадь всего треугольника}

s1: =Plosh(a, b, d); {площади внутренних треугольников}

s2: =Plosh(a, c, d);

s3: =Plosh(b, c, d);

if abs((s1+s2+s3)-s)< t then Proverka: =true{если сумма равна общей, с учетом точности, то внутри}

else Proverka: =false;

end;

function H(a, b, d: Point): real; {вычисление высоты}

Begin

H: =2*Plosh(a, b, d)/Dlina(a, b);

end;

function Min(a, b, c: real): real; {вычисление меньшей высоты}

var mn: real;

Begin

mn: =a;

if b< mn then mn: =b;

if c< mn then mn: =c;

Min: =mn;

end;

var a, b, c, d: Point;

Begin

clrscr;

Repeat

writeln('Введите координаты X, Y вершин треугольника: ');

write('A: '); readln(a.x, a.y);

write('B: '); readln(b.x, b.y);

write('C: '); readln(c.x, c.y);

if Plosh(a, b, c)< t then writeln('Это не треугольник! Повторите ввод.');

until Plosh(a, b, c)> t;

Repeat

write('Ведите координаты X, Y точки внутри треугольника D: ');

readln(d.x, d.y);

if not Proverka(a, b, c, d) then writeln('Точка D не лежит внутри треугольника! Повторите ввод.');

until Proverka(a, b, c, d);

write('Расстояние до ближайшей стороны=', Min(H(a, b, d), H(a, c, d), H(b, c, d)): 0: 2);

readln

end.

Задание 2. Для каждой из трех вещественных матриц определите среднее арифметическое ее положительных элементов.

Program z2;

uses crt;

Const

nmax=100;

Type

tArr= array [1..nmax] of real;

procedure init(n1: integer; var ar: tArr);

var i: integer;

Begin

for i: =1 to n1 do

ar[i]: =random(199)-99;

end;

procedure outPut(n1: integer; var ar: tArr);

var i: integer;

Begin

for i: =1 to n1 do

write(ar[i], ' ');

writeln;

end;

procedure average(n1: integer; var ar: tArr);

Var

i: integer;

sum: real;

Begin

sum: =0;

for i: =1 to n1 do

sum: =sum+ar[i];

writeln('Среднее арифметическое массива = ', sum/n1: 6: 2);

writeln;

end;

Var

a, b, c: tArr;

n, m, k: integer;

Begin

Repeat

write('Введите размер первого массива: ');

readln(n);

until n in [1..nmax];

Repeat

write('Введите размер второго массива: ');

readln(m);

until m in [1..nmax];

Repeat

write('Введите размер третьего массива: ');

readln(k);

until k in [1..nmax];

init(n, a);

writeln('Массив A: ');

outPut(n, a);

average(n, a);

init(m, b);

writeln('Массив B: ');

outPut(m, b);

average(m, b);

init(k, c);

writeln('Массив C: ');

outPut(k, c);

average(k, c);

readln;

end.

Задание 2. Напечатать анкетные данные студентов, которые получили одну оценку 4 (учитывать 4 предмета).

Program z2;

Uses Crt;

Type Student= Record

Fam, Data: string[12];

Ozenka1, Ozenka2, Ozenka3, Ozenka4: 2..5;

End;

Var A: array [1..100] of student;

i, n: byte;

Begin

ClrScr;

write('Введите кол-во студентов: '); readln(n);

For i: =1 to n do

Begin

writeln('Введите информацию о ', i, '-ом студенте ');

write('Фамилия: '); readln(A[i].Fam);

write('Дата рождения: '); readln(A[i].Data);

write('Оценка №1: '); readln(A[i].Ozenka1);

write('Оценка №2: '); readln(A[i].Ozenka2);

write('Оценка №3: '); readln(A[i].Ozenka3);

write('Оценка №4: '); readln(A[i].Ozenka4);

End;

writeln('-------------------------------------------------------------------------');

writeln(' Фамилия | ', ' Дата | ', 'Оценка №1 | ', 'Оценка №2 | ', 'Оценка №3 | ', 'Оценка №4');

writeln('-------------------------------------------------------------------------');

For i: =1 to n do

if (A[i].Ozenka1=4) or (A[i].Ozenka2=4) or (A[i].Ozenka3=4) or (A[i].Ozenka4=4) then

writeln(A[i].Fam: 12, '|': 1, A[i].Data: 12, '|': 1, A[i].Ozenka1: 11, '|': 1, A[i].Ozenka2: 11, '|': 1, A[i].Ozenka3: 11, '|': 1, A[i].Ozenka4: 11);

readln;

End.

Задание 1. Написать программу, которая бы вводила с клавиатуры строку и определяла на каких позициях в строке расположены символы ‘: ’ и ‘, ’ (использовать функцию Pos).

program z1;

var i, nStrLen: Integer; n: string;

Begin

writeln(' vvedite stroky ');

readln (n);

nStrLen: =Length(n);

Write('Позиции знаков в строке: ');

For i: =1 to nStrLen do

If n[i]=': ' then

Write(' ', i);

For i: =1 to nStrLen do

If n[i]='; ' then

Write(' ', i);

end.

Задание 1. Составьте программу определения значения выражения, заданного формулой:

program z1;

uses crt;

const c=10.1;

var y: array [1..100] of real;

i, n: integer; z, s: real;

Begin

write('n=');

readln(n);

for i: =1 to n do begin

writeln('vvedinte y[', i, ']');

readln(y[i]);

end;

s: =0;

for i: =1 to 6 do begin

s: =s+y[i];

end;

ifs> c then

z: =sin(c)*sin(c)

else z: =cos(c)*cos(c);

writeln('z=', z: 7: 3);

end.

Задание 3. Даны натуральное число n, действительные числа a1,..., аn. В последовательности a1,..., аn все неотрицательные члены, не принадлежащие отрезку [1, 2], заменить на единицу. Кроме того, получить число отрицательных членов и число членов, принадлежащих отрезку [1, 2].

Program z3;

uses crt;

var a: array [1..20] of integer;

i, n, p, o: byte;

Begin

write('vvedite n (ne bolshe 20): ');

Repeat

read(n);

until n in [1..20];

write (' Massiv: ');

for i: =1 to n do begin

a[i]: =random(5)-2;

write(a[i], ' ');

if a[i] in [1..2] then inc(p);

if a[i]< 0 then inc(o);

end;

for i: =1 to n do begin

if a[i] in [1..2] then a[i]: =1;

end;

writeln;

write(' Izmenenniq massiv; ');

for i: =1 to n do begin

write(a[i], ' ');

end;

writeln;

writeln('Otr elementov: ', o);

writeln(' Elementov v diapazone [1.2]: ', p);

end.

Задание 6. Дана действительная квадратная матрица порядка 12. Заменить нулями все ее элементы, расположенные на главной и побочной диагоналях и выше их.

program z6;

uses crt;

const n=12;

var a: array [1..n, 1..n] of Real;

i, j: Integer;

Begin

Writeln('Исходная матрица: ');

Randomize;

for i: =1 to n do

Begin

for j: =1 to n do

Begin

a[i, j]: =Random(101)/10;

Write(a[i, j]: 0: 1, ' ');

end;

Writeln;

end;

for i: =1 to n do

for j: =1 to n do

if (j< i) or (i=j) then a[i, j]: =0;

for i: =1 to n do

for j: =1 to n-i+1 do a[i, j]: =0;

for i: =1 to n do a[i, n-i+1]: =0;

Writeln('Полученная матрица: ');

for i: =1 to n do

Begin

for j: =1 to n do

Write(a[i, j]: 0: 1, ' ');

Writeln;

end;

Readln;

end.

Задание 3. Вычислите:

Program z3;

uses crt;

Var

i, n: integer;

s, x: real;

BEGIN

writeln('Введите n');

readln(n);

x: =1;

for i: =1 to n do begin

x: =x*i;

s: =(s+1/x)-1;

end;

writeln('s=', s);

END.