end;

Var spisok: wed; {Запись spicok типа wed}

i, j, kol, s: integer; sr: real;

Begin

kol:=0; {kol- количество отличников}

With spisok do {with присоединяет имя записи spisok ко всем }

For i:=1 to 3 do { полям внутри цикла For по i }

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.

Задание14. Пусть нам необходимо заполнить сведения о студенте (Ф.И.О., дата рождения, адрес, курс и группа), а затем вывести эти сведения на экран

program primer1;

type anketa=record

fio: string[45];

dat_r: string[8];

adres: string[50];

curs: 1..5;

grupp: string[3]

end;

var student: anketa;

begin

writeln (`введите сведения о студенте');

{обратите внимание, ввод каждого поля осуществляется отдельно}

writeln (`введите фамилию, имя и отчество');

readln (student.fio);

writeln (`введите дату рождения');

readln (student.dat_r);

writeln (`введите адрес');

readln(student.adres);

writeln (`введите курс');

readln(student.curs);

writeln (`введите группу');

readln (student.grupp);

writeln (`ввод закончен');

writeln;

{обратите внимание, что вывод записи осуществляется по полям}

writeln (`фамилия студента: ', student. fio);

writeln(` дата рождения: ', student.dat_r);

writeln(` адрес: ', student.adres);

writeln(` курс: ', student.curs);

writeln(` группа: ', student.grupp);

end.

Задание15. Пусть нам необходимо иметь сведения о многих студентах, например, нашего факультета. Следовательно, необходимо организовать массив записей Паскаля. А затем из общего списка вывести фамилии студентов 2-го курса

program primer 2;

type anketa=record

fio: string[45];

dat_r: string[8];

adres: string[50];

curs: 1..5;

grupp: string[3]

end;

var student: array [1..100] of anketa;

I: integer;

begin

{последовательно вводим каждую запись}

for I:=1 to 100 do

begin

writeln (`введите сведения о', I, `-м студенте');

writeln (`введите фамилию, имя и отчество');

readln (student[I].fio);

writeln (`введите дату рождения');

readln (student[I].dat_r);

writeln (`введите адрес');

readln(student[I].adres);

writeln (`введите курс');

readln(student[I].curs);

writeln (`введите группу');

readln (student[I].grupp);

end;

writeln (`ввод закончен');

writeln;

{просматриваем массив записей и выбираем только студентов 2-го курса }

for I:=1 to 100 do

if student[I].curs=2 then

writeln(` фамилия студента: ', student[I].fio);

end.

Строки

Задание 1. Дана последовательность слов. Напечатать те слова последовательности, которые отличны от последнего слова и удовлетворяют свойству: слово симметрично

Program Stroki;

Uses Crt;

Var s,k:string;

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

i,n,j,l:Integer;

f:boolean;

begin

ClrScr;

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

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

Readln(s);

{Запись слов в массив a}

for i:=1 to length(s) do begin

if (s[i-1]<>' ') and (s[i]=' ') and (length(k)<>0) then begin

inc(n);

a[n]:=k;

k:='';

end;

if s[i]<>' ' then k:=k+s[i];

if (i=length(s)) and (length(k)<>0) then begin

inc(n);

a[n]:=k;

k:='';

end;

end;

{Проверка на симметричность слов, содержащихся в массиве а}

l:=0;

for i:=1 to n-1 do begin

f:=false;

if a[i]<>a[n] then

if length(a[i]) mod 2 = 0 then begin

for j:=1 to length(a[i]) div 2 do

if a[i][j]<>a[i][length(a[i])+1-j] then f:=true;

if f=False then begin

l:=l+1;

if l=1 then Write('Симметричные слова: ');

Write(a[i],' ');

end;

end;

end;

Writeln;

if l=0 then Writeln('Симметричные слова отсутствуют');

Write('Нажмите Enter');

Readln;

end.

Задание 2. Дана строка символов. Преобразовать эту строку удалив из нее каждые ">>" и повторив (вставив еще раз) каждую пару символов "<<". После преобразования полученную строку вывести на печать

Program Stroki;

Uses Crt;

Var s:string;

i:integer;

begin

ClrScr;

Write('Введите строку символов: ');

Readln(s);

for i:=1 to length(s) do begin

if (s[i-1]='>') and (s[i]='>') then delete(s,i-1,2);

if (s[i-1]='<') and (s[i]='<') then begin

insert('<<',s,i-1);

i:=i+2;

end;

end;

Writeln('Преобразованная строка: ',s);

Write('Нажмите Enter');

Readln;

end.

Задание 3. Составить программу, которая запрашивает имя человека и повторяет его на экране с Приветствием

Program as;

Uses crt;

Var K:string;

Begin clrscr;

Writeln(`Как вас зовут');

Readln(k);

Writeln(`Привет,' `,k'!');

End.

Задание 4. Составить программу, которая запрашивает название футбольной команды и повторить его на экране со словом «Это чемпион!»

Program as;

Uses crt;

Var k:string;

Begin clrscr;

Writeln(`Введите название футб. команды');

Readln(k);

Writeln(k,' ','Чемпион!');

End.

Задание 5. Дана строка символов s1,s2,...sn, в которой встречаются цифры, пробелы, буква Е и знаки + и -. Известно, что первый символ строки является цифрой. Из данной строки выделить подстроку предшествующую первому пробелу. Требуется: определить является ли это подстрока числом, если да, то выяснить целым или вещественным, положительным или отрецательным

Program Stroki;

Uses Crt;

Var s1,s2:string;

i:Integer;

k:Real;

f:boolean;

begin

ClrScr;

Writeln('Введите строку символов:');

Readln(s1);

s2:='';

f:=true;

for i:=1 to length(s1) do begin

if s1[i]=' ' then f:=false;

if (s1[i]<>' ') and (f=true) then s2:=s2+s1[i];

end;

Writeln('Выделенная подстрока: ',s2);

Val(s2,k,i);

if i<>0 then Writeln('Выделенная подстрока не содержит числовое значение')

else begin

f:=false;

for i:=1 to length(s2) do

if s2[i]='E' then begin

Write('Число в подстроке вещественного типа, ');

f:=true;

end;

if f=false then Write('Число в подстроке целочисленного типа, ');

if k<0 then Writeln('отрицательное')

else Writeln('положительное')

end;

Write('Для выхода нажмите Enter');

Readln;

end.

Задание 6. Дано название футбольного клуба, определить кол-во символов в нем

Program as;

Uses crt;

Var k:string; M:integer;

Begin clrscr;

Writeln(`Введите название Ф.К');

Readln(k);

M:=length(k);

Writeln(M);

End.

Задание 7. Дано название города, определить четно или нет, кол-во символов в нем

Program as;

Uses crt;

Var k:string;b:integer;

Begin clrscr;

A:='Aktobe';

B:=length(a);

If b mod 2=0 then write(`четно `) else write(`нечетно `);

Readln;

End.

Задание 8. Дана строка, содержащая текст. Записать её в обратном порядке

program з8;

var s1,s2: String;

i: Integer;

begin

Write('Введите строку=');

ReadLn(s1); s2:='';

for i:=Length(s1) downto 1 do s2:=s2+s1[i]; WriteLn('Обратная строка=',s2);

ReadLn; end.

Задание 9. Дано слово. Заменить «о» на «е»

Program as;

Uses crt;

Var a:string; e,I,b:integer;

Begin clrscr;

Writeln(`Dano clovo');

Readln(a);

B:=length(a);

For i:=1 to b do if copy(a,I,1)='o' then begin

Delete(a,I,1);

Insert(`e',a,i);

End;

Writeln(a);

End.

Задание10. Даны 2 фамилии опред какая из них длиннее

Program as;

Uses crt;

Var a,b:string; c,d:integer;

Begin clrscr;

A:='kolin';

B:='imanalin';

C:=length(a);

D:=:=length(b);

If c>d then write(a) else write(b);

End.

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

Задание 1. При нажатии на Enter плавно перемещает треугольник c вершинами (10,10);(10,100);(100,100) на 10 пунктов по X, и по Y

uses crt,graph;

const n=4;

type

Point=record

x,y:integer;

end;

mas=array[1..n] of Point;

procedure Z(x,y:integer;var m:mas;c:byte);

var i:byte;

begin

Setcolor(c);

m[1].x:=x;m[1].y:=y;

m[2].x:=x;m[2].y:=y+90;

m[3].x:=x+90;m[3].y:=y+90;

m[4].x:=x;m[4].y:=y;

moveto(m[1].x,m[1].y);

for i:=1 to n do

lineto(m[i].x,m[i].y);

Setfillstyle(1,c);

end;

var gd,gm:integer;

x,y,x1,y1,i:integer;

p:mas;

c1,c2:byte;

k:char;

move:boolean;

begin

gd:=VGA;

gm:=VGAHi;

Initgraph(gd,gm,'..\bgi');

Setbkcolor(8);

x:=10;y:=10;

c1:=7;c2:=8;

move:=true;

repeat

if keypressed then

begin

k:=readkey;

if k=#13 then {if enter}

for i:=1 to 10 do

begin

y1:=y;

x1:=x;

y:=y+1;

x:=x+1;

delay(6000);

Z(x1,y1,p,c2);

Z(x,y,p,c1);

move:=true;

end;

end;

if move then

begin

Z(x1,y1,p,c2);

Z(x,y,p,c1);

move:=false;

end;

OutTextXY(320,240,'Press Enter to continue');

until k=#27; {until escape}

closegraph;

end.

Задание 2. Изобразить на экране скачущий мяч. Использовать графический режим

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); repeat until keypressed;closegraph

floodfill(x,y,12); end.

Задание 3. Анимационная картинка - кораблик совершает путь по заданной траектории...все происходит довольно быстро

program corablik;

uses Graph, Crt;

var

grDriver: integer;

grMode: integer;

ErrCode: integer;

x,y,y0,a,b: integer;{a,b-переменные для линии моря, чтоб они не зависели от х,у}

procedure more(a,b:integer);

begin

moveto(0,y0);

setcolor(blue);

for a:=0 to 680 do{слева направо рисуем синусоиду синего чвета}

begin

b:=y0-round(sin(a*pi/180)*30);{30-коэффициент масштабирования по оси Х,

чем больше, тем волна круче}

lineto(a,b);

end;

end;

begin

grDriver:= Detect;

InitGraph(grDriver, grMode, '..\BGI');

ErrCode:= GraphResult;

y0:= 250;

if ErrCode = grOk then

begin

x:=600;

while x>=0 do{лучше использовать цикл while, можно менять величину шага,

что тоже влияет на скорость и частоту смены картинки}

begin

cleardevice;

more(a,b);{рисуем волну}

setcolor(white);{устанавливаем цвет кораблика}

y:=y0-40-round(sin(x*pi/180)*30);{движемся по волне}

MoveTo(x - 40, y + 20);

LineTo(x - 20, y + 40);

LineTo(x + 20, y + 40);

LineTo(x + 40, y + 20);

LineTo(x - 40, y + 20);

MoveTo(x + 15, y + 20);

LineTo(x + 15, y - 40);

LineTo(x - 20, y + 20);

LineTo(x + 15, y + 20);

delay(100); {нормальная скорость, если модули *.TPL не глючные как у Вас,

время должно быть в миллисекундах, а не в каких-нибудь наносекундах}

x:=x-2;{шаг движения}

end;

end

else Writeln('Graphics error: ', GraphErrorMsg(ErrCode));

Settextstyle(0,0,3);{устанавливаем стиль шрифта}

cleardevice;

setcolor(red);

OuttextXY(200,240,'Rejs zavershen!');{выводим надпись}

readln;

CloseGraph;

end.

Задание 4. Анимация - прямоугольничек красного цвета совершает полный путь по экрану монитора!

program kv;

uses

crt, graph;

var

x, y, dx, dy, w, h, driver, mode: integer;

begin

initgraph(driver, mode, 'G:/BP/BGI');

if graphresult<>0 then begin

writeln('none');

halt

end;

dx:=1;

dy:=0;

w:=100;

h:=10;

repeat

setfillstyle(1, black);

bar(x, y, x+w, y+h);

x:=x+dx;

y:=y+dy;

setfillstyle(1, red);

bar(x, y, x+w, y+h);

delay(100);

if (x+w>=getmaxx)and(y<=0) then

begin

dx:=0;

dy:=1;

end

else

if (y+h>=getmaxy)and(x+w>=getmaxx) then

begin

dx:=-1;

dy:=0;

end

else

if (x<=0)and(y+h>=getmaxy) then

begin

dx:=0;

dy:=-1;

end

else

if (y<=0)and(x<=0) then

begin

dx:=1;

dy:=0;

end;

until keypressed;

closegraph;

end.

Задание 5. Люди часто просят нарисовать самый обычный рисунок из разных тем...например нарисую"программиста"

Program bugalteria;

Uses crt,graph;

Var gd,gm:integer;

begin

clrscr;

Detectgraph (gd,gm);

Initgraph (gd,gm,'C:\tp7');

{Зарисовка стола}

Bar (120,330,360,360);

Bar (180,360,330,480);

{Зарисовка компьютера}

Line (180,240,180,330);

Line (180,270,210,330);

Line (172,210,202,300);

Line (180,210,210,300);

Line (210,300,202,300);

Line (180,210,172,210);

Line (270,322,270,330);

Line (270,322,330,330);

{Зарисовка стула}

Bar (420,405,510,420);

Bar (456,420,480,480);

{Зарисовка бухгалтера работающего за компьютером}

Line (510,405,540,300);

Line (334,480,390,390);

Line (390,390,510,390);

Line (360,480,420,405);

Line (510,390,450,240);

Line (480,390,420,300);

Line (420,300,430,240);

Line (450,270,330,300);

Line (330,300,310,310);

Circle (435,195,40);

Readln

end.

Задание 6. Построить один прямоугольник и заполнить его случайно расположенными точками (в пределах 100 штук) и второй прямоугольник в котором проведены случайные линии (различными цветами)

program пример;

uses graph, crt;

var gd,gm,xl,yl,x2,y2,x,y,x3,y3,i,errcode: integer;

begin

gd:=0; gm:=0;

InitGraph (gd,gm,' `);

[построение первого прямоугольника]

x1:=10; y1:=10; x2:=200; y2:=200;

rectangle(x1,y1,x2,y2);

[вывод случайных точек]

for i:=1 to 100 do

begin

x:=random(x2-xl)+x1;

у:=random(y2-yl)+y1;

putpixel(x,y,2)

end;

[построение второго прямоугольника]

xl:=210; yl:=210; x2:=400; y2:=400;

rectangle(xl,yl, x2,y2);

[вывод случайных линий]

for i:=l to 100 do

begin

setcolor(random(15));

x:=random(x2-xl)+xl;

y:=random(y2-yl)+yl;

x3:=random(x2-xl)+xl;

y3:=random(y2-yl)+yl;

Iine(x,y,x3,y3);

end;

while not keypressed do;

closegraph

end.

Задание 7. Изобразить линии разного стиля и толщины

program пример;

[ вывод линий разного вида]

uses graph,crt;

var gd,gm: integer;

begin

gd:=0; gm:=0; initgraph (gd, gm, ' ');

line (0, 0, 300, 0); [линия обычного образца]

setlinestyle(l,0,l);line(0,20,300,20);[линия из точек]

setlinestyle(2,0,l);line(0,40,300,40);[пунктирная линия]

setlinestyle (3,0,1);line(0,60,300,60);[штриховая линия]

setlinestyle(0,0,3);line(0,80,300,80);[сплошная толстая линия]

while not keypressed do;

closegraph end.

Задание 8. Построить окружность и описать вокруг нее квадрат

program пример;

[квадрат и вписанная окружность]

uses graph, crt;

var gd,gm,x,y,r,x1,y1,x2,y2: integer; xa,ya:word;

begin

writeIn (`введи координаты центра окружности и радиус');

readln(x,y,r);

gd:=0; gm:=0; initgraph(gd,gm, ` `);

circle(x, у, г);

getaspectratio(xa,ya);

x1:= x-r; у1:= round (y -r*(xa/ya));

x2:=x+r; y2:= round (y+r*(xa/ya));

rectangle(xl,yl,x2,y2);

while not keypressed do;

closegraph end.

Задание 9. Построить дугу от 0 до 90 градусов и от 270 до 450 градусов

program пример;

[дуги окружности от 0 до 90 и от 270 до 450]

uses graph,crt;

var gd,gm,x,y,r,xl,yl: integer; xа,уа:word;

begin

gd:=0; gm:=0; initgraph(gd,gm,' `);

getaspectratio(xa,ya);

{строим оси координат}

line(0,100,300,100); line(150,0,150,200);

{ строим дугу от 0 до 90 }

агс(150,100,0,90,40);,

line (310, 100,610,100); line(460,0,460,200);

{ строим дугу от 270 до 450 }

arc(460,100,270,540,40);

while not keypressed do; end.

Задание10. Построить дуги элипсов

program пример;

[дуги эллипсов при разном соотношении Rx и Ry]

uses graph,crt;

var gd,gm:integer; xa,ya:word;

begin

gd:=0; gm:=4; initgraph (gd, gm, ` `);

getaspectratio(xa, ya);

{ первая дуга}

line(0,100,l60,100);

line(80, 55, 80,145);

ellipse(80,100,180, 90,40,40);

{ вторая дуга}

line(190,100,410,100);

line(300,55,300, 145);

ellipse(300, 100, 0, 359,100,20);

{ третья дуга}

line(440,100,600,100);

line(520,55,520,145);

ellipse (520, 100, 0,270,40, round (40* (xa/ya)));

while not keypressed do; end.

Задание11. Построить прямоугольники в два ряда по четыре прямоугольника в ряд и заполнить их соответственно 12-ю различными типами штриховки

program пример;

{демонстрация цветов заполнения}

uses graph,crt;

var gd,gm,x,y,k, j:integer;

begin

gd:=0; gm:=0; initgraph (gd, gm, ' ');

x:=60; y:=40;

for j:=0 to 2 do

for k:=0 to 3 do

begin

rectangle ((k + 1) *x,(j+1)*y, (k+2)*x, (j+2)*y);

setfillstyle{k+j*4, j+1);

bar((k+1)*x+1, (j+1)*y+1, (k+2)*x-1, (j+2)*y-1)

end;

while not keypressed do;

end.

Задание12. Построить окружность и описать вокруг нее квадрат,а затем область внутри квадрата, но вне окружности закрасить цветом фона

program пример;

{ квадрат и вписанная окружность}

uses graph,crt;

var gd, gm, x, y, r,xl,yl,x2,y2: integer; xa,ya:word;

begin

writeln('введи координаты центра окружности и радиус');

readln (х,у,г);

gd:=0; gm:=0; initgraph (gd, gm, ` `);

setcolor(3); circle(x, y, r);

getaspectratio(xa,ya);

x1:=x-r; yl:=round(у-r*(xa/ya));

x2:=x+r; y2:=round(y+r*(xa/ya));

rectangle(x1,y1,x2,y2);

floodfill(x1+1,y1+1,3);

floodfill(x2-1,y1+1,3);

floodfill(x1+1,y2-1,3);

floodfill(x2-1,y2-1,3);

while not keypressed do;

closegraph

end.

Задание13. Вывести точечным шрифтом горизонтально, начиная с точки (100,20), сообщение "horisontal (горизонтально)" и прямым шрифтом вывести вертикально сообщение "vertical (вертикально)", начиная с точки (5,10)

program пример;

{ графика и текст}

uses graph,crt;

var gd,gm: integer;

begin

gd:=0; gm:=0; initgraph(gd,gm, ` `);

outtextxy(100,20, `horisontal (горизонтально)');

settextstyle(0,1,1);

outtextxy (50,10, `vertical (вертикально)');

while not keypressed do;

end;

Задание14. Изобразить треугольник, вращающийся вокруг одной из вершин

program пример;

{ вращение треугольника вокруг одной вершины}

uses graph,crt;

var

gd,gm,I,xc,yc,x1,y1,x2,y2,x1n,x2n,y1n,y2n:integer;

xa,ya:word; t: real;

begin

gd:=9; gm:=2; initgraph (gd, gm, ` `);

getaspectratio(xa,ya);

xc:=300; yc:=100; t:=0; x1:=400; y1:=10; x2:=500;

y2:=100;

for i:=0 to 360 do

begin

t:=t+pi/180;

xln:=round (xc+ (xl-xc) *cos (t)+(yl-yc)*sin(t) *ya/xa);

у1n:=round (yc+ (yl-yc) *cos (t) - (xl-xc)*sin(t) *xa/ya);

x2n:=round (xc+(x2-xc) *cos(t)+(y2-yc)*sin(t) *ya/xa);

y2n: =round (yc+ (y2-yc) *cos (t) + (x2-xc)*sin(t) *xa/ya);

setcolor (15);

line (xc,yc, xln, yln); line (xln,yln,x2n,y2n);

line (x2n,y2n,xc,yc); delay(20);

setcolor(0);

line(xc,yc,xln,yln); line (xln,yln,x2n,y2n);

Iine(x2n,y2n,xc,yc); delay(20);

end; while not keypressed do;

closegraph

end.

Задание15. Изобразить движение шара(точнее круга)по горизонтали

program пример;

{ движение шара по горизонтали}

uses qraph,crt;

var gd,gm,i: integer; p:pointer; s:word;

begin;

gd:=0; gm:=0; initgraph (gd, gm, ` `);

{ рисуем шар}

for i:=l to 10 do circle (20, 30, i);

{ выделяем память}

s:=imagesize(9, 20,30, 40); getmem(p,s);

{ запоминаем рисунок}

getimage(9, 20, 30, 40,p^); cleardevice;

{ изображаем полет шара }

for i:=l to 600 do

begin putimage(10+i, 100,p^,0); delay(10); end;

while not keypressed do;

end.