Writeln(‘Минимальное=^,min);

Readln;

End.

(Вводим значение 5,6) Ответ: 5

Задание12. Даны 2 числа. Если кв.корень из второго числа меньше первого числа, то увеличить второе число в 5 раз

program as;                                                                  Блок-схема

uses crt;

var a,b,d,c:real;

begin clrscr;

writeln(‘Введи 2 числа^);

readln(a,b);

c:=sqrt(b);

if (d

writeln(‘увеличить 2 число в 5 раз^,c*c*c*c*c:5:2)

 else writeln(‘нет решения^);

readln;

end.

Ответ: нет решения

Задание13. Дано число. Если это число чётное, то /2 если нет, то *2

Program as;                                                        Блок-схема

Var a: integer;

Begin clrscr;

Writeln(‘Введи число^);

Readln (a);

If a mod 2=0 then writeln(a/2)

 else writeln(a*2);

Readln;

End.

(Вводим значение 5)

Ответ:10

Задание14.Даны 4 вещественных числа. Найти сумму тех чисел, которые больше 5

Program as;                                                        Блок-схема

Uses crt;

Var a,b,c,d,k,z,x,v:integer;

Begin clrscr;

Writeln(‘Введи 4 числа^);

Readln(a,b,c,d);

If a>5 then k:=a;

If b>5 then z:=b;

If c>5 then x:=c;

If d>5 then v:=d;

Writeln(‘Общая сумма=^,k+z+x+v);

End.

(Вводим значение 6,6,6,6)

Ответ: 24

Задание15.Даны 3 числа a,b,c. Найти максимальное

Program as;                                                        Блок-схема

Uses crt;

Var a,b,c:integer;

 Max,max1:integer;

Begin clrscr;

Writeln(‘Введи 3 числа^);

Readln(a,b,c);

If max>c then max1:=max else max1:=c;

Writeln(‘Максимально=^,max1);

Readln;

(Вводим значение 5,6,7)

Ответ: 7

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

Задание 1.Напечатать “столбиком”: все целые числа от 20 до 35

Program as;                                                        Блок-схема

Uses crt;

Var a:integer;

For a:=20 to 35 do writeln(a);

Readln;

end.

Задание 2.Напечатать “столбиком”: квадраты всех целых чисел от 10 до b (значение b вводится с клавиатуры, причем b>10)

Program as;                                                        Блок-схема

Uses crt;

Var a,j:integer;

Writeln(‘Введи число^);

Readln(j);

For a:=10 to j do writeln(sqrt(a):5:2);

Readln;

end.

		A+1

Задание 3.Найти сумму квадратов всех целых чисел от 10 до 50

Program as;

Uses crt;

Begin clrscr;

For a:=10 to 50 do s:=sqr(a)+s;

Writeln(s);

Задание 4.Одна штука некоторого товара стоит 20 тенге. Напечатать таблицу стоимости 2,3…20 штук этого товара

Блок-схема

Program as;

Var a,b:integer;

Begin clrscr;

B:=20;

For a:=2 to 20 do writeln(a*b);

Readln;

end.

Задание 5. Найти произведение всех целых чисел от 1 до А (значение А вводится с клавиатуры; 1<=A<=20.

program as;                                                         Блок-схема.

uses crt;

begin clrscr;

p:=1;

readln(a);

for b:=1 to a do if (1<=a) and (a<=20) then

p:=p*a;

writeln(p);

readln;

end.  

 Ответ:256

Задание 6.Напечатать программу, печатающую таблицу значений функции y=cos2x на отрезке [0;1] с шагом h=0,1

Program as;                                               Блок-схема

Uses crt;  

Var y,x:real;

X:=0;

While x<=1 do begin y:=cos(2*x);

Writeln(y:5:2);

End;

End.

Задание 7.Напечатать программу, вычисления факториала

Program as;                                               Блок-схема

Uses crt;  

Var i,n:integer;

Begin clrscr;

Readln(n);

F:=1; i:=1;

While i<=n do begin f:=f*i;

end;

Writeln(‘факториал от^,n,^равен^,f);

End.

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

Program as;                                               Блок-схема

Uses crt;  

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.

Задание 9.Вычислить наибольший общий делитель двух натуральных чисел А и В.

Program as;                                               Блок-схема

Uses crt;  

Var a,b:integer;

Begin clrscr;

writeln(‘Введи 2 натур. Числа^);

readln(a,b);

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

 Else b:=b-a;

Readln;

End.

Задание10. Даны целые числа А и В (а>b).Определить: Результат целочисленного деления А на В, не используя стандартную операцию целочисленного деления

Program as;                                               Блок-схема

Uses crt;  

Var a,b,n:integer;

Begin clrscr;

writeln(‘Введи 2 числа,a>b^);

readln(a,b);

While a<=b do begin

 N:=n+1;

A:=a-b;

End;

Writeln(‘результат=^,n);

Readln;

End.

Задание11.Напишите программу, которая вводит целые числа с клавиатуры и складывает их, пока не будет введено число 0

Program as;                                     Блок-схема

Uses crt;

Var N,s:integer;

S:=0;

Repeat write (‘Введи число^);

S:=s+n;

Until n=0;

Writeln(‘S=^,s);

Readln;

End.

Задание12. Напечатайте 20 первых степеней числа 2

Program as;                                     Блок-схема

Uses crt;

Var N,s:longint;

Repeat s:=s*2;

Write(s,^ ‘);

 N:=n+1;

Until n>20;

Readln;

End.

Задание13. Известны оценки по информатике 20 учеников класса. В начале списка перечислены все пятерки, затем все остальные оценки. Сколько учеников имеют по инфор-ке оценку «5»?

Program as; Блок-схема

Uses crt;

Var x,n:integer;

Begin clrscr;

Write(‘Введи оценку^);

Readln(x);

N:=0;

N:=n+1;

 Write(‘Введи оценку^);

 Readln(x);

End;

Writeln(‘имеют отлично^,n,^учеников^);

End.

Задание14.Вывести на экран таблицу умножения.

Program as; Блок-схема

Uses crt;

Var I,j:integer;

For i:=1 to 9 do

 For j:=1 to 9 do writeln(I,*,j,^ ‘,i*j);

Readln;

Задание15.Составить программу, печатающую на экране все четные числа в диапазоне от 100 до 999.

Program as;  Блок-схема

Uses crt;

Var a:integer;

For a:=100 to 999 do

 If a mod 2=0 then writeln(a);

End.

Массивы

Задание 1.Создать одномерный массив и найти сумму четных элементов и произведение нечетных элементов

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(8);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

for i:=1 to 5 do

if a[i] mod 2=0 then

s:=s+a[i]; writeln;

p:=1;

for i:=1 to 5 do

if a[i] mod 2<>0 then p:=p*a[i];

writeln;

writeln(s);

writeln(p);

end.

Задание 2.Составить программу формирования одномерного массива и вычисления произведения всех элементов массива

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(8);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

p:=1;

for i:=1 to 5 do p:=p*a[i];

writeln(p); end.

Задание 3.Дан одномерный массив вычислить произведение всех четных элементов массива

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(8);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

p:=1;

for i:=1 to 5 do if a[i] mod 2=0 then p:=p*a[i];

writeln(p);

end.

Задание 4.Дан массив вычислить сумму всех элементов больше 5

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(88);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

for i:=1 to 5 do if a[i]>5 then p:=p+a[i];

writeln(p);

readln;

end.

Задание 5.Подщитать кол-во элементов равных 7

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 7 do a[i]:=random(88);

for i:=1 to 7 do begin

writeln;

for i:=1 to 7 do write(a[i]:5);

end;

writeln;

for i:=1 to 7 do if a[i]=7 then p:=p+1;

writeln(p);

readln;

end.

Задание 6. Дан массив умножить все элементы на 20

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 7 do a[i]:=random(88);

for i:=1 to 7 do begin

writeln;

for i:=1 to 7 do write(a[i]:5);

end;

writeln;

for i:=1 to 7 do

write(a[i]*20:3);

readln;

end.

Задание 7. Дан массив все четные элементы заменить на 2, а не четные удвоить

program as;

uses crt;

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

i,s,p:integer;

begin clrscr;

for i:=1 to 7 do a[i]:=random(88);

for i:=1 to 7 do begin

writeln;

for i:=1 to 7 do write(a[i]:5);

end;

writeln;

for i:=1 to 7 do if a[i] mod 2=0 then writeln(sqr(a[i]));

for i:=1 to 7 do if a[i] mod 2<>0 then writeln(2*a[i]);

readln;

end.

Задание 8. Дан одномерный массив найти максимальный элемент

program as;

uses crt;

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

i,max:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

max:=1;

for i:=1 to 15 do if a[i] >a[max] then max:=i;

writeln(a[max]);

readln;

end.

Задание 9. Дан одномерный массив найти min элемент

program as;

uses crt;

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

i,min:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

min:=1;

for i:=1 to 15 do if a[i]

writeln(a[min]);

readln;

end.

Задание10. Дан массив скопировать все его элементы в другой массив такого же элемента

program as;

uses crt;

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

I,b:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

for i:=1 to 15 do a[i]:=b[i];

for i:=1 to 15 do write(a[i]);

writeln(‘скопир^);

for i:=1 to 15 do write(b[i]:4);

readln;

end.

Задание11. Составить программу обмена первого и третьего элем. строки матрицы

program as;

uses crt;

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

I,b,c:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

c:=a[1];

a[1]:=a[3];

a[3]:=c;

for i:=1 to 15 do write(a[i]:5);

end.

Задание12. Дан 2 мерный массив. Вывести на экран все элементы второй строки

program as;

uses crt;

var a:array[1..4,1..4] of integer;

i,j:integer;

begin clrscr;

for i:=1 to 4 do

for j:=1 to 4 do a[i,j]:=random(99);

for i:=1 to 4 do begin

writeln;

for j:=1 to 4 do write(a[i,j]:5);

end;

writeln;

writeln;

for j:=1 to 4 do write(a[2,j]:3);

end.

Задание13. Дан одномерный массив. Поменять содержимое двух произвольных ячеек

program as;

uses crt;

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

i,k,m:integer;

begin clrscr;

writeln;

for i:=1 to 10 do a[i]:=random(99);

for i:=1 to 10 do write(a[i]:5);

writeln;

writeln;

k:=a[2];

a[2]:=a[4];

a[4]:=k;

for i:=1 to 10 do write(a[i]:5);

end.

Задание14. Дан 2 мерный массив. Заменить все элементы кратные 5, нулями

program as;

uses crt;

var a:array[1..5,1..5] of integer;

i,j,s:integer;

begin clrscr;

for i:=1 to 5 do

for j:=1 to 5 do a[i,j]:=random(6);

for i:=1 to 5 do begin

writeln;

for j:=1 to 5 do write(a[i,j]:5);

end;

writeln;

for i:=1 to 5 do

for j:=1 to 5 do begin

if a[i,j] mod 5=0 then a[i,j]:=0;

end;

for i:=1 to 5 do begin writeln;

for j:=1 to 5 do write(a[i,j]:5);

end;

end.

Задание15. Дан массив вычислить сумму всех элементов больше 20

program as; end;

uses crt;  writeln;

var a:array[1..10] of integer; for i:=1 to 10 do if a[i]>20 then p:=p+a[i];

i,s,p:integer;  writeln(p);

begin clrscr;  readln;

for i:=1 to 10 do a[i]:=random(88); end.

for i:=1 to 10 do begin

writeln;

for i:=1 to 10 do write(a[i]:5);

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

Задание 1. Составить программу вычисления числа сочетания C= n!(n-m)!

program as;

uses crt;

var m,n,p1,p2,p3:integer;

c:real;

procedure factor(x:integer; var p:integer);

var i:integer;

begin p:=1;

for i:=1 to x do p:=p*i;

end;

begin clrscr;

writeln("Vvedi m,n");

readln(m,n);

factor(m,p1);

factor(n,p2);

factor(n-m,p3);

c:=p1/(p2*p3);

writeln(c:5:2);

end.

Задание 2. Составить программу нахождения меньшего из 5 заданных чисел, используя процедуру нахождения меньшего из 2 заданных чисел

Program as;

Uses crt;

Var a,b,c,d,e,z1,z2,z3,z4,z5:integer;

Procedure min(x,y:integer; var z:integer);

Begin;

If x

Writeln(z);

End;

Begin clrscr;

Readln(a,b,c,d,e);

Min(a,b,z1);

Min(z1,c,z3);

Min(z3,d,z4);

Min(z4,e,z5);

End.

Задание 3. Написать программу нахождения суммы большего и меньшего из 3 заданных чисел

Program as;

Uses crt;

Var a,b,c,d,v,v1,max,max1,min,min1:integer;

Procedure ma(x,y,z:integer; var v:integer);

Begin clrscr;

If x

If max

If x>y then min:=x else min:=y;

If min>z then min1:=min else min1:=z;

V:=min1+max1;

End;

Begin clrscr;

Readln(a,b,c);

Ma(a,b,c,v1);

Writeln(v1);

End.

Задание 4. Составить программу вычисления суммой фактор. всех четных чисел от m до n

program as;

uses crt;

var a,b,c,n,m,s,k,p1,p:integer;

procedure factor(x:integer; var p:integer);

var i:integer;

begin p:=1;

for i:=1 to x do begin p:=p*I; end;

writeln(p);

end;

begin clrscr;

writeln(‘ Vvedi n,m^);

readln(n,m);

for k:=n to m do if k mod 2=0 then begin

factor(k,p1);

s:=s+p1;

end;

writeln(s);

end.

Задание 5. Даны 5 чисел, найти их наибольший общий делитель, используя процедуру. Для алгоритма их вида

program as;

uses crt;

var a,b,c,d,e,z1,z2,z3,z:integer;

procedure E(x,y:integer; var z:integer);

begin

while x<>y do if x>y then x:=x-y

else y:=y-1;

z:=x;

end;

begin clrscr;

writeln(‘ Vvedi a,b,c,d,e^);

readln(a,b,c,d,e);

E(a,b,z);

E(c,d,z1);

E(z,z1,z2);

E(z2,e,z3);

writeln(z3);

end.

 M!

Задание 6. Составить программу вычисления числа сочетания C= n!(n-m)! с помощью функции

program as;

uses crt;

var f1,f2,f3,m,m1,n:integer;

c:real;

Function factor(n:integer):integer;

var p,i:integer;

begin p:=1;

for i:=1 to n do p:=p*i;

factor:=p;

end;

begin

read(m, n);

f1:=factor(m);

f2:=factor(n);

m1:=n-m;

f3:=factor(m1);

c:=f1/(f2*m1);

writeln(c:5:2);

end.

Задание 7. Найти НОК двух чисел по формуле НОК(a,b)=НОД

Program as;

Uses crt;

Var m, n,z,nod,a,nok:integer;

Procedure F (a,b:integer; var nod:integer);

Begin

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

Nod:=a;

End;

Begin clrscr;

Readln(m,n);

F (m,n,z);

Nok:= trunk (z/(m*n));

Writeln(nok);

End.

Задание 8. Трехугольник задан с координ. своих вершин. Составить программу вычисления его периметра

Program as;

Uses crt;

Var a1,a2,c1,c2,b1,b2:integer;

d1,d2,d3,d:real;

c,p:real;

procedure F(x1,x2,y1,y2:integer; var d:read);

begin

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

writeln(d:5:2);

end;

begin clrscr;

readln(a1,a2,b1,b2,d1,d2);

F(a1,a2,c1,c2,d1);

F(c1,c2,b1,b2,d2);

F(d1,d2,a1,a2,d3);

P:=d1+d2+d3;

Writeln(p:8:5);

End.

Задание 9. Увеличить вдвое все элементы массива

program as;

const          n=10; m=20;

type T1 = array[1..n] of integer;

T2 = array[-m..m] of integer;

var    A: T1;         B: T2;         k: integer;

Procedure Double(var X: array of integer);

var i: byte;

begin

for i:=0 to High(X)-1 do X[i]:=X[i]*2;

end;

begin

for k:=1 to n do read(A[k]);

for k:=-m to m do read(B[k]);

Double(A);

Double(B);

Double(k);

writeln("k=",k);

for k:=1 to n do write(A[k]," ");

writeln;

for k:=-m to m do write(B[k]," ");

end.

Задание 10. Использование типизированных констант

program typed_const;

var N:integer;

procedure Test;

const k:integer=1;

begin

if k

begin

writeln(k,"-й вызов процедуры");

k:=k+1;     

Test;

end

else writeln("последний вызов процедуры");

end;

begin

read(N);

if N>0 then Test;

end.

Задание 11. Вычислить N-е число Фиббоначчи

program Fib;

var n:byte;

function F(k:byte):word;

begin

if k<2 then F:=1 else F:=F(k-1)+F(k-2);

end;

begin

write("введите номер числа Фиббоначчи ");

readln(N);

writeln(N,"-е число Фиббоначчи =",F(N));

readln

end.

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

program as;

uses crt;

var a,b,c,d,e,z1,z2,z3,z:integer;

procedure E(x,y:integer; var z:integer);

begin

while x<>y do if x>y then x:=x-y

else y:=y-1;

z:=x;

end;

begin clrscr;

writeln(‘ Vvedi a,b,c,d,e^);

readln(a,b,c,d,e);

E(a,b,z);

E(c,d,z1);

E(z,z1,z2);

E(z2,e,z3);

writeln(z3);

end.

Задание13. Трехугольник задан с координ. своих вершин. Составить программу вычисления его периметра

Program as;

Uses crt;

Var a1,a2,c1,c2,b1,b2:integer;

d1,d2,d3,d:real;

c,p:real;

procedure F(x1,x2,y1,y2:integer; var d:read);

begin

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

writeln(d:5:2);

end;

begin clrscr;

readln(a1,a2,b1,b2,d1,d2);

F(a1,a2,c1,c2,d1);

F(c1,c2,b1,b2,d2);

F(d1,d2,a1,a2,d3);

P:=d1+d2+d3;

Writeln(p:8:5);

End.

Задание14. Составить программу для вычисления определенного интеграла

tk

2t

I= S--------------- dt

sqrt(1-sin2t)

tn

вычисляется по формуле:

ISimps=2*h/3*(0.5*F(A)+2*F(A+h)+F(A+2*h)+2*F(A+3*h)+...

+2*F(B-h)+0.5*F(B))

Program INTEGRAL;

type

Func= function(x: Real): Real;

var

I,TN,TK:Real;

N:Integer;

{$F+}

Function Q(t: Real): Real;

begin

Q:=2*t/Sqrt(1-Sin(2*t));

end;

{$F-}

Procedure Simps(F:Func; a,b:Real; N:Integer; var INT:Real);

var

sum, h: Real;

j:Integer;

begin

if Odd(N) then N:=N+1;

h:=(b-a)/N;

sum:=0.5*(F(a)+F(b));

for j:=1 to N-1 do

sum:=sum+(j mod 2+1)*F(a+j*h);

INT:=2*h*sum/3

end; begin WriteLn(" ВВЕДИ TN,TK,N");

Read(TN,TK,N);

Simps(Q,TN,TK,N,I);

WriteLn("I=",I:8:3)

end.

Задание15. Записать отрезок -X(-1,-10), с помощью функции

program as;

function A(x:integer):integer;

begin

a:=-x;

end;

var i:integer;

begin

for i:=1 to 10 do writeln(a(i));

end.

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

Задание 1. Дан текстовый файл, посчитать кол-во строк в нем

Program as;

Uses crt;

Var F:text; a:string; s:integer;

Begin clrscr;

Assign (f,^a1.txt^);

Reset (f);

While not (eof(f)) do begin

Readln(f,a);

S:=s+1; end;

Close(f);

Writeln(s);

End.

Задание 2. Создать текстовый файл и записать в него фразу: «Здравствуй Мир!»

Program as;

Uses crt;

Var F:text; a:string;

Begin clrscr;

Assign (f,^a.txt^);

Rewrite (f);

Readln(a);

Writeln(f,a);

Close(f);

End.

Задание 3. Создать текстовый файл и записать в него слово «Привет»

Program as;

Uses crt;

Var F:text; a:string;

Begin clrscr;

Assign (f,^A.txt^);

Rewrite (f);

Readln(a);

Writeln(f,a);

Close(f);

End.

Задание 4. Создать текстовый файл и записать в него 5 одинаковых чисел

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,^text.txt^);

Rewrite (f);

For i:=1 to 5 do

Writeln(f,5);

Close(f);

End.

Задание 5. Создать текстовый файл и записать в него все числа от 10 до 16

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,^text.txt^);

Rewrite (f);

For i:=10 to 16 do

Writeln(f,i);

Close(f);

End.

Задание 6. Создать текстовый файл и записать в него 5 одинаковых слов

Program as;

Uses crt;

Var F:text; a:string;

Begin clrscr;

Assign (f,^A.txt^);

Rewrite (f);

Readln(a);

Writeln(f,a);

Close(f);

End.

Задание 7. Дан текстовый файл перенести его строки в другой файл

Program as;

Uses crt;

Var f,t:text; a:string;

Begin clrscr;

Assign(f,^202as.txt^); assign(t,^201as.txt^);

Reset(f); rewrite(t);

While not(eof(f)) do begin

Readln(f,a);

Writeln(t,a);

End;

Close(f);

Close(t);

Readln;

End.

Задание 8. Имеется текстовый файл, напечатать все его строки начиная с буквы Т

Program as;

Uses crt;

Var f:text; a:string;

Begin clrscr;

Assign(f,^202as.txt^);

Reset(f);

While not(eof(f)) do begin

Readln(f,a);

If copy (a,1,1)=^T^ then

Writeln(a);

End;

Close(f);

Readln;

End.

Задание 9. Имеется текстовый файл посчитать кол-во строк начинающихся на букву А

Program as; readln(f,a);

Uses crt; if copy(a,1,1)=^A^ then k:=k+1;

Var F:text; a:string; k:integer; end;

Begin clrscr;  close(f);

Assign(f,^abc.txt^); writeln(k);

Reset(f); end.

While not(Eof(f)) do begin

Задание10. Все четные строки этого файла записать во 2 файл, а не четные в 3 файл

Program as;

Uses crt;

Var F,t,g:text; a:string; k:integer;

Begin clrscr;

Assign(f,^abc.txt^); assign(t,^cop.txt^); Assign(g,^cap.txt^);

Reset(f); rewrite(t); rewrite(g);

While not(Eof(f)) do begin

Readln(f,a);

K:=k+1;

If k mod 2=0 then writeln(t,a) else writeln(g,a);

End;

Close(f); close(t); close(g);

End.

Задание11. Найти сумму элементов одномерного массива рез-т записать в текстовый файл

Program as;

Uses crt;

Var f:text; a:array[1..10] of integer; i,s:integer;

Begin clrscr;

Writeln(‘Ввод массива^);

Assign(f,^abc.txt^); rewrite(f);

For i:=1 to 10 do begin write(‘Введи^,I,^ элемент массива^);

Readln(a[i]);

End;

Writeln;

For i:=1 to 10 do s:=s+a[i];

Writeln(f,s);

Close(f);

End.

Задание12. Создать текстовый файл и записать в него все числа от 5 до 25

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,^text.txt^);Rewrite (f);

For i:=5 to 25 do

Writeln(f,i);

Close(f);

End.

Задание13. Дано слово удвоить его каждую букву и записать его в текст. файл

Program as;

Uses crt;

Var f:text; a:string; I,s:integer;

Readln(a);

For i:=1 to length (a)*2 do begin insert

Copy(a,I,1),a,i);

I:=i+1;

End;

Writeln(f,a);

Close(f);

End.

Задание14. Имеется текстовый файл посчитать кол-во строк начинающихся на букву М

Program as;

Uses crt;

Var F:text; a:string; k:integer;

Begin clrscr;  

Assign(f,^abc.txt^);

Reset(f);

While not(Eof(f)) do begin

readln(f,a);

if copy(a,1,1)=^М^ then k:=k+1;

end; close(f);

writeln(k);

end.

Задание 15. Создать текстовый файл и записать в него 6 одинаковых чисел

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,^text.txt^);

Rewrite (f);

For i:=1 to 6 do

Writeln(f,6);

Close(f);

End.

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

Задание 1. Составить список учебной группы, включающей 25 человек. Для каждого учащегося указать дату рождения, год поступления в техникум, курс, группу, оценки каждого года обучения. Информацию о каждом учащемся оформить в программе в виде записи. Совокупность записей объединить в массив.

Составить программу, которая обеспечивает ввод полученной информации, распечатку ее в виде таблицы, а также распечатку информации о отличниках

Program Pascal;

Uses crt;

type student=record

fio: string;

d_r:1..31;  {день рождения}

m_r:1..12; {месяц рождения}

god_r:1965..1975; {год рождения}

god_p:2004..2008;  {год поступления}

group:string; {название группы}

ocenki:array[1..3,1..5] of integer; {оценки по трем предметам}

end;

var

s1: array[1..25] of student;

i,j,x:integer;

ch:char;

f:boolean;

begin

clrscr;

for i:=1 to 25 do begin

writeln("Сведения о ",i," студенте");

with s1[i] do begin

write("ФИО:");readln(fio);

write("Дата рождения:.. г.");

x:=wherex;

gotoxy(x-13,wherey); read(d_r);

gotoxy(x-10,wherey-1); read(m_r);

gotoxy(x-7,wherey-1); read(god_r);

if keypressed then begin

ch:=readkey;

if ch=#0 then ch:=readkey;

end;

write("Год поступления: ");readln(god_p);

write("Группа: ");readln(group);

j:=0;

for i:=god_p to 2008 do begin

j:=j+1;

writeln("Оценки за ",i," год:");

write("Математика: ");readln(ocenki[1,j]);

write("Информатика: ");readln(ocenki[2,j]);

write("История: ");readln(ocenki[3,j]);

end;

end;

writeln;

end;

writeln("список отличников");

for i:=1 to 25 do begin

with s1[i] do begin

j:=0;

f:=true;

for i:=god_p to 2008 do begin

j:=j+1;

if not((ocenki[1,j]=5) and (ocenki[1,j]=5) and (ocenki[1,j]=5)) then f:=false;

end;

if f=true then writeln(fio,", группа ",group,", год поступления ",god_p);

end;

end;

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

readln;

end.

Задание 2. Разработать программу формирования файла, содержащего сведения о студентах. Каждый элемент этого файла должен содержать следующие данные: номер группы; номер в группе по списку; фамилию, имя, отчество; год рождения; оценки за последнюю сессию

Program Pascal;

Uses crt;

Const fname="students.dat";

n=5; {количество предметов за последнию сессию}

Type st=record

n_group:integer; {номер группы}

n_sp:integer;  {номер в группе по списку}

fam:string; {фамилия}

im:string; {имя}

ot:string; {отчество}

god_r:integer; {год рождения}

oc:array [1..n] of integer; {оценки за последнию сессию}

end;

Var t:array[1..30] of st;

i,ch,j:integer;

h: file of st;

begin

write("Введите количество студентов в группе: "); readln(ch);

for i:=1 to ch do begin

writeln("Сведения о ",i," студенте");

write("Номер группы: "); readln(t[i].n_group);

write("Номер в группе по списку: "); readln(t[i].n_sp);

write("Фамилия: "); readln(t[i].fam);

write("Имя: "); readln(t[i].im);

write("Отчество: "); readln(t[i].ot);

write("Год рождения: "); readln(t[i].god_r);

writeln("Оценки за последнию сессию: ");

for j:=1 to n do begin

case j of

1:write("Математика: ");

2:write("Физика: ");

3:write("Химия: ");

4:write("Культурология: ");

5:write("История: ");

end;

readln(t[i].oc[j]);

if not ((t[i].oc[j]>0) and (t[i].oc[j]<=5)) then begin

writeln("Неверно введена оценка! Повторите ввод.");

j:=j-1;

end;

end;

writeln;

end;

Assign (h,fname);

{$I-}

reset(h);

If Ioresult<>0 then rewrite(h);

{$I+}

for i:=1 to ch do write(h,t[i]);

close(h);

writeln("Данные занесены в файл ",fname);

readln;

end.

Задание 3. В ГИБДД имеется следующая информация об автомобилях и их владельцах:

а) марка машины;

б) номер машины;

в) Фамилия владельца.

Необходимо организовать поиск количества автомобилей определенной марки. Информацию об автомобилях и их владельцах оформить в виде записей, хранимых в файле. Ввод данных в запись и сохранение записи в файле

Program N10_1;

Uses Crt;

Const fname="spisok.dat";

{Имя файла, в который будет производиться запись}

Type Person=record

marka:string;

number:string;

familia:string;

end;

Var auto:array[1..5] of person;

i:integer;

h: file of person;

begin

Clrscr;

auto[1].marka:="Мерседес";

auto[1].number:="235";

auto[1].familia:="Иванов";

auto[2].marka:="Мерседес";

auto[2].number:="289";

auto[2].familia:="Петров";

auto[3].marka:="Волга";

auto[3].number:="365";

auto[3].familia:="Сидоров";

auto[4].marka:="Жигули";

auto[4].number:="896";

auto[4].familia:="Кузнецов";

auto[5].marka:="Вольво";

auto[5].number:="957";

auto[5].familia:="Тимофеев";

Assign (h,fname);

{$I-}

reset(h);

If Ioresult<>0 then rewrite(h);

{$I+}

for i:=1 to 5 do begin

write(h,auto[i]);

end;

writeln("Данные занесены в файл ",fname);

write("Нажмите Enter");

readln;

end.

Выполнение задания

Program N10_2;

Uses Crt;

Const fname="spisok.dat";

Type Person=record

marka:string;

number:string;

familia:string;

end;

Var auto:array[1..5] of person;

i,j,l,q:integer;

h: file of person;

s:string;

f:boolean;

begin

Clrscr;

Assign (h,fname);

Reset (h);

i:=0;

While Eof (h) = false do begin

i:=i+1;

Read(h,auto[i]);

end;

Close(h);

writeln("Информация, считанная из файла ",fname);

writeln;

q:=i;

for j:=1 to q do begin

with auto[j] do begin

gotoxy(1,wherey);

write(marka);

gotoxy(15,wherey);

write(number);

gotoxy(20,wherey);

writeln(familia);

end;

end;

writeln;

write("Введите интересующую Вам марку автомобиля: ");

readln(s);

writeln;

l:=0;

for j:=1 to q do begin

with auto[j] do begin

if marka=s then begin

l:=l+1;

gotoxy(1,wherey);

write(number);

gotoxy(10,wherey);

writeln(familia);

end;

end;

end;

writeln("Количество автомобилей данной марки - ",l);

write("Нажмите Enter");

readln;

end.

Задание 4. На телефонном узле в конце каждого квартала составляется на каждого абонента ведомость оплаты междугородных телефонных разговоров (с 7-ю городами) в течение квартала (3 месяца)

Написать программу, которая вводит исходные данные, выполняет расчеты и выводит на экран:

ü  Исходные данные в виде таблицы, где указаны коды городов, с которыми велись разговоры, общее время разговора с каждым городом за один месяц, стоимость одной минуты разговора (меняется каждый месяц);

ü  Общая продолжительность разговоров с каждым городом за квартал;

ü  Плата за каждый месяц;

ü  Общая плата за 3 месяца;

ü  Город с наибольшей платой.

program kursovik;

uses crt;

type

telef=record

kod:integer;

tpm1,tpm2,tpm3,price1,price2,price3:integer;

end;

telef1=record

kod,tpm,ob:integer;

pr1,pr2,pr3:integer;

end;

var

a:file of telef;

res:array[1..7] of telef1;

i,j,s,aa,max:integer;

begin;

textbackground(10);

clrscr;

textcolor(0);

gotoxy(15,2);

writeln("Курсовая работа студента группы 01М22 Белоусовой Е.В.");

gotoxy(27,3);

writeln("Задание на курсовую работу:");

textcolor(4);

writeln;

writeln(" На телефонном узле в конце каждого квартала составляется на каждого абонента");

writeln("ведомость оплаты междугородных телефонных разговоров (с 7-ю городами) в течение");

writeln("квартала (3 месяца).");

writeln(" Написать программу, которая вводит исходные данные, выполняет расчеты и ");

writeln("выводит на экран:");

writeln(" - исходные данные в виде таблицы, где указаны коды городов, с которыми велись");

writeln(" разговоры, общее время разговора с каждым городом за один месяц, стоимость");

writeln(" одной минуты разговора (меняется каждый месяц);");

writeln(" - общая продолжительность разговоров с каждым городом за квартал;");

writeln("плата за каждый месяц;");

writeln("общая плата за 3 месяца;");

writeln("город с наибльшей платой.");

gotoxy(27,18);

textcolor(0);

writeln("Требование к вводу информации");

textcolor(4);

writeln(" - исходные данные вводятся с клавиатуры.");

textcolor(0);

writeln;

writeln(" Требование к выводу результатов");

textcolor(4);

writeln(" - результат выводятся на экран.");

textcolor(14);

writeln;

writeln(" Для продолжения работы программы нажмите ENTER");

readln;

clrscr;

textcolor(0);

writeln(" Требования к структуре программы ");

textcolor(4);

writeln(" Программа должна состоять из следующих частей:");

writeln(" - вывод заставки с информацией о студенте и задании;");

writeln(" - ввод данных (выполняется в диалоговом режиме);");

writeln(" - вывод исходных данных и результатов (на один экран).");

textcolor(0);

writeln(" Требования к размещению исходных данных внутри программы ");

textcolor(4);

writeln(" Исходные данные располагаются в файле, компонентами которого являются записи.");

writeln("Структура каждой записи и типы ее полей выбираются в зависимости от задания.");

textcolor(0);

writeln(" Используемые цвета ");

textcolor(4);

writeln(" - черный(0),красный(4), светло-зеленый(10), желтый(14)");

textcolor(14);

gotoxy(18,24);

writeln("Для продолжения работы программы нажмите ENTER");

readln;

clrscr;

assign(a,"kurs.dat");

rewrite(a);

textcolor(0);

for i:=1 to 7 do

begin

write("Введите код ",i,"-го города: ");

readln(tel.kod);

write("Введите общее время разговора с городом ",tel.kod," за 1-й месяц: ");

readln(tel.tpm1);

write("Введите стоимость одной минуты разговора с городом ",tel.kod," в 1-м месяце: ");

readln(tel.price1);

write("Введите общее время разговора с городом ",tel.kod," за 2-й месяц: ");

readln(tel.tpm2);

write("Введите стоимость одной минуты разговора с городом ",tel.kod," в 2-м месяце: ");

readln(tel.price2);

write("Введите общее время разговора с городом ",tel.kod," за 3-й месяц: ");

readln(tel.tpm3);

write("Введите стоимость одной минуты разговора с городом ",tel.kod," в 3-м месяце: ");

readln(tel.price3);

write(a,tel);

end;

close(a);reset(a);

s:=1;

while not eof(a) do begin

read(a,tel);

res[s].kod:=tel.kod;

res[s].tpm:=tel.tpm1+tel.tpm2+tel.tpm3;

res[s].pr1:=tel.tpm1*tel.price1;

res[s].pr2:=tel.tpm2*tel.price2;

res[s].pr3:=tel.tpm3*tel.price3;

res[s].ob:=res[s].pr1+res[s].pr2+res[s].pr3;

s:=s+1;

end;close(a);

clrscr;

writeln("Код города Общее время разговора за каждый месяц Стоимость минуты разговора");

reset(a);

while not eof(a) do

begin

read(a,tel);

writeln(" ",tel.tpm1," ",tel.price1);

writeln(" ",tel.kod," ",tel.tpm2," ",tel.price2);

writeln(" ",tel.tpm3," ",tel.price3);

end;

textcolor(14);

gotoxy(18,24);

writeln("Для продолжения работы программы нажмите ENTER");

readln;

clrscr;

textcolor(0);

writeln("Код города Общее время разговора за квартал Плата за месяц Общая плата");

for i:=1 to 7 do

begin

aa:=res[i].kod;

writeln(" ",res[i].pr1);

writeln(" ",aa," ",res[i].tpm," ",res[i].pr2," ",res[i].ob);

writeln(" ",res[i].pr3);

end;

max:=res[1].ob;

for i:=1 to 6 do begin

if res[i+1].ob>max then

begin

max:=res[i+1].ob;

j:=i+1;

end;

end;

writeln("Город с наибольшей платой: ",res[j].kod);

textcolor(14);

gotoxy(18,24);

writeln("Для завершения работы программы нажмите ENTER");

readln;

end.

Задание 5 Упорядочить список студентов по среднему балу и распечатать его

Program spisok_grupp;

Uses Crt;

Const kurs=3;

Const kol=5;

Type

sved=record

famil:string[25];

datar:string[8];

god: integer;

gruppa: integer;

ocenki:array[1..3,1..5] of integer;

srball:array[1..25] of real;

End;

Var

spisok: array[1..25] of sved;

i,i1,j, s,mesto,n,g:integer;

max,t:real;

q:string[25];

Begin

ClrScr;

writeln("Введите количество учеников");

readln(n);

for i:=1 to n do

With spisok[i] do

Begin

Writeln ("Фамилия ",i," студента");

Readln (famil);

Writeln("Дата рождения");

Readln (datar);

Writeln ("Год поступления");

Readln (god);

Writeln ("Группа");

Readln (gruppa);

s:=0;

for i1:=1 to kurs do

begin

writeln("Оценки ",i1," года");

for j:=1 to kol do

Begin

Writeln (j," Предмет");

Readln (ocenki[i1,j]);

s:=s+ocenki[i1,j];

End;

end;

srball[i]:=s/(kol*kurs);

ClrScr;

End;

writeln("Фамилия":8,"Дата рождения":16,"Год поступления":18,"Курс":7,"Группа":8);

for i:=1 to n do

begin

with spisok[i] do write(famil:8,datar:16,god:18,kurs:7,gruppa:8);

writeln;

writeln;

for g:=1 to kurs do

begin

write(g," год:");

for j:=1 to kol do

with spisok[i] do write(ocenki[g,j]:4);

writeln;

end;

with spisok[i] do writeln("Средний бал =",srball[i]:6:2);

writeln;

end;

writeln;

writeln("По порядку");

for j:=1 to n do

Begin

max:=spisok[j].srball[j];

mesto:=j;

for i:=j to n do

if spisok[i].srball[i]<=max then

Begin

max:=spisok[i].srball[i];

mesto:=i;

End;

t:=spisok[j].srball[j];

spisok[j].srball[j]:=spisok[mesto].srball[mesto];

spisok[mesto].srball[mesto]:=t;

q:=spisok[j].famil;

spisok[j].famil:=spisok[mesto].famil;

spisok[mesto].famil:=q;

with spisok[j] do writeln(famil:8,srball[j]:6:2);

End;

End.

Задание 6. Запись с вариантами

var R = Record

rem: string;

Case byte of

3: (n:integer);

5: (x,y,z:char);

"a": (i,j:byte);

end;

begin

R.rem:="запись с ваpиантами";

R.n:=25000;

write(R.i,R.x,R.j,R.y); {168и97a}

{ord("и")=168, ord("a")=97, 168+97*256=25000}

end.

Задание 7. Пример объявления типа запись

type Men = Record

FIO,Adress: string;

Year: byte;

End;

var A,B: Men;

begin

A.FIO:="Иванов И.И.";

A.Adress:="пp. Ленина, д. 40, кв. 10";

A.Year:=1981;

end.

Задание 8. Составить программу в которой известны Фамилия, адрес и номера Телефонов 15 человек, организовать поиск номера телефона по фамилии абонента

Program as;

Type

person=record

surname: string[40]

adres: string[20]

nomer: integer

var

mas:array[1..15] of person;

i:integer; poisk: string;

procedure Input.date;

var

begin

writeln(‘Введи данные^,I,^ абонента^);

writeln(‘Фамилия^);

readln(mas[i].surname);

writeln(‘адрес^);

readln(mas[i].adres);

writeln(‘Номер телефона^);

readln(mas[i].nomer);

end;

Procedure write date;

Begin

With mas[i] do

Begin

Writeln(‘фамилия^,surname);

Writeln(‘адрес^,adres);

Writeln(‘номер^,nomer);

End;

End;

Begin

For i:=1 to 15 do Input.date;

Writeln(‘Введи фамилию абонента^);

Readln(poisk);

For i:=1 to 15 do

If mas[i] nomer=poisk then write date;

End.

Задание 9. Создать список учеников класса и вывести на экран Фамилии и Имена в виде таблицы

Program as;

Uses crt;

Type

Klass=record

Surname:string[15];

Name:string[10];

End;

Var A:array [1..10] of klass;

I:integer;

Begin clrscr;

For i:=1 to 10 do begin

Writeln(‘введи фамилию^);

Readln(a[i].surname);

Writeln(‘введи имя^);

Readln(a[i].name);

End;

Writeln;

Clrscr;

For i:=1 to 10 do writeln(a[i].surname,^ ‘,a[i].name);

End.

Задание10. Известны данные о 6 сотрудниках фирмы Фамилия, возраст, и отношение к воен.службе. Вывести на экран фамилии всех военнообязанных сотрудников

Program as;

Uses crt;

Type

S=record

N:string[10]; voz:integer;

V:string[8];

End;

Var a:array[1..6] of s;

I:integer;

Begin clrscr;

For i:=1 to 6 do begin

Writeln(‘какая у тебя фамилия^);

Readln(a[i].s);

Writeln(‘сколько тебе лет^);

Readln(a[i].voz);

Writeln(‘ты относешся к военной части^);

Readln(a[i].v);

End; Writeln; Clrscr;

For i:=1 to 6 do if a[i].v=^DA^ then writeln(a[i].s);

End.

Задание11. Даны названия 6 городов и стран, среди них есть город находящийся в Италии напечатать их название

Program as;

Uses crt;

Type

S=record

strana: string[10];

gorod:string[8];

End;

Var a:array[1..6] of s;

I:integer;

Begin clrscr;

For i:=1 to 6 do begin

Writeln(‘страна?^);

Readln(a[i].strana);

Writeln(‘город^);

Readln(a[i]. gorod);

End; Writeln; Clrscr;

For i:=1 to 6 do if a[i]. strana =^italia^ then writeln(a[i].gorod);

End.

Задание12. Даны названия 10 стран и частей света. Напечатать на экране все страны находящиеся в Азии

Program as;

Uses crt;

Type

S=record

strana: string[10];

ch:string[8];

End;

Var a:array[1..10] of s;

I:integer;

Begin clrscr;

For i:=1 to 10 do begin

Writeln(‘страна^);

Readln(a[i].strana);

Writeln(‘часть света^);

Readln(a[i]. ch);

End; Writeln; Clrscr;

For i:=1 to 10 do if a[i]. ch =^Azia^ then writeln(a[i]. strana);

End.

Задание13. Из ведомости 3-х студентов с их оценками (порядковый номер, Ф.И.О. и три оценки) определить количество отличников и средний бал каждого студента

Program Spic;

Type wed = record {Тип wed включает 3 поля: n, fio, bal}

n: integer;

fio: string[40];

bal: array [1..3] of integer {Поле bal – массив из 3 оценок }

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,"..gi");

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:pgi ");

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: p7");

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

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.