Основные приемы работы в среде ТР

БОЛЬШАЯ ЛЕНИНГРАДСКАЯ БИБЛИОТЕКА - РЕФЕРАТЫ - Основные приемы работы в среде ТР

Основные приемы работы в среде ТР

Актюбинский Политехнический колледж

Отчет

по учебной практике

по программированию

Выполнила:

Волоснова А.С

учащаяся

группы 202АС

Проверила:

Гайсагалеева Б.М

Актобе 2010

ДНЕВНИК.

СОДЕРЖАНИЕ.

1. Линейная программа на Паскаль.

2. Программа с ветвлениями.

3. Циклическая программа.

4. Массивы.

5. Процедуры и функции.

6. Файловые данные в Паскале.

7. Записи в Паскале.

8. Строки.

9. Графика в Турбо-Паскале.

Раздел: Линейные алгоритмы

1.Описание: Программа вычисления периметра треугольника.

program one;

uses crt;

var a,b,P:integer;

begin clrscr;

writeln ('a=');

readln (a);

writeln ('b=');

readln (b);

P:=(a+b)*2;

writeln ('P=',P);

end.

2.Описание: Программа вычисления площади треугольника.

program one;

uses crt;

var a,b,h,s:real;

begin clrscr;

writeln('A= B= H= ');

readln(a,b,h);

s:=h*(a+b)/2;

writeln('S=',s:0:4);

readln;

end.

3.Описание: Программа вычисления количества теплоты по формуле 'Q=c*m*(t2-t1)

program one;

uses crt;

var Q,c,m,t2,t1:integer;

begin clrscr; textcolor(10);

writeln ('c=');

readln (c);

writeln ('m=');

readln (m);

writeln ('t2=');

readln (t2);

writeln ('t1=');

readln (t1);

Q:=c*m*(t2-t1);

writeln('Q=c*m*(t2-t1)=',Q);

end

4.Описание: Программа вычисления величины силы тока I на участке цепи с R Ом и U В.

program one;

uses crt;

var I,U,R:real;

begin clrscr; textcolor(10);

writeln ('U='); readln (U);

writeln ('R=');

readln (R);

I:=U/R;

writeln('I=',I:5:0);

end.

5.Описание: Программа вычисления расстояния между двумя точками с данными координатами x1,y1,x2,y2

program one;

uses crt;

var r:real; x1,x2,y1,y2:integer;

begin clrscr;

writeln ('znachenie x1=');

readln (x1);

writeln ('znachenie x2=');

readln (x2);

writeln ('znachenie y1=');

readln (y1);

writeln ('znachenie y2=');

readln (y2);

r:=sqrt(sqr(x2-x1)+sqr(y2-y1));

writeln ('rasstoyanie=',r);

end.

6.Описание: Известна сумма денег,имеющаяся у покупателя и стоимость одной ед. товара. Сколько ед. товара может купить покупатель и какова его сдача?

program one;

uses crt; var a,b,c:real; begin clrscr;

writeln ('summa deneg=');

readln (a);

writeln ('cena ed.tovara=');

readln (b);

c:=a/b;

writeln ('ostatok=',c);

end.7.Описание: Сумма цыфр введенного трехзначного натурального числа.

program one;

uses crt;

var a:integer; s,d,e,f:real;

begin clrscr;

writeln ('vvedi 3-hznachnoe chislo');

readln (a);

s:=a div 100;

d:=a mod 100 div 10;

e:=a mod 100 mod 10;

writeln (d:5:0); writeln (s:5:0); writeln (e:5:0);

f:=d+s+e; writeln (f:5:0);

end.

8.Описание: Найти площадь по известной стороне равностороннего треугольника.

program one;

uses crt;

var a,S:real;

begin clrscr;

writeln('Vvedite storonu treugolnika');

readln(a);

S:=0;

S:=a*a*sqrt(3)/4;

writeln ('Ploshad ravna:', S:3:1);

readln;

end.

9.Описание: Бабушка вяжет в неделю 3 пары детских носков, пару женских и пару мужских и продает их. Считая, что в месяце 4 недели,определить,какую прибыль бабушка имеет за месяцю.

program one;

uses crt; var det,jen,muj,ned,mes:integer;

begin clrscr;

writeln ('det:=');

readln (det);

writeln ('jen:=');

readln (jen);

writeln ('muj:=');

readln (muj);

ned:=muj+jen+det;

mes:=4*ned;

writeln('dohod=',mes);

end

10.Описание: Пирамида из звездочек

program one;

uses crt;

var j,i:integer;

begin clrscr;textcolor(9+5);

for i:=1 to 25 do begin gotoxy(40-i,i);

for j:=2 to 2*i do write('*');

end;

readln;

end.

11.Описание:Вычислить произведение

Program one;

Uses crt;

Var a,b,p:integer;

begin clrscr;textcolor(9+5);

writeln ('a= b=');

readln (a,b);

p:=a*b;

textcolor (9+16);

writeln (`p=,p');

end.

12.Описание: Вычисление радиуса

Program one;

Uses crt;

Var l:real; r:integer;

begin clrscr;textcolor(5);

writeln ('R=');

readln (r);

l:=2*pi*r;

writeln (`radius=,r');

end.

13.Описание: Вычисление периметра квадрата

Program one;

Uses crt;Var а:integer;

begin clrscr;textcolor(5);

writeln ('a=');

readln (a);

p:=4*a;

writeln (`perimetr=,р');

end.

14.Описание: Выведение введенного числа

Program one;

Uses crt;Var s:integer;

begin clrscr;textcolor(5);

writeln ('s=');

readln (s);

writeln (`вы ввели число,s');

end.

15.Описание: Вычисление плотности по количеству жителей и площади.

Program one;

Uses crt;Var k,s:integer; p:real;

begin clrscr;textcolor(5);

writeln ('число жителей=');

readln (k);

writeln (`plosh=');

readln (s);

p:=s/k;

writeln (`plotnost=',p);

end.

Раздел: Разветвляющиеся алгоритмы

1.Описание: Вычисление уравнения

program one;

var x,y:integer;; begin write('x='); readln(x); if x>0 then y:=sqr(sin(x)) else y:=1-2*sin(sqr(x)); writeln (y); end.

2.Описание: Деление нацело

Program ch;

Uses crt;

Var a,m,n:integer;

Begin clrscr;

Writeln (`m= n=');

Readln (m,n);

a:=m mod n;

If a=0 then write (m div n)

Else write(`net resh')

End.

3 .Описание: Написать программу на языке Pascal для реализации разветвляющегося алгоритма, где x - известные величины.

program one;

var x,y:real;

begin writeln('');

write('Vvedite x=');

readln(x); if x<=0.8 then

y:=exp(x-1)+3.14 else if (0.8<x) and (X<=5.27) then

y:=ln(x+5.96) else y:=2*x;

writeln('y=',y:4:2); readln;end.

4. Описание: Написать программу на языке Pascal для реализации разветвляющегося алгоритма, где x - известные величины.

program one; var x,y,z:real; begin writeln(''); write('Vvedite x='); readln(x); write('Vvedite y='); readln(y);

if x-y>0 then z:=1/(x*y) else z:=sqr(x)*sqr(y); writeln('z=',z:4:2); readln; end.

5 .Описание: Написать программу на языке Pascal для реализации разветвляющегося алгоритма, где x=ln a2, y=1/arctg b; a,b - известные величины. program one; var x,y,z,a,b:real; begin writeln(''); write('Vvedite a='); readln(a); write('Vvedite b='); readln(b); x:=ln(sqr(a)); y:=1/arctan(b); if x-y>0 then z:=1/(x*y) else z:=sqr(x)*sqr(y); writeln('z=',z:4:2); readln; end.

6. Описание: Заданы два прямоугольных параллелепипеда. Можно ли разместить их один в другом?program one; var a1,a2,b1,b2,c1,c2:integer; begin writeln('vvedite shiriny, dliny, vusoty 1');

readln(a1,b1,c1); writeln('vvedite shiriny, dliny, vusoty 2'); readln(a2,b2,c2); if ((a1<=a2) and (b1<=b2) and (c1<=c2)) or ((a1>a2) and (b1>b2) and (c1>c2)) then writeln('mogno') else writeln('nelzya'); readln; end.

7. Описание: номер клетки на шахматной доске 8х8 определяется двумя целыми числами - номер вертикали и номер горизонтали. Даны 4 целых положительных числа a,b,c,d. Выяснить, бьет ли ферзь, находящийся на клетке (a,b) клетку(c,d)

program one; var a,b,c,d:integer; begin read(a,b); read(c,d); if (a=c) or (b=d) or (abs(c-a)=abs(d-b))

then write('ga') else write('HeT');

readln

end

8. Описание: Возможно, ли построить треугольник с данными сторонами

program one;

uses crt;

var a,b,c:real;

begin clrscr;

writeln('Стороны треугольника= ');

readln(a,b,c);

if (a<b+c) and (b<a+c)

and(c<a+b) then write('можно')

else write('невозможно');

readkey;

end.

9 .Описание: Даны три неравных числа a, b, c. Составить программу нахождения квадрата большего из этих чисел.

program one; var a,b,c:real; begin read(a,b,c); if (a>b) and (a>c) then write('a^2= ',a*a:1:4); if (b>a) and (b>c) then write('b^2= ',b*b:1:4); if (c>a) and (c>b) then write('c^2= ',c*c:1:4); readln end.

10.Описание:Вычисление большего из двух чиселProgram b_ch;

Uses crt;

Var a,b:integer;

Max:integer;

Begin clrscr;

Writeln (`a= b=');

Readln (a,b);

If a>b then max:=a else max:=b

Writeln (`max=',max);

End.

11.Описание:Вычисление меньшего из двух чисел

Program m_ch;

Uses crt;

Var a,b:integer;

Min:integer;

Begin clrscr;

Writeln (`a= b=');

Readln (a,b);

If a<b then min:=a else min:=b

Writeln (`min=',min);

End.

12.Описание:Деление нацело

Program ch;

Uses crt;

Var a,b,c:integer;

Begin clrscr;

Writeln (`a= b=');

Readln (a,b);

C:=a mod b;

If c=0 then write (a div b)

Else write(`net resh')

End.

13.Описание: Сравнение чисел трехзначного числа

Program ch;

Uses crt;

Var a,b,c,d,e,i:integer;

Begin clrscr;

Writeln (`a=');

Readln (a);

D:=a div 100;

E:=b mod 100 div 10;

C:=I mod 10;

writeln(d,e,c);

if (a<b) and (b<i) then writeln (`ravny')

else writeln (`ne ravny');

End.

14.Описание: Принадлежит ли число интервалу

Program ch;

Uses crt;

Var a:integer;

Begin clrscr;

Writeln (`a=');

Readln (a);

if (a>=(-5)) and (a<=3) then writeln (`prinadl')

else writeln (` ne prinadl');

End.

15.Описание:Сравнить 3 стороны треугольника

Program ch;

Uses crt;

Var a,b,c:integer;

Begin clrscr;

Writeln (`a= b= c=');

Readln (a,b,c);

if (a=c) or (a=b) then writeln (`ravnobedr')

else writeln (` ne ravnobedr');

End.

Раздел: Алгоритмы циклической структуры:

1.Описание: Написать программу на языке Pascal для реализации циклического алгоритма n, х - известные величины.

var i,j,fact,n:integer;

s,x:real;

begin

writeln;

write('Vvedite n=');

readln(n);

write('Vvedite x=');

readln(x);

s:=0;

for i:=1 to n do begin fact:=1;

for j:=1 to i do Fact:=fact*j;

s:=s+(1/fact+sqrt(abs(x)));

end;

writeln('s=',s:4:2);

readln;

end.

2.Описание: Написать программу на языке Pascal для реализации циклического алгоритма

n - известные величины. program one;

var i,j,n,zn,factorial:integer; s,x:real; begin writeln; write('Vvedite n='); readln(n); s:=0; factorial:=1; zn:=1; for i:=1 to n do begin zn:=zn*(-1); factorial:=factorial*i; s:=s+(zn*(i+1)/factorial); end; writeln('s=',s:4:3); readln; end.

3.Описание: Написать программу на языке Pascal для реализации циклического алгоритма

s=1/1*2-1/2*3+…+(-1)n+1/n(n+1) n - известные величины.

program one;

var i,j,n,zn:intege r; s,x:real; begin writeln; write('Vvedite n='); readln(n); s:=0; zn:=-1; for i:=1 to n do begin zn:=zn*(-1); s:=s+zn/(i*(i+1)); end; writeln('s=',s:4:2); readln; end.

4.Описание: Написать программу на языке Pascal для реализации циклического алгоритма

n - известные величины. program one;

var i,j,n:integer; stepen:integer; s:real; begin writeln; write('Vvedite n='); readln(n); s:=0; for i:=1 to n do begin stepen:=1; for j:=1 to 5 do begin stepen:=stepen*i; end; s:=s+1/stepen; end; writeln('s=',s:4:2); readln; end.

5. Описание: Написать программу, которая выводит целые четные числа с клавиатуры и складывает их , пока не будет введено число 0.

Program 5;

Uses crt;

Var n,s:integer.;

Begin clrscr;

S:=0;

Repeat;

Writeln(vvedi chislo);

Readln(n);

S:=s+n;

Until n=0;

Writeln(s=,s);

Readln;

End.

6. Описание: Составить программу, подсчета суммы S первых 1000 членов гармонического ряда 1+1/2+1/3+…+1/N

Program 1;

Uses crt;

Var s:real; n;integer;

Begin clrscr;

S:=0; n:=0;

Repeat;

N:=n+1;

S:=s+1/n;

Until n=1000;

Writeln(s);

End.

7. Описание: Напечатать 20 первых степеней числа 2.

Program 2;

Uses crt;

Var n,s:longint;

Begin clrscr;

S:=1;

N:=1;

Repeat S:=s*2;

Writeln(s,);

N:=n+1;

Until n>20; Readln;

End.

8. Описание:Известны оценки по информатике каждого из 20 учеников класса. В начале списка Перечислены все «5»,затем остальные оценки. Сколько учеников имеют оценку «5»?

Program 5;

Uses crt;

Var x,n:word;

Begin clrscr;

Writeln(vvedi ocenki);

Readln(x);

N:=0;

While x=5 do begin n:=n+1;

Writeln(vvedi ocenki);

Readln(x);

End;

Writeln(imeyut 5,n,uchenikov);

Readln;

End.

9. Описание: Вычислить наибольший общий делитель двух натуральных чисел А и В, использую для этого алгоритм Евклида. Будем уменьшать каждый раз большее из чисел на величину меньшего до тех пор, пока оба числа не станут равными.

Program nod;

Uses crt;

Var a,b:integer;

Begin clrscr;

Writeln(vvedi 2 chisla);

Readln(a,b);

While a<>b do if a>b then a:=a-b else b:=b-a;

Writeln(nod=,a);Readln;

End.

10.Описание: Программа подсчета суммы S первых 1000 членов гармонического ряда 1+1/2+1/3+1/4+…+1/N

Program S;

Uses crt;

Var s:real;n:integer;

Begin clrscr;

S:=0; N:=0;

While n<1000 do begin N:=n+1;

S:=s+1/n;

End;

Writeln(s);

Readln;

End.

11.Описание:Имеется четыре (A, B, C, D) числа. Необходимо ответить на вопрос:«Правда ли что все среди этих чисел есть равные?»Ответ вывести в виде текста:«Правда», или «Неправда».

Program z1;

var a,b,c,d:integer; {описываем имеющиеся переменные}

begin writeln('vvedite chislo a'); {вводим все числа по очереди}

readln(a);

writeln('vvedite chislo b');

readln(b);

writeln('vvedite chislo c');

readln(c);

writeln('vvedite chislo d');

readln(d);

if (a=b)or (a=c) or (a=d)or (b=c) or (b=d) or (d=c) then writeln ('pravda') else writeln ('nepravda');

readln;

end.

12.Описание: Составить программу вычисления и выдачи на печать суммы (произведения) N элементов бесконечного ряда. Оформить проверку задания. Y=(-512)*256*(-128)*64…… Общая формула имеет вид: y=210-i

program z2;

var i,j,zn,n:integer; s:real;

begin writeln;

writeln('vvedite kolichestvo elementov ryada');

write('N='); {вводим количество элементов ряда}

readln(n);

s:=1;

for i:=1 to n do begin zn:=1;

for j:=1 to i+1 do begin zn:=zn*(-1);

end;

s:=s*(-zn)*(exp((10-i)*ln(2))); {вводим формулу}

end;

writeln('s=',s:4:2);

readln;

end.

13.Описание: Дана функция Y=1-[x-2]^2/10 вычислить и напечатать значения этой функции для последовательных значений x=c,x=c+(b+1), x=c+2(b+1),x=c+3(b+1) где а=1; b=9;с=2. Считать до тех пор пока сумма Y+6 не станет отрицательной.

program zad3;

const b=9; c=2;

var x,n:integer; f,s:real; function y(x:integer):real;

begin y:=1-(sqr(x-c)) / (b+1);

end;

begin writeln('Y=1-[x-2]^2/10');

n:=0;

repeat x:=c+n*(b+1);

inc(n);

f:=y(x);

write('x',n,'= ',x,' ');

writeln('y',n,'= ',f:6:5)

until f+6<0;

readln

end.

14.Описание: Имеется массив А из N произвольных чисел (A(n)), среди которых есть положительные, отрицательные и равные нулю. Напечатать только те числа из массива которые больше предыдущего числа.

program z4;

uses Crt;

const MAX = 100;

var mas : array[1..MAX] of integer; n,i : byte; k,p: integer;

begin ClrScr;

Write('N:=');

Readln(n);

for i:=1 to n do begin Write('vvedite ',i,' element massiva:>');Readln(mas[i]); end;

begin k := 0;

for i := 1 to n do begin if mas[i]>mas[(i-1)] then writeln (mas[i]); end;

readln; end;

end.

15.Описание: Составить программу вычисления числового ряда для известного числа членов ряда N. Y=(7+35/1)(8-3-4/2)(9+33/3)….

program z5;

var i,j,zn,n:integer; s:real;

begin writeln;

writeln('vvedite kolichestvo elementov ryada');

write('N=');

readln(n);

s:=1;

for i:=1 to n do begin zn:=1;

for j:=1 to i+1 do begin zn:=zn*(-1);end;

s:=s*((6+i)+exp((zn*(6-i))*ln(3))/i);end;

writeln('s=',s:4:2);

readln;

end.

Раздел : Массивы

1 Описание: Найти, сколько раз каждый элемент встречается в массиве

Дополнительных массивов не создавать.

Program msv;

Const Size=10; Diap=10;

var a: array [1..Size] of integer; i,n,k,j:integer;

begin writeln;

repeat write('Введите размерность 1 массива (от 2 до ',Size,'):');

Read (n);

Until (n>1) and (n<=Size); Randomize;

a [1]:=Random(Diap);

Write ('A= ', a[1],' ');

For i: =2 to n do begin A[i]:=Random (Diap);

Write (a[i],' '); End;

writeln;

k:=0;

For i: =1 to n do if a[i]=0 then Inc(k);

If k>0 then writeln ('0: ',k);

For i: =1 to n-1 do if a[i]<>0 then begin K: =1;

For j: =i+1 to n do if a[i]=a[j] then begin A[j]:=0;

Inc (k); End;

writeln (a[i],': ',k); end;

end.

2. Описание: Объединить 2 упорядоченных массива по возрастанию.

Program msv;

const Size=10; Step=5;

var a,b:array [1..Size] of integer; c:array [1..2*Size] of integer; i,n1,n2,ia,ib,ic:integer;

begin writeln;

repeat write('Введите размерность 1 массива (от 2 до ',Size,'):');

read (n1);

until (n1>1) and (n1<=Size);

Randomize;

a[1]:=Random(Step);

write ('A= ',a[1],' ');

for i:=2 to n1 do begin a[i]:=a[i-1]+Random(Step);

write (a[i],' '); end;

writeln;

repeat

write('Введите размерность 2 массива (от 2 до ',Size,'):');

read (n2);

until (n2>1) and (n2<=Size);

b[1]:=Random(Step);

write ('B= ',b[1],' ');

for i:=2 to n2 do begin b[i]:=b[i-1]+Random(Step);

write (b[i],' ');

end;

writeln;

ia:=1; ib:=1;

write ('C= ');

for i:=1 to n1+n2 do begin if a[ia]<=b[ib] then begin c[i]:=a[ia];

if ia<n1 then Inc(ia) else begin a[n1]:=b[ib];

if ib<n2 then Inc (ib); end; end

else begin c[i]:=b[ib];

if ib<n2 then Inc(ib) else begin b[n2]:=a[ia];

if ia<n1 then Inc(ia); end; end;

write (c[i],' ');

end;

writeln;

end.

3. Описание: Дан массив чисел. Найти наибольшее.

Program msv;

Uses crt;

Var i,n,max:integer; a:array[1..100] of integer;

begin clrscr;

read(n);

for i:=1 to n do read(a[i]); {ввод чисел в массив}

max:=a[1];

for i:=2 to n do if a[i] > max then max:=a[i]; {сравнивается с уже найденным наибольшим,}

write('maksimalnoe chislo = ',max);

readln;

end.

4. Описание: Найти сумму элементов числового массива

Program msv;

uses crt;

Var i,n,s:integer; a:array[1..1000] of integer;

begin clrscr;

read(n);

for i:=1 to n do read(a[i]); {ввод значений в массив}

s:=0;

for i:=1 to n do s:=s+a[i];

write('Summa = ',s); readln;

readln;

end.

5. Описание: Дан числовой массив. Вычислить сумму элементов,имеющих четное значение индекса. Вычислительную часть организовать в виде функции

Program msv;

Uses crt;

type mas=array[1..100] of integer;

Var a:mas; i,n:integer; function calc(b:mas;m:integer):integer;

var i,s:integer;

begin s:=0;

for i:=1 to m do;

if i mod 2=0 then s:=s+b[i];

calc:=s;

end;

begin clrscr;

read(n);

for i:=1 to n do read(a[i]);

write('Сумма каждого второго элемента = ',calc(a,n));

readln;

readln;

end.

6. Описание: Дан массив символов. Вычислить, сколько в нем элементов 'a'

Program msv;

Uses crt;

Var i,n,s:integer; a:array[1..100] of char;

begin clrscr;

readln(n); {Объявление а:array[1..1000] of char означает,}

for i:=1 to n do readln(a[i]);

s:=0;

for i:=1 to n do readln(a[i]);

s:=0;

for i:=1 to n do if a[i]='a' then s:=s+1;

write('Kolichestvo elementov ravnyh "a" = ',s);

readln;

end.

7. Описание: Дан двумерный массив целых чисел размерностью NxN. Найти сумму его элементов

Program msv;

Uses crt;

Var s,i,j,n:integer; a:array[1..10,1..10] of integer;

begin clrscr;

read(n);

for i:=1 to n do for j:=1 to n do read(a[i,j]);

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

write('Сумма элементов = ',s);

readln;

readln;

end.

8. Описание: По заданному массиву X[7] сформировать массив Y, элементы которого вычисляются по формуле

Y[i]= |X[i]-B|, где B - максимальный элемент массива X

program msv;

const Size=7; { Размерность массива }

var x:array [1..Size] of real; b:real; i:integer;

begin writeln;

writeln ('Жду ввода элементов массива размерностью ',Size,':');

for i:=1 to Size do begin write ('x[',i,']=');

readln (x[i]); end;

b:=x[1];

for i:=2 to Size do if x[i]>b then b:=x[i];

writeln ('Максимальный элемент=',b:10:3);

writeln ('Исходный Новый');

writeln ('массив массив');

for i:=1 to Size do begin write (x[i]:10:4);

x[i]:=abs(x[i]-b);

writeln (x[i]:10:4); end;

end.

9. Описание: Найти максимальный элемент в линейном массиве.

Вывести результат на экран

program msv;

uses crt;

const

nn = 10; var max, i: integer; a: array[1..nn] of integer; begin clrscr;

for i := 1 to nn do a[i] := random(500);

max := a[1];

for i := 2 to nn do if a[i] > max then max := a[i];

for i := 1 to nn do write(a[i], ' '); writeln;

writeln('Max = ', max);

readkey;

end.

10. Описание: Отсев. Удалить в заданном массиве x(n) лишние (кроме первого) элементы так, чтобы оставшиеся образовывали возрастающую последовательность(за один просмотр массива)

program msv;

uses crt;

const n = 10; {dlina massiva}

var a: array[1..n] of integer; i, max, j, k, mi: integer; begin clrscr; randomize;

for i := 1 to n do begin a[i] := random(51);

write(a[i], ' '); end;

max := a[1];

k := 2; {t.k. uslovie zadachi "preobarzovat' za odin prosmotr massiva", to}

{k ne mozhet bit' bol'she N, chem mi vospol'zuemsya v cikle}

for i := 2 to n do begin if k > n then break;

if a[i] <= max then {esli a[i] <= max to udalyaem etot element}

begin for j := i to n - 1 do {etogo cikl mog bi ne viiti, no u nas est' K}

a[j] := a[j + 1];

dec(i); end;

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

mi := i; {MI - poziciya maksimuma v massive} end;

inc(k); {uvelichivaem K, k = [2..n]} End;

Write (#10#13, a[1], ' ');

For i: = 2 to mi do Write (a[i], ' ');

readkey;

end.

11. Описание: В массиве X из n элементов каждый из элементов равен 0, 1 или 2. Переставить элементы массива так, чтобы сначала располагались нули, затем единицы и двойки. Дополнительный массив не использовать.

Программа расширена для возможности переставлять элементы массива, являющимися любыми числами (не только 0, 1, 2)

Program msv;

Const n = 10; {кол-вл элементов массива}

var a, b, t : integer; X: array[1..n] of integer; {сам массив из n элементов}

BEGIN For a := 1 to n do {ввод массива X} Begin Write ('Введите X [', a, ']: ');

Readln(X[a]); End;

for a := 1 to n do begin t := X[a];

b := a - 1;

While (b>=0) and (t<X[b]) do Begin X [b+1]:= X[b];

B: = b - 1; End;

X [b+1]:= t; end;

for a := 1 to n do {вывод результата}

Write(X[a]:2);

END. {конец программы}

12. Описание: Операции с массивом, сортировка суммирование.В одномерном массиве, состоящем из N вещественных элементов, вычислить:1) количество элементов массива, равных 0;2) сумму элементов массива, расположенных после минимального элемента.

Упорядочить элементы массива по возрастанию модулей элементов.

Program msv;

Uses CRT;

Const N = 10; {сколько всего элементов}

Var a: Array[1..N] of Real; i, j: Byte; Zero: Byte; Min: Real; Summ: Real;

Procedure Print;

Begin For i := 1 to N do Write(a[i]:0:1,' ');

Writeln;End;

Procedure CreateMassive;

BeginWriteln('Исходная последовательность');

For i := 1 to N do Begin a[i] := Random(4);

a[i] := a[i] - 2; {Этот и предыдущий операторы можно объединить}

End;

Print;

Writeln;End;

Begin ClrScr;Randomize;

CreateMassive;

Min := a[1];

For i := 2 to N do Begin Summ := Summ + a[i];

If (a[i] < Min) then Begin Min := a[i];

Summ := 0; End; End;

Writeln('Минимальный элемент ',Min:0:1,'. Сумма элементов после: ',Summ:0:1);

For i := 1 to N do Begin For j := i + 1 to N do If (abs(a[j]) < abs(a[i])) then Begin a[i] := a[i] + a[j];

a[j] := a[i] - a[j];

a[i] := a[i] - a[j]; End; End;

Writeln(#13#10,'Отсортировання последовательность'); Print;

For i := 1 to N do If a[i] = 0 then Inc(Zero);

Write(#13#10,'Нулевых элементов: ',Zero);ReadKey;

End.

13. Описание: Вычислить угол между двумя заданными векторами размерности 8, используя функцию скалярного произведения a = arccos((x,y)/((x,x)*(y,y)))

program msv;

uses crt;

type TVector = array[1..8] of Real;

function scal(var Vec1, Vec2 : TVector):real; var p : Real; i : integer;

begin p:=0;

for i:=1 to 8 do p:=p+(Vec1[i]*Vec2[i]);

scal := p;end;

var Vec1, Vec2 : TVector; i : integer; sc, a, angle : Real;

BEGIN writeln('Условие:');

writeln(' вычислить угол между двумя заданными векторами размерности 8,');

writeln(' используя функцию скалярного произведения');

writeln;

Writeln('Ввод первого вектора');

for i := 1 to 8 do begin Write('Vec1[', i, '] : ');

Readln(Vec1[i]); end;

Writeln('Ввод второго вектора');

for i := 1 to 8 do begin Write('Vec2[', i, '] : ');

Readln(Vec2[i]); end;

sc := scal(Vec1, Vec2);

a:= sc/sqrt(scal(Vec1,Vec1)*scal(Vec2,Vec2)); {Вычисляется косинус}

if a=0 then angle:=90 else angle:=arctan(sqrt(1-a*a)/a)*180/pi;

if a=-1 then angle:=180;

if angle<0 then angle:=180+angle;

writeln('Угол между векторами: ',angle:7:3,' градусов');

END.

14. Описание: Вычислить сумму двух векторов, первый из которых вводится, а элементы второго вычисляются по формуле b[i]:=sin(i*x), где 0<=x<=3.14

program msv;

const Nm = 10; {размерность вектора}

var Vec1, Vec2, ResVec : array[1..Nm] of Real; i : integer; x : Real; N : integer;

BEGIN writeln('Условие :');

writeln(' вычислить сумму двух векторов, первый из которых вводится, а элементы');

writeln(' второго вычисляются по формуле b[i]:=sin(i*x), где 0<=x<=3.14');

writeln;

Write('введите размерность вектора (N<', Nm, '): ');

Readln(N);

if n <= Nm then begin Writeln('Ввод вектора');

for i := 1 to N do begin Write('Vec1[', i, '] : ');

Readln(Vec1[i]); end;

Write('Введите X (от 0 до 3.14) : '); Readln(x);

if (X <= 3.14) and (X >= 0) then begin for i := 1 to N do begin Vec2[i] := sin(Vec1[i]*X); ResVec[i] := Vec1[i]*Vec2[i]; {сразу же вычисляем произведние} end;

Write('Результирующий вектор : '); {выводим на экран результат}

for i := 1 to N do Write(ResVec[i]:6:2); end else Writeln('Введено неверное X');

end else Writeln('неверная размерность');

END.

15. Описание: Создается случайный массив из 5 элементов. Заменить все четные значения на 1, нечетные - на 0.

Program msv;

uses crt;

const n=5;

var a:array[1..n] of integer; i:integer;

begin clrscr; randomize;

for i:=1 to n do begin a[i]:=random(9);

write(a[i]); end;

writeln;

for i:=1 to n do begin if odd(a[i])=false then a[i]:=1 else a[i]:=0;

write(a[i]);

end;

readkey;

end.

Раздел: Процедуры и функции

1.Описание: Найти последовательности целых чисел те, которые встречаются в ней ровно два раза.

program one;

uses crt;

type mas=array[1..100]of integer; func=function(var x:mas):integer; var a:mas; j,n,m,x:integer;

function kolichestvo(var c:mas):integer; var k,i:integer;

begin k:=0;

for i:=1 to n do if c[i]>m then k:=k+1;

kolichestvo:=k; end;

procedure deist(var b:mas; operation:func);

begin writeln('b[j]');

for j:=1 to n do readln(b[j]);

for j:=1 to n do write(b[j],' '); writeln;

x:=operation(a); end;

begin clrscr;

writeln('vvedite celoe chislo m i razmer massiva(n)');

readln(m,n);

deist(a,kolichestvo);

writeln('kolichestvo=',x);

readkey;

end.

2.Описание: Процедура отображения рамки в текстовом режиме

program frame;

uses Crt;

procedure Frm(l:integer; t:integer; w:integer; h:integer);

var x,y:integer; i:integer; c1,c2,c3,c4,c5,c6:char;

begin clrscr;

c1:=chr(218); c2:=chr(196);

c3:=chr(191); c4:=chr(179);

c5:=chr(192); c6:=chr(217); GoToXY(l,t);

write(c1);

for i:=1 to w-2 do write(c2);

write(c3);

y:=t+1;

x:=l+w-1;

for i:=1 to h-2 do begin GoToXY(l,y);

write(c4);

GoToXY(x,y);

write(c4);

y:=y+1; end;

GoToXY(l,y);

write(c5);

for i:=1 to w-2 do write(c2);

write(c6);

end;

begin Frm(2,2,15,10);

readln;

end.

3.Описание: Произведение нечетных элементов

Program one;

type massiv= array [1..100] of integer;

var A1,A2:massiv; i,j:integer; n1,n2:integer; function pr_nec(m:massiv; n:integer):integer;

var i,j,pr:integer;

begin pr:=1;

for i:=1 to n do if odd(m[i]) then pr:=pr*m[i];

pr_nec:=pr;

end;

begin writeln('Vvedite PERVYI massiv:');

write('ego razmer "n": '); readln(n1);

for i:=1 to n1 do begin write('A1[',i,']='); readln(A1[i]); end;

writeln('_______________________');

writeln('Vvedite VTOROI massiv:');

write('ego razmer "n": '); readln(n2);

for i:=1 to n2 do begin write('A2[',i,']='); readln(A2[i]); end;

writeln('_______________________');

writeln;

writeln('Vi vveli:');

write('A1: '); for i:=1 to n1 do write(A1[i],' '); writeln;

write('A2: '); for i:=1 to n2 do write(A2[i],' '); writeln;

writeln;

writeln('Proizvedenie iz A1= ',pr_nec(A1,n1));

writeln('Proizvedenie iz A2= ',pr_nec(A2,n2));

readln;

end.

4.Описание: Нахождение тангенса tg и котангенса ctg угла, используя выражения sin(x)cos(x) и обратное ему.

Program one;

uses crt;

var y1,y2,z: real; function tg (x : real) : real;

begin tg := sin(x)/cos(x);

end;

function ctg (x : real) : real;

begin ctg := cos(x)/sin(x);

end;

Begin clrscr;

write ('input x: ');

readln (z);

y1:=tg(z); y2:=ctg(z);

writeln ('tg (',z:0:2,')=',y1:0:2);

writeln ('ctg (',z:0:2,')=',y2:0:2);readln;

End.

5. Описание: Определить максимальное число из четырех введенных, путем сравнения их сначала попарно, а затем результат между собой.

program one;

uses crt;

var a,b,c,d,z,x,y,x1,y1:integer; function max(x,y:integer):integer;

begin if x>y then max:=x else max:=y;

end;

begin clrscr;

writeln('Vvedite chisla');

readln(a,b,c,d);

x1:=max(a,b); y1:=max(c,d); z:=max(x1,y1);

writeln('max=',z);

readkey;

end.

6.Описание: Вычислить день недели по дате

program Kalendar;

uses crt; var y,d,m,c,w: integer; {m-mesiac,d-den, y-god }Procedure WriteDay(d,m,y:Integer);

constDays_of_week: rray [0..6] of String [11] =('Voskresen`e','Ponedelnik','Vtornik', ' Sreda', ' Chetverg', ' Piatnica', ' Subbota') ;

Begin if m <3 then begin m := m + 10;

y := y - 1;end else m := m - 2;c := y div 100;y := y mod 100;w := (d+(13*m-1) div 5+y+y div 4+c div 4-2*c+777) mod 7;

WriteLn(Days_of_week[w] );end;

Procedure InputDate(var d,m,y : Integer);

Begin Write('Vvedite datu v formate DD MM GG ');

ReadLn(d,m,y);

if (d>=1)and (d<=31) and (m>=1) and (m<=12) and (y>=1582) and (y<=4903) then Writeday(d,m,y) else begin writeln ('Nekorrektnyj vvod!');end;end;

BEGIN clrscr;

InputDate(d,m,y);

readkey;

End.

7. Описание: Нахождение процента от числа

Program one;

uses crt;

var k,n:byte; x:real; function procent(n,m:byte):real;

begin procent:=m*100/n;

end;

begin clrscr;

writeln('Vvedite chisla');

readln(k,n);

x:=procent(k,n);

writeln('x=',x:5:2);

readkey;

end.

8. Вывести заданное число звездочек.

program one;;

uses crt;

var n:byte; function zvezda(n:byte):real; var i:integer; s:string;

begin i:=1;

s:='';

while i<=n do begin s:=s+'*';

inc(i); end;

writeln(s); end;

begin clrscr;

writeln('Vvedite chislo'); readln(n);

zvezda(n); readkey;

end.

9. Описание: Функция возведения числа в степень. С учетом дробных чисел и частных случаев, когда числа отрицательные или равны нулю

program one;

Uses crt;

var x,y,z:real; Function Pow(A,B:Real):Real; Var T,R:Real; L:integer;

Begin T := Abs(A);

If A < 0 Then R := (-1)*Exp(B*Ln(T)) else if A > 0 Then R := Exp(B*Ln(T)) else R:=0;

L := round(B);

If (L mod 2 = 0) Then R:=Abs(R);

If (B=0) Then R:=1;

Pow:=R;

End;

BEGIN clrscr;

Writeln('vvedite chislo:');

readln(x);

Writeln('vvedite stepen:');

readln(y);

z:=Pow(x,y);

Writeln(z:0:2);

readkey;

END.

10. Описание: Вывести заданный символ заданное количество раз

program one;

uses crt;

var n:byte; l:string; function zvezda(n:byte;l:string):real; var i:integer; s:string;

begin i:=1;

s:='';

while i<=n do begin s:=s+l;

inc(i); end;

writeln(s); end;

begin clrscr;

writeln('Vvedite chislo'); readln(n);

writeln('Vvedite simvol'); readln(l);

zvezda(n,l);

readkey;

end.

11.Описание: Определить к чему ближе меньшее из двух чисел: к их среднему арифметическому или среднему геометрическому.

Program one;

vara,b : real; average : real; geometricmean : real; minstr : string;function min(a,b : real) :real;

begin min := a;

minstr := 'Pervoe';

if (b < a) then begin min := b;

minstr := 'Vtoroe';end;end;

beginwrite('Vvedite 1-e chslo: ');readln(a);

write('Vvedite 2-e chslo: ');readln(b);

average := (a + b) / 2;

geometricmean := sqrt(a*a + b*b);

a := min(a,b);

writeln('Naimenshee chislo - ',minstr,' (',a:0:3,')');

write('Blize k srednemu ');

if (abs(average - a) < abs(geometricmean - a)) thenbegin writeln('arifmeticheskomu (',average:0:3,')');

end else begin writeln('geometricheskomu (',geometricmean:0:3,')');end;

readln;

end.

12.Описание:Возведение в степень для целого показателя, вычисляемого за время log2(степень).

Program power_maximal;

Uses crt;

Var a,b,c: integer; function power (x,pow:integer):integer; var res: integer;

begin res := 1;

while (pow > 0) do beginif (pow and 1 = 1) then res:= res * x;

x := x * x;

pow := pow shr 1;end;

power := res; end;

Begin Clrscr;

Writeln ('input a,b: ');

Readln (a,b);

c:=power(a,b);

Writeln('a^b = ',c);

Readkey;

End.ъ

13.Описание:Арккосинус числа. Нахождение из математических соображений

var ca,al,albeg: real; function ArcCos(arg:real):real;

var r:real;

begin if (abs(arg)>1) then begin writeln(' Unavailable argument ');

halt; end;

if abs(arg)<0.000001 then r := pi/2 else r := ArcTan(sqrt(1/arg/arg-1)); { arccos }

if arg<0 then r:=pi-r;

ArcCos := r; end;

begin albeg:=pi/2+0.2;

ca := cos(albeg);

al := arccos(ca);

writeln('ArcCos(',ca:10:7,')=',al:10:7,' AlBeg=',albeg:10:7,

' ChekSum =',al-albeg,' Must be sero');

readln;

end.

14.Описание:Есть ли в строке числовые значения

Function NumInStr(S: String): Boolean;

VAR C, I: INTEGER; N: BOOLEAN;

BEGIN; I:=0;

Repeat;

I:=I+1;

C:=Ord(S[I]);

N:=( (C >= 48) AND (C <= 57) );

Until (NOT N) OR (I=Length(S));

NumInStr:=N;

END;

15.Описание:Нахождение функции методом половинного деления

program half_del;

uses crt;

type ms=array[1..100] of real; { [x,y] }

var Eps,XH,DX,Y,z,X,YH,P,S,A,B:real; N,U,Er:integer; masx,masy:ms;Function F(X:real):real;

beginF:=exp(x)+x*x-2

end;

Function FuncA(Eps,s,p,YH:real):real;

begin if F(p)*F(s)<0 then begin YH:=0.5*(p+s);

while abs(F(YH)) > EPS do begin If F(p)*F(YH) <0 then S:=YH else P:=YH;

YH:=0.5*(P+S) end; end else er:=1;

FuncA:=YH; end;

procedure P1(a,b,XH:real; N:integer); var z,q:real; u:integer;

begin if x>1 then begin Z:=sqrt(X*sqrt(X-1));

a:=FuncA(Eps,s,p,YH);

for U:=1 to N do begin masx[U]:=X;

masy[U]:=sin(x)/z;

X:=X+DX; end;

{else writeln(' Error: x<1 ');} end; end;

Begin clrscr;

write ('vvedite eps: '); readln(eps);

Write ('vvedite dx: '); readln(DX);

write ('vvedite N: '); readln(N);

write ('vvedite x>1 :'); readln(x);

if x1; writeln;

Writeln ('--------------------');

Writeln (' | X | Y ');

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

P1(a,b,XH,N);

for U:=1 to N do writeln('',masx[u]:10:7,' ',masy[u]:10:7);readln;

end.

Раздел: Файлы

1.Описание: Решает простейшие арифметические примеры записанные в файл.

program pn12;

var f:text; s,sa,sb:string; c:char; i,a,b,o,j,code:integer; m,op:set of char;

begin m:=['1','2','3','4','5','6','7','8','9','0'];

op:=['+','-','*','/'];

assign(f,'file.txt');reset(f);

while not(eof(f)) do begin readln(f,s);

writeln(s);

for i:=2 to length(s)-1 do if (s[i] in op)and (s[i-1]in m) and (s[i+1]in m) then begin j:=1;

sa:='';

while (s[i-j] in m) and (i-j>0) do begin sa:=s[i-j]+sa;

j:=j+1 end;

j:=1;

sb:='';

while (s[i+j] in m) and (i+j<=length(s)) do begin sb:=sb+s[i+j];

j:=j+1 end;

val(sa,a,code);val(sb,b,code);

case s[i] of '+':O:=a+b;

'-':O:=a-b;

'*':O:=a*b;

'/':O:=a div b; end;

writeln(a,s[i],b,'=',O,' ')

end;end; close(f);

readln;

end.

2.Описание: Работа с текстовыми файлами предусматривает собой: создание, редактирование, добавление, удаление.

Program one;

uses Dos,Crt;

var f :text;

FileName :string[9];

st :string; ch :char; vibor :byte;

procedure Head;

begin Writeln('esli vy otkazyvaetes ot deistviya,to naberite v nazvanii faila simvola""');

Write('vvedite imya faila:>');

Readln(FileName);

if FileName='~' then halt(1) else Assign(f,FileName); end;

procedure TextEdit;

begin Writeln('Seichas vy smojetedobavlyat informaciyu v file.');

Writeln('esli vyzahotite prekratit vvod, to naberite sleduschuyu posledovatelnost:"~~"');

repeat Write('>');Readln(st);

if st<>'~~' then Writeln(f,st);

until st='~~'; end;

procedure WriteToFile;

begin Head;

ReWrite(f);

TextEdit;

Close(f);

Writeln('Vy okonchili vvodit info v file.Najmite lubuyu knopku...');

ReadKey; end;

procedure ReadFromFile;

Head;

Reset(f);

if IOresult<>0 then begin Writeln('file ',FExpand(filename),' ne sushestvuet.');

Writeln((Y/N).');

ch:=ReadKey;

if (ch='Y') or (ch='y') then ReadFromFile;

end else begin Writeln('Soderjimoe faila:');Writeln;

while not eof(f) do begin Readln(f,st);

Writeln('>',st); end;

Close(f);

Writeln;

Writeln('Najmite lubuyu knopku');

ReadKey; end;end;

procedure AddToFile;

begin Head;

Append(f);

if IOresult<>0 then begin

Writeln('faila ',FExpand(filename),' ne sushestvuet.');

Writeln('hotite vvesti drugoe imya faila?(Y/N).');

ch:=ReadKey;

if (ch='Y') or (ch='y') then AddToFile; end else begin TextEdit; Close(f);

Writeln('Vy okon4ili vvodit info v file.Najmite lubuyu knopku...');

ReadKey; end; end;

procedure DelFile;

begin Head;

Reset(f);

if IOresult<>0 then begin Writeln('file ',FExpand(filename),' ne sushestvuet.');

Writeln('hotite vvesti drugoe imya file??(Y/N).');

ch:=ReadKey; if (ch='Y') or (ch='y') then DelFile; end else begin Writeln('vy uvereny 4to hotite udalit etot file?(Y/N)');

ch:=ReadKey; if (ch='Y') or (ch='y') then Erase(f);

Writeln('vy tolko 4to udalili file.Najmite lubuyu klavishu..');

Readkey; end; end;

procedure Menu;

begin repeat repeat ClrScr;

Writeln('1. record file / sozdanie faila');

Writeln('2. read file');

Writeln('3. Dobavlenie info v file');

Writeln('4. delet file');

Writeln('5. Exit');

Write('Vash vybor:>');Readln(vibor);

until (vibor>0) and (vibor<6);

Writeln;

Write('‚л ўлЎа «Ё : ');

case vibor of 1:begin Writeln(' record file / sozdanie faila');

WriteToFile; end;

2:begin Writeln('read file');

ReadFromFile; end;

3:begin Writeln(' Dobavlenie info v file');

AddToFile; end;

4:begin Writeln('delet file');

DelFile; end; end;

until vibor=5; end;

begin Menu;

end.

3.Описание: Дан файл, содержащий текст и арифметические выражения вида, а*в, где * - один из знаков +, -, *, /.Выписать все арифметические выражения и вычислить их значения

program pn12;

var f:text; s,sa,sb:string; c:char; i,a,b,o,j,code:integer; m,op:set of char;

begin m:=['1','2','3','4','5','6','7','8','9','0'];

op:=['+','-','*','/'];

assign(f,'e:\tp\tp6\Arif.dat');reset(f);

while not(eof(f)) do begin readln(f,s);

writeln(s);

for i:=2 to length(s)-1 do if (s[i] in op)and (s[i-1]in m) and (s[i+1]in m) then begin j:=1;

sa:='';

while (s[i-j] in m) and (i-j>0) do begin sa:=s[i-j]+sa;

j:=j+1 end;

j:=1; sb:='';

while (s[i+j] in m) and (i+j<=length(s)) do begin sb:=sb+s[i+j];

j:=j+1 end;

val(sa,a,code);val(sb,b,code);

case s[i] of '+':O:=a+b;

'-':O:=a-b; '*':O:=a*b; '/':O:=a div b; end;

writeln(a,s[i],b,'=',O,' ')

end; end;

close(f);

end.

4.Описание: Вывести максимальное число из файла in.txt

Program one;

var t:text; i,p,code:integer; s:string; m:array[1..100] of real; max:real;

begin assign(t,'in.txt'); reset(t);

read(t,s);

i:=0;

repeat p:=pos(' ',s);

inc(i);

val(copy(s,1,p-1),m[i],code);

delete(s,1,p);

until p=0;

max:=m[1];

for p:=2 to i do if m[p]>max then max:=m[p];

writeln('MAX= ',max);

close(t);

readln;

end.

5.Описание: Перекодирование файла из формата DOS в формат Windows.

Program one;

var f,g:text; i,p,n:integer; m:array [1..100] of string; s:string;

begin assign(f,'in.txt'); reset(f);

assign(g,'out.txt'); rewrite(g);

while not eof(f) do begin readln(f,s); {считываем очередную строку}

i:=0; {ставим счётчик слов на 0}

repeat inc(i); {увеличиваем счётчик текущего ПРЕДЛОЖЕНИЯ}

p:=pos(' ',s); {смотрим где находится пробел}

m[i]:=copy(s,1,p-1); {записываем текущее слово в массив}

delete(s,1,p); {то слово, которое заприсали в массив - удаляем}

until p=0; {****************}

n:=i+1; {конец массива}

if s[length(s)]='.' then begin m[n]:=copy(s,1,length(s)-1); m[1]:=m[1]+'.' {то эту точку перемещаем на 1 слово}

end else m[n]:=s; {а если нет точки - то просто его записываем в массив}

writeln(g);;

for i:=n downto 1 do write(g,m[i],' '); {идём с конца массива в начало и записываем слова в обратном порядке}end;

writeln('PEREZAPISANO...');readln;

close(f); close(g);

end.

6.Описание: Удаление следующих друг за другом нескольких пробелов из файла.

Program one;

const

FileName: String = 'Strings.txt';

VAR f: Text; S: String;

BEGIN Assign(f, FileName); {$I-}Reset(f); {$I+}

if IOResult = 0 then begin ReadLn(f, S); Close(f) end;

WriteLn('input string: ',S);

while (POS(' ', S) > 0) do delete(S, POS(' ',S), 1);

if ( length(S) > 1) and (S[1] = ' ') then Delete(S, 1, 1);

if (length(S)>1) and (S[length(S)] = ' ') then Delete(S, length(S), 1);

writeln('output string: ',s);

readln;

END.

7.Описание: Вывести содержимое файла в обратном порядке в новый файл.

program one;

uses crt;

var fl1,fl2:text;a,b:string; i,l:longint;

begin clrscr;

assign(fl1,'input.txt');

assign(fl2,'output.txt'); reset(fl1); readln(fl1,a);

close(fl1);

l:=length(a);

for i:=l downto 1 do b:=b+a[i];

rewrite(fl2); write(fl2,b);

close(fl2);

write(b); readln;

end.

8.Описание: Бинарный поиск элемента в типизрованном longint файле.

program searches;

uses crt,dos;

type longint_file=file of longint;

procedure files_names_query(var read_file,error:string; var search_value:longint);

var f:text;

begin error:='';

write('`считываемый файл: ');

readln(read_file);

assign(f,read_file);

reset(f);

if (ioresult=0) then begin close(f);

write('находимое значение=');

readln(search_value);

end else begin error:='ошибка:файл не существует'; end; end;

function bin_search(left,right,search_value:longint;var f:longint_file):boolean;

var center,value,new_left,new_right,right_value,center_value:longint;

begin if (left=right) then begin seek(f,left);

read(f,value);

if (value=search_value) then begin bin_search:=TRUE;

end else begin bin_search:=FALSE; end;

end else begin center:=((left+right) div 2)+1;

seek(f,right);

read(f,right_value);

seek(f,center);

read(f,center_value);

if ((search_value>=center_value)and(search_value<=right_value)) then begin new_left:=center;

bin_search:=bin_search(new_left,right,search_value,f);

end else begin new_right:=center-1;

bin_search:=bin_search(left,new_right,search_value,f); end; end; end;

function search(read_file:string; search_value:longint):boolean;

var f:longint_file;

finded:boolean;

elements_count:longint;

begin assign(f,read_file);

reset(f);

finded:=FALSE;

elements_count:=filesize(f);

finded:=bin_search(0,elements_count-1,search_value,f);

close(f);

search:=finded; end;

procedure writing_to_file(write_file:string;finded:boolean;begin_time:longint);

var f:text; hour,minutes,seconds,seconds100:word; end_time:longint; time:real;

begin gettime(hour,minutes,seconds,seconds100);

end_time:=minutes*60*100+seconds*100+seconds100;

time:=(end_time-begin_time)/100;

assign(f,write_file);

rewrite(f);

if (finded) then writeln(f,'ok') else writeln(f,'error');

writeln(f,time:4:2);

close(f); end;

procedure writing(finded:boolean; begin_time:longint);

begin if (finded) then begin writeln('Element finded complete');

end else begin writeln('Element not finded'); end;

readln; end;

var read_file,write_file,error,search_value_string:string; hour,minutes,seconds,seconds100:word;

begin_time,search_value:longint; k:integer; result:boolean;

begin gettime(hour,minutes,seconds,seconds100);

begin_time:=minutes*60*100+seconds*100+seconds100;

if (paramstr(1)<>'') then begin read_file:=paramstr(1);

search_value_string:=paramstr(2);

val(search_value_string,search_value,k);

write_file:=paramstr(3);

result:=search(read_file,search_value);

writing_to_file(write_file,result,begin_time);

end else begin files_names_query(read_file,error,search_value if (error='')

then begin result:=search(read_file,search_value);

writing(result,begin_time);

end else begin writeln(error);

writeln('нажмите Enter для продолжения.');

readln; end; end;

end.

9.Описание: Вывести таблично результаты расчета функции y=sin(x)/x на указанном диапазоне в файл.

Program one;

Const M=24;

Var FName: Text; AB,H,X: Real;

Function F(X:Real):Real;

Begin F:=Abs(Sin(X)/X);

End;

Begin Write ('vvedite na4alo diapazona: ');

ReadLn (A);

Write ('vvedite konec diapazona: ');

ReadLn (B);

WriteLn('sozdayu LA-BA.TAB');

H:=(B-A)/M;

X:=A;

Assign(FName,'LA-BA.TAB');

ReWrite(FName);

WriteLn (FName,'X | F(X)');

While (X<=B) Do Begin WriteLn (FName,X,' | ',F(X));

X:=X+H;

End;

Close (FName);

End.

10.Описание: Дан файл, содержащий текст. Сколько слов в тексте? Сколько цифр в тексте?

program one;

Const mn=['0'..'9'];

Var f3:text; i,j,ch,sl:integer; name:string; s:char; wrd :string;

Begin writeln('vvedite imya faila');

readln(name);

assign(f3,name);

reset(f3);

s:=' '; sl:=0; ch:=0;

while not eof(f3) do begin readln(f3,wrd);

i:=1;

While i<=length(wrd) do begin if wrd[i]<>' ' then sl:=sl+1;

while (wrd[i]<>' ') and (i<=length(wrd)) do inc(i);

inc(i) end; end;

close(f3);

reset(f3);

while not eof(f3) do begin while not eoln(f3) do begin read(f3,s);

if (s in mn) then ch:=ch+1;

end; readln(f3); end;

writeln('4islo slov: ',sl,' 4islo cifr: ',ch);

close(f3);

End.

11.Описание: Заменить синонимами слова в файле

program ;

var f1,f2,f3:text; i,n,k,l:integer; s,sout,ss,slovoT,slovo,sinonim:string;

begin assign(f1,'text1.txt');

assign(f2,'text2.txt'); assign(f3,'text3.txt');

rewrite(f1);

writeln('‚ўҐ¤ЁвҐ ⥪бв:');

repeat readln(s);

writeln(f1,s)

until s='';

close(f1); reset(f1);

rewrite(f3);

while not(eof(f1)) do begin readln(f1,s);

s:=s+' ';

sout:='';

while length(s)>0 do begin l:=pos(' ',s);

slovoT:=copy(s,1,l-1);

delete(s,1,l);

reset(f2);

while not(eof(f2)) do begin readln(f2,ss);

k:=pos(',',ss);sinonim:=copy(ss,1,k-1);

if sinonim=slovoT then slovoT:=copy(ss,k+1,length(ss)-k) end;

close(f2);

sout:=sout+slovot+' ' end;

writeln(s);

writeln(f3,sout) end;

close(f3); reset(f3);

while not(eof(f3)) do begin readln(f3,s);

writeln(s) end;

close(f3); readln

end.

12.Описание: Очистить файл, оставив лишь первую строку.

program one;

uses crt;

var fl1:text;a:string;i,l,poz:longint;label m;

begin clrscr;

assign(fl1,'input.txt');

reset(fl1); readln(fl1,a); close(fl1);

l:=length(a);

rewrite(fl1);

for i:=1 to l do if a[i]='.'then begin poz:=i;goto m; end;

m:for i:=1 to poz do write(fl1,a[i]); close(fl1);

writeln('complete!!!');

readkey;

end.

13.Описание: Вывод статистики по файлу

program one; uses crt; var infile:text;file_name,s:string;i, commas, points, blanks,lines:integer; begin clrscr; commas:=0;points:=0;blanks:=0;lines:=0; write('vvedite imya faila'); readln(file_name); assign(infile,file_name);reset(infile); while not eof(infile) do begin readln(infile,s); for i:=1 to length(s) do begin case s[i] of ',' :inc(commas); '.' :inc(points); ' ' :inc(blanks); end; end; inc(lines); end; close(infile); gotoxy(1,3); writeln('zapyatih: ',commas); writeln('predlogenii: ',points); writeln(' probelov: ',blanks); writeln(' strok: ',lines); readln; end.

14 Задан файл F, компонентами которого являются целые числа. Переписать в файл G вначале все отрицательные, затем все нулевые, а затем все положительные числа, упорядочив их по возрастанию модуля величины. Файл G - текстовый. Program Pascal; Const fname='num.txt'; fname2='num2.txt'; Var f,g:text; stroka:string; k,code,i,j,tmp:integer; a:array[1..20] of integer; begin Assign(F, fName); ReSet(F); k:=0; While Not Eof(F) Do Begin ReadLn(F, Stroka); k:=k+1; val(Stroka,tmp,code); a[k]:=tmp; writeln(a[k]); End; close(f); writeln; writeln(k); writeln; for i:=2 to k do for j:= k downto 2 do if a[j-1] > a[j] then begin tmp := a[j-1]; a[j-1] := a[j]; a[j] := tmp; end; for i:=1 to k do write(a[i],' '); Assign(g, fName2); rewrite(g); for i:=1 to k do begin writeln(g,a[i]); end; close(g); writeln; readln; end.

15 Задан тектовый файл, содержащий текст. Определить сколько раз встречается в нем самое длинное слово.

program tp7; const razd=[' ','.',',','?','!',':',')','(']; var f:text; s,slo,slovo,name:string; k,i:integer; begin write('Введите имя файла:'); readln(Name); assign(f,name); reset(f); slovo:='';k:=0; while not(EOF(F)) do begin readln(f,s);slo:=''; for i:=1 to length(s) do begin if s[i] in razd then begin if (i>1)and not(s[i-1]in razd) then begin if (length(slo)=length(slovo))and (slo=slovo) then k:=k+1; if length(slo)>length(slovo) then begin slovo:=slo; k:=1 end; end; slo:='' end else begin slo:=slo+s[i] end; end; if (length(slo)=length(slovo))and (slo=slovo) then k:=k+1; if length(slo)>length(slovo) then slovo:=slo; end; writeln('слово ',slovo,' встречается ',k,' раз'); close(f); readln end.

Раздел: Записи

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

program one;

const n=2;

type group=record

ser:string[30]; p:string[1]; h:100..250;

end;

var person:array[1..n] of group; f:text; r:boolean; ar:array[1..n] of integer; i,j,z,obr:integer;

begin assign(f,'AAAAAAA.txt');

rewrite(f);

for i:=1 to n do with person[i] do begin writeln('person ',i);

writeln(f,'person ',i);

writeln('sername');

readln(ser);

writeln(f,'sername: ',ser,' ');

writeln('pol');

readln(p);

writeln(f,'pol: ',p,' ');

writeln('rost');

readln(h);

writeln(f,'rost: ',h,' ');

writeln(f);

writeln; end;

close(f);

reset(f);

append(f);

writeln(f,'poisk dvuh men s odinakovim rostom');

j:=1; for i:=1 to n do begin with person[i] do begin if (p='m') or (p='M') then begin ar[j]:=h;

j:=j+1; z:=j-1; end; end; end;

r:=false;

for j:=1 to z do begin obr:=ar[j]; i:=j;

repeat if ar[i+1]=obr then r:=true else i:=i+1;

until (i>z) or (r); end;

if r=true then writeln(f,'sovpadenie naydeno');

if r=false then writeln(f,'sovpadenie ne naydeno');

close(f);

readln;

end.

2.Описание: Телефонный справочник

program one; type Zapis=record fam:string; tel:string;

 end; var out: file of Zapis; nam:Zapis; kon:char; begin assign(out,'nomera'); rewrite(out); repeat write('fam?'); readln(nam.fam); write('nomer?'); readln(nam.tel); write(out,nam); writeln('prodolgim? y/N'); readln(kon); until kon <>'y'; reset(out); while not eof(out) do begin read(out,nam); writeln(nam.fam,'-',nam.tel); end; close(out); end.

3.Описание: Программа, которая создает файл с описанием студентов:

program one;

type TStudentInfo=record name:string[30]; kurs:string[20]; ekz:array[1..5] of byte; end; var f:file of TStudentInfo; st:TStudentInfo; p:byte; begin assign(f,'students.dat'); reset(f); {Откроем файл. Позиция на данный момент в самом начале} if ioresult<>0 then rewrite(f); {Если ошибка, занчит файла нет, и значит откоем его подругому} seek(f,filesize(f));

with st do repeat write('Введите имя студента (пустую строку для выхода): '); readln(name); if name='' then break; write('Введите курс:'); readln(kurs); for p:=low(ekz) to high(ekz) do begin write('Введите оценку по экзамену №',p,': '); readln(ekz[p]); end; write(f,st); {Вот эта строка и записывает информацию о студенте в файл} until false; close(f); {Эту команду мы ещё не рассматривали, но об этом я расскажу в конце} end.

4.Описание: Производится ввод даты последовательно: число, месяц, год. Программа проверяет наличие ошибок при вводе.

program lab4;

uses crt;

type day=1..31; mon=1..12; year=1..3000;

var data:record

d:day; m:mon; y:year; end; s:boolean;

function vernaydat:boolean;

begin with data do begin write('chslo: ');

readln(d);

write('mesyc: ');

readln(m);

write('god: ');

readln(y);

s:=true;

if y>3000 then s:=false;

if m>12 then s:=false;

case m of 1,3,5,7,8,10,12:begin if d>31 then s:=false; end;

4,6,9,11:begin if d>30 then s:=false; end;

2:begin if (y mod 4)<>0 then if d>28 then s:=false;

if (y mod 4)=0 then if d>29 then s:=false;

end; end;

if s=true then write('OK');

if s=false then write('ERROR');end;end;

begin clrscr;

writeln('Vvedite datu');

Vernaydat; readln;

end.

5.Описание: Формирование базы данных информации о студентах. Вывод из таблицы список студентов:-получивших оценку 4;-получивших оценки 4 и 5;-фамилия которых начинается на 'А'.

Program Laba6;

Uses Crt;

Type Exam = Record

Name: String[20]; Year: Integer; Lesson: String[10]; Prise: Integer;

End;

Mass = Array [1..30] Of Exam;

Var Student: Mass; Prise1, Prise2, Num, I: Integer; Letter: Char;

Procedure InputStudent (Var InpNum: Integer);

Var I:Integer;

Begin ClrScr;

Write ('4islo studentov: ');

ReadLn (InpNum);

For I:=1 To InpNum Do Begin Write ('vvvedite familiyu stud nomer ',I,' [20] : '); ReadLn (Student[I].Name);

Write ('god rojden stud nomer',I,': '); ReadLn (Student[I].Year);

Write ('predmet studenta nomer ',I,' [10] : '); ReadLn (Student[I].Lesson);

Write ('ocenka stud nomer ',I,': '); ReadLn (Student[I].Prise);

WriteLn; End;End;

Procedure OutLine (Line: Integer);

Begin Write (Student[Line].Name:20);

Write (Student[Line].Year:6);

Write (Student[Line].Lesson:10);

Write (Student[Line].Prise:7);

WriteLn;End;

Procedure OutStudent (OutNum: Integer); Var I: Integer;

Begin ClrScr;

WriteLn ('familiya':20,'god':6,'predmet':10,'ocenka':7);

For I:=1 To OutNum Do OutLine (I);End;

Procedure OutStudentPrise1 (OutNum, OutPrise: Integer);Var Col, I: Integer;

Begin WriteLn;

Col:=0;

WriteLn ('dannye o stud-h polu4ivshih ocenki: ',OutPrise);

For I:=1 To OutNum Do If (Student[I].Prise=OutPrise) Then Begin Col:=Col+1;

OutLine (I); End;

WriteLn ('4islo stud polu4ivshih ocenku ',OutPrise,': ',Col);End;

Procedure OutStudentPrise2 (OutNum, OutPrise1, OutPrise2: Integer);

Var I: Integer;

Begin WriteLn;

WriteLn ('dannye o stud polu4ivshih ocenku : ',OutPrise1,' Ё ',OutPrise2);

For I:=1To OutNum Do If ((Student[I].Prise=OutPrise1)Or (Student[I].Prise=OutPrise2))Then OutLine (I);

End;

Procedure OutStudentName (OutNum:Integer; OutLetter:Char);Var I: Integer;

Begin WriteLn;

WriteLn ('dannye o studentah 4i familii na4inayutsa na "',OutLetter,'"');

For I:=1 To OutNum Do If (Copy(Student[I].Name,1,1)=OutLetter)Then OutLine (I);End;

Begin InputStudent (Num);

OutStudent (Num); Prise1:=4;

OutStudentPrise1 (Num, Prise1); Prise2:=5;

OutStudentPrise2 (Num, Prise1, Prise2); Letter:='Ђ';

OutStudentName (Num, Letter);

ReadLn;

End.

6.Описание: Дана таблица материалов с следующей информацией по каждому материалу: название, удельный вес, вид проводимости (диэлектрик, полупроводник, проводник). Выписать из таблицы все полупроводники и их удельный вес.

program one;

Uses CRT;

Const Veshestvo = 1;

Type Material = Record

Name: String[20]; Weight: Real; Provod: Integer;

End;

Var Result,I,J,N: Integer; F : Array[1..20] Of Material; Begin

F[1].name := 'med'; F[1].Weight := 4.00; F[1].Provod := 2;

F[2].name := 'bumaga'; F[2].Weight := 66.0; F[2].Provod := 0;

F[3].name := 'ЉаҐ¬­Ё©'; F[3].Weight := 5.40; F[3].Provod := 1;

F[4].name := 'germany'; F[4].Weight := 21.5; F[4].Provod := 1;

F[5].name := 'arsenid gallia'; F[5].Weight := 3.00; F[5].Provod := 1;

F[6].name := 'alluminiy'; F[6].Weight := 50.0; F[6].Provod := 2;

F[7].name := 'keramika'; F[7].Weight := 9.90; F[7].Provod := 0;

F[8].name := 'rezina'; F[8].Weight := 80.0; F[8].Provod := 0;

F[9].name := 'ftoroplast'; F[9].Weight := 4.00; F[9].Provod := 0;

ClrScr;

N := 9;

Result := 0;

Writeln('naimenovanie materiala udelny ves provodimost');

Writeln('-----------------------------------------------------------');

For I := 1 to N Do If (F[I].Provod = Veshestvo) Then Begin

Write(F[I].Name:22,F[I].Weight:15:2);

Case F[I].Provod Of

0: WriteLn('izolyator':15);

1: WriteLn('poluprovodnik':15);

2: WriteLn('provodnik':15); End;

Result := Result + 1; End;

Writeln('-----------------------------------------------------------');

Writeln('naideno ',Result,' material.');

If Result = 0 Then WriteLn('takogo materiala net'); Readln;

End.

7.Описание: Вывести из введеной строки слова с максимальным количеством вхождений буквл 'l' и 'o' и подсчитать количество этих вхождений.

Type Info = record

wrd,num : Byte; ch : Char;

End;

Var S, Temp:String; P,I : Byte; M, N : Info;

Function CalkChar(A:String;C:Char):Byte; Var I, Result : Byte;

Begin Result := 0;

For I := 1 To Length(A) Do If UpCase(A[I]) = UpCase(C) Then Inc(Result);

CalkChar := Result;

End;

Begin WriteLn('vvedite frazu po-angl:');

ReadLn(S);

I := 1;

M.num := 0; M.wrd := 0; M.ch := 'l';

N.num := 0; N.wrd := 0; N.ch := 'o';

While Pos(' ',S) <> 0 Do Begin P := Pos(' ',S);

Temp := Copy(S,1,P);

If M.wrd < CalkChar(Temp,M.ch) Then Begin M.num := I;

M.wrd := CalkChar(Temp,M.ch); End;

If N.wrd < CalkChar(Temp,N.ch) Then Begin N.num := I;

N.wrd := CalkChar(Temp,N.ch); End;

Delete(S,1,P); Inc(I); End;

If M.wrd < CalkChar(S,M.ch) Then Begin M.num := I;

M.wrd := CalkChar(S,M.ch); End;

If N.wrd < CalkChar(S,N.ch) Then Begin N.num := I;

N.wrd := CalkChar(S,N.ch); End;

WriteLn('-------------');

If M.wrd <> 0 Then WriteLn('bukva ',M.ch,'4asche vstre4aetsa v ',M.num,'-¬ slove, celyh ',M.wrd,' raz( )');

If N.wrd <> 0 Then WriteLn('bukva ',N.ch,' 4asche vstre4aetsa v ',N.num,'-m slove, celyh ',N.wrd,' raz( )');readln;

End.

8.Описание: Из исходной таблицы игрушек с полями: название игрушки, стоимость, возрастные ограничения, выписать сведения для игрушек стоимостью менее 4 рублей, подходящие детям 5 лет.

Uses CRT;

Const Vozrast = 5;

Cena = 400;

Type Toy = Record

Name: String[20]; Sale: Integer; Min: Integer; Max: Integer;

End;

Var Sum,Result,I,J,N: Integer; F : Array[1..20] Of Toy;

Begin

F[1].name := 'mya4'; F[1].Sale := 400; F[1].min := 1; F[1].max := 9;

F[2].name := 'kukla'; F[2].Sale := 660; F[2].min := 3; F[2].max := 7;

F[3].name := 'samolet'; F[3].Sale := 540; F[3].min := 3; F[3].max := 5;

F[4].name := 'pupsik'; F[4].Sale := 210; F[4].min := 1; F[4].max := 3;

F[5].name := 'knijka'; F[5].Sale := 300; F[5].min := 1; F[5].max := 5;

F[6].name := 'mashinka'; F[6].Sale := 500; F[6].min := 3; F[6].max := 8;

F[7].name := 'parovoz'; F[7].Sale := 990; F[7].min := 4; F[7].max := 7;

F[8].name := 'ula'; F[8].Sale := 800; F[8].min := 2; F[8].max := 5;

F[9].name := 'konstruktor'; F[9].Sale := 400; F[9].min := 6; F[9].max := 9;

ClrScr;

N := 9;

Result := 0;

Sum := 0;

Writeln('igryshka cena, kop. Min vozrast Max vozrast');

Writeln('-----------------------------------------------------------');

For I := 1 to N Do If (F[I].min <= Vozrast) And (Vozrast <= F[I].max) And (F[I].Sale <= Cena) Then Begin

WriteLn(F[I].Name:20,F[I].Sale:12,F[I].Min:14,F[I].Max:13);

Result := Result + 1; Sum := Sum +F[I].Sale; End;

Writeln('-----------------------------------------------------------');

Writeln('stoimost pokupki: ',Sum/100:3:2,' rub.');

If Result = 0 Then WriteLn('pokupku sovershit nevozmojno!');

Readln;

End.

9.Описание: Из первой таблицы, где заданы коэффициенты для уравнений задания линий выписать в новую таблицу только те коэффициенты, которые формируют линию, параллельную первой в исходной таблице.

Uses CRT;

Type Line = Record

A,B,C: Integer;

End;

Var Result,I,J,N: Integer; F,G : Array[1..20] Of Line;

Begin

F[1].A := 1; F[1].B := 9; F[1].C := 2;

F[2].A := 2; F[2].B := 6; F[2].C := 3;

F[3].A := 3; F[3].B := 5; F[3].C := 1;

F[4].A := 4; F[4].B := 2; F[4].C := 4;

F[5].A := 3; F[5].B := 3; F[5].C := 1;

F[6].A := 2; F[6].B := 5; F[6].C := 2;

F[7].A := 1; F[7].B := 9; F[7].C := 5;

F[8].A := 2; F[8].B := 6; F[8].C := 1;

F[9].A := 3; F[9].B := 5; F[9].C := 2;

ClrScr;

N := 9; Result := 0; I := 1;

For J := 2 to N Do If (F[I].A = F[J].A) And (F[I].B = F[J].B) Then Begin Write('liniya ',I,' paralelna linii ',J,' ');

WriteLn(F[I].A,'X + ',F[I].B,'Y + ',F[I].C);

Result := Result + 1; End;

Writeln('naideno ',Result,' liniy');

If Result = 0 Then WriteLn('takih liniy net');

Readln;

End.

10.Описание: Имеется запись о багаже пассажира (кол-во вещей и общий вес вещей). Выяснить, имеется ли пассажир, багаж которого превышает багаж каждого из остальных пассажиров и по числу вещей и по весу. Дать сведения о багаже, число вещей в котором не меньше, чем в любом другом багаже, а вес вещей не больше, чем в любом другом багаже.

uses crt; type bagaj = record ves:double;kol_veshei: integer; end; var bagage:array[1..20] of bagaj; i,j,n,temp:byte;rez,k:double;a:boolean; begin clrscr; writeln('Vvedite kol-vo passajirov (n <= 20):'); readln(n); for i:=1 to n do begin writeln('Vvedite svedeniya o ',i,'-om bagaje passajira:'); writeln('Vvedite ves bagaja: '); readln(bagage[i].ves); writeln('Vvedite kol-vo veshei bagaja: '); readln(bagage[i].kol_veshei);end; clrscr; writeln('Bagage, sredniy ves odnoi veshi otlichaetsya ne bolee'); writeln('chem na 0.3 kg ot obshego srednego vesa:'); writeln; a:=true; for i:=1 to n do begin rez:=bagage[i].ves/bagage[i].kol_veshei; if (abs(bagage[i].ves - rez) <= 0.3) then begin a:=false; writeln('Bagage nomer ',i); writeln('ves bagaja: ',(bagage[i].ves):5:2,' kg'); writeln('kol-vo veshei: ',bagage[i].kol_veshei);writeln; end;end; if (a) then writeln('Takogo bagaja net!'); writeln; writeln('Kol-vo passajirov imeyushih bolee 2 veshei:'); writeln; temp:=0; for i:=1 to n do if (bagage[i].kol_veshei > 2) then temp:=temp+1; writeln('Takih passajirov ',temp,' chelovek'); if temp = 0 then writeln('Takih passajirov net!'); writeln; writeln('Kol-vo veshei bolshe srednego chisla veshei: '); writeln; rez:=0; temp:=0; for i:=1 to n do rez:=rez+bagage[i].kol_veshei; for i:=1 to n doif (bagage[i].kol_veshei > (rez/n)) then temp:=temp+1; writeln('Takih veshei ',temp); if temp = 0 then writeln('Takih veshei 0');.writeln; writeln('Bagage iz 1 veshi s vesom ne menee 30 kg'); writeln; temp:=0; for i:=1 to n doif bagage[i].kol_veshei = 1 thenif bagage[i].ves >= 30 thentemp:=temp+1; writeln('Imeetsya ',temp,' passajirov s takim bagajom'); readln; end.

11.Описание: 1.Список книг состоит из 10 записей. Запись содержит поля: Фамилия автора, название книги, год издания.Найти название книг данного автора, изданных с 1960 года. Program df; Uses crt; Type knigi= record Fam:string[15];Naz:string[30];Gad:integer; End; Var s:array[1..10] of knidi; I,k:integer;Av:string;Begin clrscr; For i:=1 tio 10 do begin with s[i] do begin Writeln(vvedi fam,i); Readln(fam); Writeln(vvedi nazv,i); Readln(nazv); Writeln(god); Readln(god);End;end; Writeln(vvedi av); Readln(avt); K:=length(av); For i:=1 to 10 do begin With s[i] do begin If (copy(fam,1,k)=av) and (god>1960) then writeln(nazv,nazv); End;End; End.

12.Описание: Из ведомости 3-х студентов с их оценками ( порядковый номер, Ф.И.О. и три оценки) определить количество отличников и средний бал каждого студента. Program Spic; Type wed = record n:integer ; fio:string[40] ; bal:array [1..3] of integer end;Var spisok:wed; i,j,kol,s:integer; sr:real; Begin kol:=0; with spisok do For i:=1 to 3 do begin n:=i; Write (' Vvedite FIO # ', i ,' '); Readln (fio); s:=0; For j:= 1 to 3 do begin write ( 'Vvedite ocenky: ' ); readln ( bal [j] ); s := s+ bal [j]; end; if s=15 then kol:=kol+1; sr := s/3; writeln ( fio, ', Sredniy bal = ', sr:4:1); end; writeln ( ' Kolichestvo otlichnikov = ', kol ); readln; end.

13.Описание: программа показывает пример объединения координат точек в запись. Здесь используется массив из записей типа RecPoint. Каждая такая запись содержит в себе поля с координатами x, y, z и поле комментария. Таким образом, одна запись описывает одну точку, а массив из записей представляет собой набор точек. Program Records; Uses crt; type RecPoint = record x, y, z: real; comment: string end; var Point: array [1..10] of RecPoint; i: integrer; delta: real; begin Clrscr; for i := 1 to 10 do begin Point[i].x := 2*i - 3; Point[i].y := 3*Point[i].x + 2; Point[i].z := 6*Point[i].y - 2*Point[i].x + 1; delta := Point[i].z - Point[i].x; if delta > 100 then Point[i].comment := 'z - x > 100.' else Point[i].comment := 'Нет комментариев.'; end; Writeln ('Результа расчёта (поля записи):'); Write (' ':7,'x'); Write (' ':8,'y'); Write (' ':8,'z'); Writeln (' комментарии'); for i := 1 to 10 do begin Write (Point[i].x:8:3,' '); Write (Point[i].y:8:3,' '); Write (Point[i].z:8:3,' ':2); Writeln (Point[i].comment); end; Readkey; end.

14.Описание: Выравнивание текста

uses crt;

const

l = 79; {kolvo liter, umeshayushihsya na ekrane v DOSe}

var t: text; i, j: integer; s: string; c, ost: byte;

begin clrscr;

assign(t, 'input.txt'); reset(t);

while not EoF(t) do begin readln(t, s);

for i := 1 to length(s) do if s[i] = ' ' then incc;

ost := l - length(s); {ost - kolichestvo probelov, kotorie nado}

j := 1;

while ost > 0 do begin for i := 1 to length(s) + c - 1 do if (s[i] = ' ') then begin if ost <= 0 then break;

insert(' ', s, i); dec(ost); inc(i, j); end;

inc(j); {t.k. pri prohozhdenii cikla FOR mi vstrechaem pervii probel} end;

c := 0; {obyazatel'no obnulayem kol-vo strok v stroke}

writeln(s); end;

close(t); readkey;

end.

15.Описание:Программа контроля студентов по литературе.Формируется файл вопросов и ответов

program zavd1;

uses crt;

const qfile='quest.txt'; afile='ansver.txt'; var f1,f2:text;i,k:integer; name,ansv:string;

begin clrscr;

assign(f1,qfile);

assign(f2,afile);

rewrite(f2);

reset(f1);

write('vvedi imya ?¬`п, gruppu :');

readln(name);

writeln(f2,name);

while not eof(f1) do begin readln(f1,name);

writeln(name);

write('‚ и ў?¤Ї®ў?¤м :');

readln(name);

writeln(f2,name);

readln(f1,ansv);

if ansv=name then k:=k+1;

i:=i+1;end;

writeln(f2,'‚бм®Ј® ЇЁв ­м :');

writeln(f2,i);

writeln(f2,'Џа ўЁ«м­Ёе ЇЁв ­м :');

writeln(f2,k);

close(f1); close(f2);

end.

Раздел: Строки

1. Описание: Из строки повторяющихся слов, отделяемых запятыми и заканчивающиеся точкой, выписать все гласные буквы в алфавитном порядке, которые входят не более чем в одно слово.

program one;

Uses CRT;

Type MyType = Set Of Char; Var S,W : String; I,K,L : Integer; J : Char; M,N : MyType; B,C : Array [1..32] of MyType;

Begin ClrScr;

M :=[' ','Ґ','с','Ё','®','г','л','н','о','п']; S := 'е«ҐЎ,¬®«®Є®, аЎг§,алЎ ,ᥫҐ¤Є .'; K := 1;

writeln(s);

While pos(',',S) > 0 Do Begin W := copy(S,1,pos(',',S));

B[K] := [];

For I := 1 To Length(W) Do B[K] := B[K] + [W[I]];

Inc(K);

delete(S,1,pos(',',S)); End;

W := S; B[K] := [];

For I := 1 To Length(W) Do B[K] := B[K] + [W[I]];

For I := 1 To K Do Begin C[I] := B[I]; For L := 1 To K Do If I <> L Then C[I] := C[I] - B[L]; End;

N := [];

For I := 1 To K Do N := N + C[I];

M := M * N;

For J := ' ' To 'п' Do If J in M Then Write(J,' ');

WriteLn; ReadKey;

End.

2.Описание: Основа алгоритма игры, согласно которой из слова образца, которое является первым в строке (в данном случае Pascal), составляются другие слова из тех же букв. Количество вхождений одной и той же буквы должно быть не больше, чем в образце.

program one;

Uses CRT;

Var S,T : String; N,I,J : Integer; A : Array [1..100] of String; F : Boolean;

Begin ClrScr;

S := 'pascal cal lasca nosok pasca sapca lapca caplan capla';

N := 1;

While pos(' ', S) > 0 Do Begin A[N] := copy(S, 1, pos(' ', S)-1);

delete(S, 1, pos(' ', S));

inc(N); End;

A[N] := S;

For I := 2 To N Do Begin F := True;

T := A[I];

For J := 1 To Length(T) Do Begin If (pos(T[J], A[1])) >0 Then T[J] := '*' Else F := False; End;

If F Then WriteLn(A[I]); End;

readln;

End.

3.Описание: Вывести каждое слово предложения задом наперед.

Program Stroki;

const chars=['.',',','!','?',' '];var S,S_out,slovo: string; i,j: integer;

begin Writeln('Vv stroku');

Readln(S);

S:= S+' ';

for i:= 1 to Length(S) do if not (S[i] in chars) then Slovo:=slovo+S[i] else if slovo <> '' then begin for j:= Length(slovo) downto 1 do S_out:=s_out+slovo[j];

s_out:=s_out+' ';

slovo:=''; end;

Writeln(S_out);

Readln;

end.

4.Описание: Расположить слова в порядке возрастания их длины в тексте.

program one;

uses crt;

var a,d,sl1,sl2 : string; i,l,k,j : longint; b : array [1..50] of string;

begin clrscr;

write('input s: ');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.

5.Описание: Найти и заменить определенные символы в тексте (заменяемые) введенным символом с клавиатуры (заменяющий). Каждую замену сопровождать подтверждением.

program one;

uses crt;

var i,l:longint;a,a1,a2,p:string;

begin clrscr;textcolor(11);

write('vvedite text: '); readln(a);

write('zamenyaemyi simvol: '); readln(a1);

write('zamenyauschiy simvol: '); readln(a2);

if (length(a1)>1)or(length(a2)>1) then halt;l:=length(a);

for i:=1 to l do if a[i]=a1 then begin clrscr; a[i]:='_';

writeln(a);

writeln('Vy podtverzhdaete zamenu ',i,'-ogo simvola? (y/n)'); readln(p);

if p='y' then a[i]:=a2[1] else a[i]:=a1[1]; end;

clrscr;

write(a); readln;

end.

6.Описание: Найти похожее слово в предложении, которое отличается не более, чем на два символа. Пример: Pascal=Paskal=Pacsal.

program one;

var s,sl:string; m:array[1..100] of string; i,j,k,p,n,kol:integer;

beginwrite('Vvedite TEXT (slova cerez PROBEL): '); readln(s);

write('ISCEM - ? : '); readln(sl);

i:=0;

repeat inc(i);

p:=pos(' ',s);

m[i]:=copy(s,1,p-1);

delete(s,1,p);

until p=0; n:=i; m[n]:=s;

writeln('Naideno:');writeln;

for i:=1 to n do begin kol:=0;

for j:=1 to length(sl) do if pos(sl[j],m[i])<>0 then inc(kol);

if (length(m[i])-kol)<3 then writeln('*',m[i]); end; readln;

end.

7.Описание: Подсчет числа слов в тексте.

program one;

uses crt;

var tec : string; l,i,n : longint;

begin clrscr;

write('input s:');readln(tec);

l:=length(tec)+1;tec[l]:=' ';

for i:=1 to l do if tec[i]=' 'then n:=n+1;

write('in s ',n,' words');

readln;

end.

8.Описание: Максимальное слово в прдложении

program one;

Uses CRT;

Var MaxL,C : String; Pb : Byte;

Begin ClrScr;

WriteLn(vvedite predlojenie:'); ReadLn(C);

MaxL := '';

While Pos(' ',C) <> 0 Do Begin Pb := Pos(' ',C);

If Length(MaxL) < Length(Copy(C,1,Pb-1)) Then MaxL := Copy(C,1,Pb-1);

Delete(C,1,Pb); End;

If Length(MaxL) < Length(C) Then MaxL := C;

WriteLn;

WriteLn('Samaya bolshayaposledovatelnost'simvolov v predlojenii:');

WriteLn(MaxL);

ReadLn;

End.

9.Описание: Выписать слова из строки, которые начинаются с заданной буквы.

program one;

uses crt;

var a,aa,b : string; i,l,o,oo : longint;

begin clrscr;

write('string: ');readln(a);

write('bukva: ');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('takix slov net!'); readln;

end.

10.Вводится 10 букв, а затем слово. Проверяется возможность составить введенное слово из этих символов.

program one;

uses crt;

var as:Array[1..10]of Char; s,s2:String; i,b:Byte;

beginclrscr;

Writeln('vvedite 10 simvolov:');

for i:=1 to 10 do begin rite('ь',i,': ');

readln(mas[i]); end;

write('vvedite stroku: '); readln(s);

for i:=1 to Length(s) do for b:=1 to 10 do if s[i]=mas[b] then begin s2:=s2+mas[b];

mas[b]:=' '; b:=10; end;

if s2=s then write('Iz etih simvolov mozhno sostavit' slovo ',s)else writeln('Iz etih simvolov nelzya sostavit slovo',s);

readln;

end.

11.Описание:Найти в строке минимальное и максимальное слова

program gdy;

label 1;

var s:string; m:array[1..100] of string; i,p,n:integer; ax,min:string; c:char;

begin 1:write('Vvedite stroky: '); readln(s);

if s[length(s)]<>'.' then begin writeln('ERROR: konec stroki okancivaetsia na "."'); goto 1; end;

if length(s)>79 then begin writeln('ERROR: stroka doljna biti <=79 simvolov'); goto 1; end;

write('Vvedite ZADANII SIMVOL:'); readln(c);

i:=0;

repeat p:=pos(' ',s);

if pos(c,copy(s,1,p-1))<>0 then begin inc(i); m[i]:=copy(s,1,p-1); end; delete(s,1,p); until p=0; n:=i; f pos(c,copy(s,1,length(s)-1))<>0 then begin n:=i+1; m[n]:=copy(s,1,length(s)-1); end;

max:=m[1]; min:=m[1];

for i:=2 to n do begin if length(m[i])>length(max) then max:=m[i];

if length(m[i])<length(min) then min:=m[i]; end;writeln;

writeln('MakS: ',max);

writeln('MIN: ',min);

readln; readln;

end.

12.Описание: Счет количества вхождений каждого символа в строку.

program one;

Var I : Word; M : Array [0..255] Of Byte; S : String;

Begin For I := 0 To 255 Do M[I] := 0;

writeln('input string');

Readln(S);

For I := 1 To Length(S) Do Begin Inc(M[ORD(S[I])]); End;

For I := 0 To 255 Do Begin If M[I] > 0 Then WriteLn(CHR(I):3, M[I]:3); End; readln;

End.

13.Описание: Удаление пробелов из заданной строки и вывод результата.

program one;

Var S,T : String; I : Integer;

Begin writeln('input string');

readln(s);

T := '';

For I := 1 To Length(S) Do Begin If (S[I] <> ' ') Then T := T + S[I];

End;

WriteLn(T);

ReadLn;

End.

14.Описание: Вывести заданный символ заданное количество раз

program one;

uses crt;

var n:byte; l:string;n function zvezda(n:byte;l:string):real; var i:integer; s:string;

begin i:=1;

s:='';

while i<=n do begin s:=s+l;

inc(i); end;

writeln(s); end;

begin clrscr;

writeln('Vvedite chislo'); readln(n);

writeln('Vvedite simvol'); readln(l);

zvezda(n,l);

readkey;

end.

15.Описание: Заменить строку звездочками, если строка содержит кавычки

Program one;

var S : string; i : integer;

found : boolean;

begin Write('vvedite stroku simvolov : ');

Readln(S); Found := FALSE;

for i := 1 to Length(S) do {Length(s) = длинна строки, стандартная функция}

if s[i] = '''' then found := TRUE; if Found then {если найден символ "",заменяем}

for i := 1 to Length(S) do s[i] := '*'; Writeln('Rezultiruyuschaya stroka: ', S);

readln;

end

Раздел: Графика

1.Описание: Зеленый перевернутый лист папоротника, заполняющийся точками.

program Fract;

uses Graph,Crt;

var Dt,M : integer; R,A,B,C,D,E,F, NewY,NewX,X,Y : real;

begin Dt := Detect;

InitGraph(Dt, M,'');

Randomize;

X := 0; Y := 0;

repeat R := Random;

if R>0.93 then begin A := -0.15; B := 0.28; C := 0.26; D := 0.24; E := 0; F := 0.44;

end else if R>0.86 then begin A := 0.2; B := -0.26; C := 0.23; D := 0.23; E := 0; F := 1.6;

end else if R>0.01 then begin A := 0.85; B := 0.02; C := -0.02; D := 0.85; E := 0; F := 1.6;

end else begin A := 0; B := 0; C := 0; D := 0.16; E := 0; F := 0; end;

NewX := A*X + B*Y + E; NewY := C*X + D*Y + F; X := NewX; Y := NewY;

PutPixel(Round(X*50)+100,Round(Y*50)+50, Green);

until(Keypressed);

CloseGraph;

end.

2.Описание: Стрелочные часы с быстроидущей секундной стрелкой и показом реального времени.

Program 4as;

uses graph, crt, dos;

type TPoint = record

x, y: Real; end;

var H, M, S, Hund : Word; Xc, Yc, i : Integer; P, P2, P3, P4, P5, P6 : TPoint;

procedure Dec2Polar(Ang, Len: Real; var P: TPoint);

begin Ang := Ang - 90; { Correlation for our coord system }

P.x := Xc + Len * cos(Ang * Pi / 180);

P.y := Yc + Len * sin(Ang * Pi / 180);end;

begin i := 0;

InitGraph(i, i, '');

Xc := GetMaxX div 2; Yc := GetMaxY div 2; SetColor(10);

Circle(Xc, Yc, Yc - 30); SetColor(2); Circle(Xc, Yc, 3); SetColor(14);

for i := 0 to 23 do begin Dec2Polar(i * 15, Yc - 40, P);

Circle(Round(P.x), Round(P.y), 2 + 3*Byte(i mod 2 = 0)); end;{ SetLineStyle(0, 0, 3);}

while not keypressed do begin { Erase } SetColor(0); Line(Round(P2.x), Round(P2.y), Round(P.x), Round(P.y));

Line(Round(P4.x), Round(P4.y), Round(P3.x), Round(P3.y));

Line(Round(P6.x), Round(P6.y), Round(P5.x), Round(P5.y));

GetTime(H, M, S, Hund); { Second arrow }

Dec2Polar((S + Hund/100) * 6, Yc - 50, P);

Dec2Polar((S + Hund/100) * 6, 5, P2); { Minute arrow }

Dec2Polar((M + S/60) * 6, Yc - 100, P3);

Dec2Polar((M + S/60) * 6, 5, P4); Dec2Polar((H + M/60) * 30, Yc - 150, P5);

Dec2Polar((H + M/60) * 30, 5, P6); { Redraw } SetColor(15);

Line(Round(P2.x), Round(P2.y), Round(P.x), Round(P.y)); SetColor(9);

Line(Round(P4.x), Round(P4.y), Round(P3.x), Round(P3.y)); SetColor(7);

Line(Round(P6.x), Round(P6.y), Round(P5.x), Round(P5.y)); delay(1000); end; CloseGraph;

end.

3.Описание: Скачущий мяч с постепенным снижением амплитуды.

program ufo;

uses crt,graph; const r=20;h=5; var gd,gm,i,n,t,x,y,p:integer;

begin clrscr;

gd:=Detect;

initgraph(gd,gm,'c:\bp\bgi '); setcolor(4); setlinestyle(0,1,1);

line(0,479,639,479);

x:=r;y:=r; t:=479-2*r; n:=t div h; p:=h;

while n<>0 do begin for i:=1 to n do begin setcolor(2); circle(x,y,r); setfillstyle(1,2);

floodfill(x,y,2); delay(10);

setcolor(0); circle(x,y,r);

setfillstyle(1,0); floodfill(x,y,0);

y:=y+p; x:=x+1; end;

if p>0 then begin t:=round(3*t/4);n:=t div h end;

p:=-p end; setcolor(12); circle(x,y,r);

setfillstyle(1,2);

floodfill(x,y,12);

repeat until keypressed;closegraph

end.

4.Описание: Нло в замкнутом пространстве на фоне звездного неба.

program ufo;

uses graph,crt;

const r=20; pause=50; var d,m,e,xm,ym,x,y,lx,ly,rx,ry, size,i,dx,dy,width,height:integer; saucer:pointer;

label loop;

begin d:=detect;

initgraph(d,m,'');

e:=graphresult;

if e<> grok then writeln(grapherrormsg(e)) else begin x:=r*5; y:=r*2;

xm:=getmaxx div 4; ym:=getmaxy div 4;

ellipse(x,y,0,360,r,r div 3+2); ellipse(x,y-4,190,357,r,r div 3);

line(x+7,y-6,x+10,y-12); line(x-7,y-6,x-10,y-12);

circle(x+10,y-12,2); circle(x-10,y-12,2);

floodfill(x+1,y+4,white);

lx:=x-r-1; ly:=y-14;

rx:=x+r+1; ry:=y+r div 3+3;

width:=rx-lx+1; height:=ry-ly+1;

size:=imagesize(lx,ly,rx,ry);

getmem(saucer,size); getimage(lx,ly,rx,ry,saucer^);

putimage(lx,ly,saucer^,xorput);

rectangle(xm,ym,3*xm,3*ym);

setviewport(xm+1,ym+1,3*xm-1,3*ym-1,clipon); xm:=2*xm; ym:=2*ym;

for i:=1 to 200 do

putpixel(random(xm),random(ym),white);

x:=xm div 2;

y:=ym div 2;

dx:=10; dy:=10; repeat putimage(x,y,saucer^,xorput); delay(999);

putimage(x,y,saucer^,xorput);

loop: x:=x+dx; y:=y+dy;

if (x<0) or (x+width+1>xm) or (y<0) or (y+height+1>ym) then begin x:=x-dx; y:=y-dy;

dx:=getmaxx div 10-random(getmaxx div 5); dy:=getmaxy div 30-random(getmaxy div 15); goto loop end until keypressed;

if readkey=#0 then x:=ord(readkey);

closegraph end

end.

5.Описание: Заполнение квадрата случайными линиями разных цветов.

program graphik;

uses graph,crt;

var d,r,e:integer; x1,y1,x2,y2:integer;

begin clrscr;

d:=detect;

initgraph(d,r,'');

e:=graphresult;

if e <> grok then writeln(grapherrormsg(e)) else begin x1:=getmaxx div 3;

y1:=getmaxy div 3;

x2:=4*x1;y2:=4*y1;

rectangle(x1,y1,x2,y2);

setviewport(x1+1,y1+1,x2-1,y2-1,clipon);

repeat setcolor(succ(random(16)));

line(random(x2-x1),random(y2-y1),random(x2-x1),random(y2-y1))

until keypressed;

if readkey=#0 then d:=ord(readkey);

closegraph

end end.

6.Описание: Медленно выезжающий кусок пирога или пиццы.

program pie;

uses crt,graph;

var graphdriver,graphmode,errorcode:integer; j,v,l,m,k,i:integer;

begin graphdriver:=detect;

initgraph(graphdriver,graphmode,'');

errorcode:=graphresult;

if errorcode<>grOk then begin writeln('ЋиЁЎЄ Ја дЁЄЁ: ',graphErrorMsg(errorcode));

writeln('Џа®Ја ¬¬ ў аЁ©-® § ўҐаиЁ« а Ў®вг...');

halt(1); end;

setcolor(yellow);

circle(200,200,50);

floodfill(199,199,yellow);

delay(30000);

setcolor(black);

pieslice(200,200,30,60,50);

for i:=1 to 20 do begin setcolor(yellow);

pieslice(200+i,200-i,30,60,50);

setcolor(black);

pieslice(200+i,200-i,30,60,50);

delay(30000);

i:=i+1; end;

readkey;

closegraph;

end.

7.Описание: Статичное изображение двухколесного велосипеда.

program gr;

uses graph;

var grDriver:integer;

grMobe:integer;

Begin grDriver:=Detect;

InitGraph(grDriver,grMobe,'');

SetColor(12);

circle(200,150,30);circle(200,150,23);circle(330,150,30);circle(330,150,23);line(200,150,280,150);line(280,150,320,110);line(320,110,210,110);line(210,110,250,150);line(200,150,210,110);circle(200,150,5);circle(270,150,10);line(270,150,270,170);line(265,170,275,170);line(200,145,270,140);line(200,155,270,160);line(330,150,320,110);line(320,110,320,98);line(320,98,310,98);line(210,110,210,100);circle(210,100,5);line(210,100,220,100);line(270,150,270,130);line(265,130,275,130);readln;

End.

8.Описание: Приближающийся на смотрящего квадрат. Увеличение размеров по времени.

program gr;

uses graph,crt;

VAR x,y,i:integer;

PROCEDURE grafika_on;

Var drv,mode:integer;

BEGIN drv:=9; {VGA }mode:=2; {VGAHi}

initgraph(drv,mode,'');END;

BEGIN grafika_on;

x:=300; y:=200;

for i:=1 to 100 do begin setcolor(9);

rectangle(x-i,y-i,x+i,y+i);

delay(100); setcolor(0); rectangle(x-i,y-i,x+i,y+i);

end; readkey; closegraph;

END.

9. Описание:Строительство башни по блокам.

program gr;

Uses crt, Graph;Var P:pointer;Size:Word; X1,Y1:Word; gd,gm: integer;

Begin gd:=detect;

InitGraph(gd,gm,'');

IF GraphResult<>0 THEN Halt(1);

SetViewPort(0,0,640,80,TRUE);

ClearViewPort;

SetBkColor(black);SetColor(yellow);

SetLineStyle(0,1,Thickwidth);Rectangle(120,400,200,440);

Size:=ImageSize(120,400,200,440);

GetMem(p,Size);

GetImage(120,400,200,440,P^);

Y1:=440;

WHILE Y1>=40 DO begin X1:= 120;

begin PutImage(X1,Y1,p^,CopyPut); Delay(59000);

X1:=X1+80 end;

Y1:=Y1-40 end; x1:=x1-160;WHILE X1<=280 DO Begin PutImage(X1,Y1,p^,CopyPut);

X1:=X1 +160 end;

setfillstyle(8,red);

Bar(200,40,280,500); Bar(40,40,120,500);

SetColor(11);SETTEXTSTYLE(6,7,6);

outtextxy(350,100,'BASHNYA!');Readln;

CloseGraph End.

10. Описание:Пульсирующее сердце (анимация).

program gr;

uses crt,graph;var driver,mode,error:integer; l,n,m,x,y,r:integer;

begin driver:=detect;

initgraph(driver,mode,'');

error:=graphresult;

if error<>grOk then begin writeln('ЋиЁЎЄ Ја дЁЄЁ: ',graphErrorMsg(error));

writeln('Џа®Ја ¬¬ ў аЁ©-® § ўҐаиЁ« а Ў®вг...'); halt(1); end;

m:=1;l:=1;x:=1;y:=1;r:=1;n:=1;

repeat x:=1;y:=1;r:=1;l:=1;

repeat begin setcolor(cyan);

arc(170-x,150,0,180,20+r); arc(210+x,150,0,180,20+r);

line(150-2*x,150,190,200+y); line(230+2*x,150,190,200+y);

floodfill(149,150,cyan);

x:=x+1;y:=y+1;r:=r+1;

delay(20); clearviewport;

l:=l+1; end; until l=20;

x:=1;y:=1;r:=1;m:=1;

repeat setcolor(cyan);

arc(150+x,150,0,180,40-r); arc(230-x,150,0,180,40-r);

line(110+2*x,150,190,220-y); line(270-2*x,150,190,220-y);

floodfill(149,150,cyan);

x:=x+1;y:=y+1;r:=r+1;m:=m+1; delay(20);

clearviewport; until m=20; n:=n+1; until n=20; closegraph;

end.

11. Описание: Динамическое изображение планеты сатурн с помощью эллипсов.

program graphik;

uses graph,crt;

var a,b,e:integer;

begin a:=detect;

initgraph(a,b,'');

e:=graphresult;

if e<>grok then writeln(grapherrormsg(e))

else begin repeat setlinestyle(2,5,2*2+5);

setcolor(random(3));

ellipse(300,250,128,52,random(300),random(100));

setcolor(random(8));

ellipse(300,250,0,360,random(200),200);

until keypressed;

closegraph;end

end.

12.Описание: Медленно поднимающийся вверх воздушный шар.

Program one;

uses crt,graph;

var gd,gm,y,size:integer; p:pointer;

begin initgraph(gd,gm,'');size:=imagesize(50,200,150,400);getmem(p,size);setcolor(14);

setfillstyle(1,14);arc(100,250,0,180,50);line(50,250,150,250);

floodfill(120,240,14);setcolor(1);line(50,250,75,350);

line(150,250,125,350);setcolor(4);setfillstyle(1,4);

bar(75,350,125,400);

getimage(50,200,150,400,p^);setfillstyle(1,0);

for y:=480 downto 0 do begin putimage(50,y,p^,1);delay(1000);cleardevice;

bar(50,y,150,y+100);

end; readln; closegraph;

end.

13.Описание: Снеговики стоят в несколько рядов один за другим.

program snegovik;

uses graph;

var i,j,x,y:integer;grdriver:integer;grmode:integer;begin grdriver:=detect;initgraph(grdriver,grmode,'c');

x:=50;y:=30;

for i:=1 to 10 do begin for j:=1 to 10 do begin setcolor(blue);

circle(x,y,10);circle(x,y+30,20);

circle(x,y+80,30);circle(x-30,y+30,10);

circle(x+30,y+30,10);setcolor(5);

line(x,y-5,x+15,y);line(x,y+5,x+15,y);setcolor(white);

line(x-5,y+5,x+5,y+5);

putpixel(x-5,y-5,white);putpixel(x+5,y-5,white);

putpixel(x,y+20,white);putpixel(x,y+30,white);

putpixel(x,y+40,white);putpixel(x,y+60,white);

putpixel(x,y+70,white);putpixel(x,y+80,white);

putpixel(x,y+90,white);putpixel(x,y+100,white);setcolor(3);

line(x-5,y-10,x+5,y-10);line(x+5,y-10,x,y-20);line(x,y-20,x-5,y-10);

x:=x+90;end;

y:=y+160;x:=50;

end;readln

end.

14.Описание: Снежика, рисуемая в зависимости от длины и количества лучей и глубины рекурсии.

Program Snezhinka;

Uses crt, graph;

const k = 150; n = 8; g = 4;

var gd, gm: integer; procedure Snezhinka_v_zh (x, y: word; r, c: byte); var alpha: real; i: byte; xd, yd: integer;

begin if c < 1 then exit;

for i := 1 to n do

begin alpha := 2 * Pi * i / n;

xd := round(x + r * cos(alpha));

yd := round(y + r * sin(alpha));

moveto(x, y); lineto(xd, yd);

Snezhinka_v_zh(xd, yd, r div 3, c - 1); end; end;

BEGIN initgraph(gd, gm, 'h:\tp\bgi'); setcolor(11);

snezhinka_v_zh(320, 240, k, g); readkey;

closegraph;

END.

15.Описание: Нарисовать радугу, используя элипсные дуги разных цветов.

Program Raduga;

Uses Graph;

var D,M,y,i : Integer;

begin D := Detect;

InitGraph(D,M,'');

if GraphResult <> grOk then WriteLn(GraphErrorMsg(GraphResult)) else begin y:=200;

for i:=1 to 30 do begin if i<5 then SetColor(4); if (i>5)and(i<10) then SetColor(14); if (i>10)and(i<15) then SetColor(2); if (i>20)and(i<25) then SetColor(1); if i>25 then SetColor(13);

Ellipse(325,y,10,170,240,150); inc(y); end;

Readln; CloseGraph; end;

end.