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

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); {смотрим где находится пробел}

Страницы: 1, 2, 3