Основные приемы работы в среде ТР — страница 2
Обновлено
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); {смотрим где находится пробел}