1.

uses CRT;

{Andrey Sharov}

{web www.borlpasc.narod.ru}

const RUS:set of char=['А'..'П','Р'..'Я','а'..'п','р'..'я'];

ss='или';{искомое слово}

var N:integer;c:char;f:TEXT;S:string;

BEGIN

Assign(f,'temp.pas');{ имя тестируемого файла }

Reset(f);N:=0;c:=#0;

repeat

While (NOT EOF(f))and(NOT(c in RUS)) do

Read(f,c);{пропуск нерусских букв}

S:=c;

While (NOT EOF(f))and((c in RUS)) do begin

Read(f,c);

if c in RUS then S:= S + c;{выделение слова}

end;

if S=ss then inc(N);

until EOF(f);

WriteLn('Слово "',ss,'" встречается ',N,' раз !');

Close(f);

repeat until KeyPressed;

END.

2.

Program Generator_Zadaniy;

Var T : Text;

S : String;

I, N, Rez, B, C, D : Integer;

Begin

Assign(T, 'test.dat');

ReWrite(T);

Randomize;

Write('Сколько заданий сгенерировать? ');

ReadLn(N);

For I := 1 To N Do

Begin

Rez := 2 + Random(15);

B := (11 + Random(35));

C := Rez * B;

Repeat

D := 2 + Random(6)

Until Not Odd(D);

Write(T, '-', C Div 10);

If C Mod 10 <> 0 Then Write(T, ',', C Mod 10);

Write(T, ':', B Div 10);

If B Mod 10 <> 0 Then Write(T, ',', B Mod 10);

WriteLn(T, '+', 2 + Random(16), ',5·(-0,', D, ');')

End;

Flush(T);

Close(T)

End.

3.

Program AlphaBeta;

Var T : Text;

R : String;

Stroka, Slovo : String;

Sl : File Of String;

N : Integer;

{Процедура преобразования заглавных букв в слове в маленькие}

Procedure Preobr(Var S : String);

Var I : Byte;

Begin

For I := 1 To Length(S) Do

Begin

If Ord(S[I]) In [128..143]

Then S[I] := Chr(Ord(S[I]) + 32);

If Ord(S[I]) In [144..159]

Then S[I] := Chr(Ord(S[I]) + 80)

End

End;

{Процедура поиска слова в данной строке и занесение его в словарь}

Procedure Find(Var S : String);

Const Mn = ['А'..'Я', 'а'..'п', 'р'..'я'];

Var N, K : Integer;

S1, Slovo, X : String;

B : Boolean;

KK, Poz : Integer;

Begin

N := 1;

{Ищем начало слова}

While Not(S[N] In Mn) And (N <= Length(S)) Do

N := N + 1;

K := N;

{Ищем конец слова}

While (S[K] In Mn) And (K <= Length(S)) Do

K := K + 1;

S1 := Copy(S, N, K - N);

Preobr(S1);

{Ищем начало следующего слова}

While Not(S[K] In Mn) And (K <= Length(S)) Do

K := K + 1;

Delete(S, 1, K - 1); {Удаление найденного слова вместе с пробелами

и знаками препинания }

{Вставляем очередное слово в словарь}

ReSet(Sl);

B := True;

While Not Eof(Sl) And B Do

Begin

Read(Sl, Slovo);

B := S1 > Slovo

End;

If Eof(Sl)

Then Begin If B

Then Write(Sl, S1)

End

Else If S1 <> Slovo

Then

Begin

Poz := FilePos(Sl) - 1;

KK := FileSize(Sl) - 1;

While KK >= Poz Do

Begin

Seek(Sl, KK);

Read(Sl, X);

Write(Sl, X);

KK := KK - 1

End;

Seek(Sl, Poz);

Write(Sl, S1)

End

End;

{Основная программа}

Begin

Write('Введите имя файла: ');

ReadLn(R);

Assign(T, R);

Reset(T);

Assign(Sl, 'c:\tp7\Slovar.dat');

ReWrite(Sl);

Close(Sl);

While Not Eof(T) Do

Begin

ReadLn(T, Stroka);

WriteLn(Stroka);

While Length(Stroka) > 0 Do

Find(Stroka);

End;

Reset(Sl);

While Not Eof(Sl) Do

Begin

Read(Sl, Stroka);

WriteLn(Stroka);

End;

Close(Sl)

End.

4.

program bukva;

var a,m:set of char;

c:char;

fa,s:string;

f:text;

i,j:integer;

begin m:=['б','в','г','д','ж','з','л','м','н','р'];

a:=[];

writeln;

writeln('Ваш текст запишите в файл TEXT1.PAS.И вводите это имя файла');

write('Введите имя файла =>');readln(fa);

writeln;

assign(f,fa);reset(f);j:=1;

while not eof(f) do

begin

read(f,s);

for i:=1 to length(s) do

if (s[i] in m)

then begin a:=a+[s[i]];

i:=i+1;

j:=j+1;

end;

end;

for c:='б' to 'р' do

if c in a then writeln(c);

end.

5.

program p;

var f:text;

s:string;

i,j,k:integer;

m:set of char;

begin write('***************************************************');

assign(f,'e:\F11.txt');

reset(f);

m:=['а'..'я'];

writeln('Вот эти буквы:');

while not(eof(f)) do

begin readln(f,s);

for i:=1 to length(s) do

begin k:=0;

for j:=1 to length(s) do

if (s[i] in m)and(s[j] in m)and(s[i]=s[j])

then k:=k+1;

if k=1 then write(s[i],' ');

end;

end;

close(f);

end.

6.

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.

7.

program p;

var f:text;

g:file of string;

i,j,k,max:integer;

s,sl,s1,s2,smax:string;

function Srav(s1,s2:string):boolean;

const sr='АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';

var p:boolean;i,k:integer;

begin p:=false;k:=length(s1);I:=1;

if length(s2)<k then k:=length(s2);

if Pos(s1[1],sr)<Pos(s2[1],sr)

then p:=true;

while (s1[i]=s2[i]) and(i<=k)and not(p) do

begin if Pos(s1[i],sr)<Pos(s2[i],sr)

then p:=true;

i:=i+1

end;

Srav:=p;

end;

begin assign(f,'f0.Txt');assign(g,'g0.txt');

reset(f);k:=1;

rewrite(g);sl:='';

writeln;

while not(eof(f)) do

begin readln(f,s);

for i:=1 to length(s) do

begin if s[i]=' ' then begin if sl<>' '

then begin write(g,sl);

k:=k+1;

end;

sl:='';

end

else sl:=sl+s[i];

end;

if sl<>' ' then begin write(g,sl);

k:=k+1;

end;

sl:='';

end;

close(f);close(g);

reset(g);

while not(eof(g)) do

begin read(g,s);

write(s,' ')

end;writeln;

reset(g);

for i:=0 to k-2 do

begin reset(g);

seek(g,i);

read(g,s1);

max:=i;smax:=s1;

for j:=i+1 to k-2 do

begin seek(g,j);

read(g,s2);

if srav(s2,sMAX)

then begin max:=j;

smax:=s2

end;

end;;

seek(g,i);

write(g,smax);

seek(g,max);

write(g,s1);

end;

reset(g);

while not(eof(g)) do

begin read(g,s);

write(s,' ')

end;

end.

8.

program n3;

USES CRT;

var s,sl,r,p:string;

t:text;k,i:integer;

begin CLRSCR;k:=0;

write ('слово ');

readln(sl);

write ('в файл ');

readln(r);

assign(t,r);

reset(t);

while not eof(t) do

begin

readln(t,p);

s:='';

FOR I:=1 TO LENGTH(P) DO

BEGIN

IF (P[I]<>' ') AND (P[I]<>'.')

then S:=S+P[I]

else

IF S=SL THEN

begin

k:=k+1;

s:='';

end

else

s:='';

end;

end;

if k>0 then writeln (k) else writeln ('такого слова в тексте нет ')

end.

9.

program pr13c;

const sighnp=[' ','.',',','?','!',':'];

var f:text;

s,sl,slo,b,slovo,name:string;

l,t:integer;

function WordT(var s:string):string;

var k,i:integer;

begin s:=s+' ';k:=1;

while not(s[k] in sighnp) do inc(k) ;

if k>1

then begin WordT:=copy(s,1,k-1);

delete(s,1,k)

end

else WordT:=''

end;

begin write('Введите имя файла:');

readln(Name);

write('Введите букву:');

readln(b);

assign(f,name);

reset(f);slovo:='';l:=0;

WHILE NOT(EOF(F)) do

begin readln(f,s);

sl:=WordT(s);

while sl<>'' do

begin t:=0;

slo:=sl;

while pos(b,sl)>0 do

begin inc(t);

sl[pos(b,sl)]:=' '

end;

if t>l then begin l:=t;slovo:=slo end;

sl:=WordT(s)

end;

end;

writeln('Искомое слово:',slovo);

close(f);

readln

end.

10.

Program file3;

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

Var f3:text;

i,j,ch,sl:integer;

name:string;

s:char;

wrd :string;

Begin

writeln('введите имя файла');

readln(name);

assign(f3,name);

reset(f3);

s:=' ';

sl:=0;

ch:=0;

while not eof(f3) do

begin

readln(f3,wrd);

i:=1;

While i<=length(wrd) do

begin

if wrd[i]<>' ' then sl:=sl+1;

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

inc(i)

end;

end;

close(f3);

reset(f3);

while not eof(f3) do

begin

while not eoln(f3) do

begin read(f3,s);

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

end;

readln(f3);

end;

writeln('число слов: ',sl,' число цифр: ',ch);

close(f3);

End.

11.

program ;

var f1,f2,f3:text;

i,n,k,l:integer;

s,sout,ss,slovoT,slovo,sinonim:string;

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

assign(f2,'text2.txt');

assign(f3,'text3.txt');

rewrite(f1);

writeln('Введите текст:');

repeat readln(s);

writeln(f1,s)

until s='';

close(f1);

reset(f1);

rewrite(f3);

while not(eof(f1)) do

begin readln(f1,s);

s:=s+' ';

sout:='';

while length(s)>0 do

begin l:=pos(' ',s);

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

delete(s,1,l);

reset(f2);

while not(eof(f2)) do

begin readln(f2,ss);

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

if sinonim=slovoT

then slovoT:=copy(ss,k+1,length(ss)-k)

end;

close(f2);

sout:=sout+slovot+' '

end;

writeln(s);

writeln(f3,sout)

end;

close(f3);

reset(f3);

while not(eof(f3)) do

begin readln(f3,s);

writeln(s)

end;

close(f3);

readln

end.

12.

program pr

var f,g:text;

prep:set of char;

words:array [1..50] of string;

pw:array[1..50] of integer;

filename,filename1,s,s1,wsp:string;

n,i,j,t,t1,n1:integer;

begin prep:=['.',',','!',' '];

write('Введите имя файла:');

readln(filename);

assign(f,filename);

assign(g,'textg.txt');

rewrite(g);

reset(f);

while not(eof(f)) do

begin readln(f,s); {s- строка}

j:=1; words[j]:='';n1:=1;

for i:=1 to length(s) do

begin

if s[i] in prep

then begin pw[j]:=n1;

j:=j+1;

words[j]:='';

n1:=i+1

end

else words[j]:=words[j]+s[i];

end;

n:=j+1;

for j:=1 to n-1 do

for i:=j+1 to n do

if words[i]=words[j]

then begin wsp:=' ';

wsp:=copy(wsp,1,length(words[j]));

delete(s,pw[i],length(words[i]));

insert(s,wsp,pw[i]);

end;

writeln(g,s)

end;

close(g);

{вывод содержимого полученного файла на экран}

reset(g);

while not(eof(g)) do

begin readln(g,s);

writeln(s)

end;

close(g)

end.

13.

program pr6c;

const razd=[' ','.',',','?','!',':',')','('];

var f:text;

s,slo,slovo,name:string;

k,i:integer;

begin write('Введите имя файла:');

readln(Name);

assign(f,name);

reset(f);

slovo:='';k:=0;

while not(EOF(F)) do

begin

readln(f,s);slo:='';

for i:=1 to length(s) do

begin

if s[i] in razd

then

begin

if (i>1)and not(s[i-1]in razd)

then begin

if (length(slo)=length(slovo))and

(slo=slovo)

then k:=k+1;

if length(slo)>length(slovo)

then

begin

slovo:=slo;

k:=1

end;

end;

slo:=''

end

else

begin

slo:=slo+s[i]

end;

end;

if (length(slo)=length(slovo))and

(slo=slovo)

then k:=k+1;

if length(slo)>length(slovo)

then slovo:=slo;

end;

writeln('слово ',slovo,' встречается ',k,' раз');

close(f);

readln

end.

14.

program Zadacha;

const R=15;

var FileName:string;

fa:file;

a,b,c,d,e,f,k,m,l,x,n,i:longint;

function Fx(a,b,c,d,e,f,k,m,l,x:longint):boolean;

begin

{write(4,':',x,'@');

Fx:=((a*x+b)/(c*x+d)+(e*x+f)/(k*x+m)-l)=0;}Fx:=true

end;

function Check(var x:longint;a,b,c,d,e,f,k,m,l:longint):boolean;

var a1,b1,c1,d1,x1,x2:real;

begin

Check:=False;{write(1);}

{if (a=0) and b=0*c*d*e*f*k*m=0 then exit;

{проверка существования целочисленного решения}

if ((c*x+d)=0) or ((k*x+m)=0) then exit;

if not((frac((a*x+b)/(c*x+d))=0) and

(frac((e*x+f)/(k*x+m))=0))

then exit; {write(2);}

a1:=a*k+e*c-l*c*k; if a1=0 then exit;

b1:=a*m+b*k+e*d+f*c-l*c*m-l*d*k;

c1:=b*m+f*d-l*d*m;

d1:=sqr(b1)-4*a1*c1; if d1<0 then exit;

d1:=sqrt(d1);

x1:=(-b1+d1)/(2*a1);

x2:=(-b1-d1)/(2*a1);

if frac(x1)=0

then x:=trunc(x1)

else exit;

if frac(x2)=0

then x:=trunc(x2)

else exit;

if (a1*x+b1)*x+c1<>0 then exit;

Check:=Fx(a,b,c,d,e,f,k,m,l,x) and (x<>0); {write(4,':',x,'@');}

writeln(5)

end;

begin

{write('Введите имя файла:');readln(FileName)}

write('Введите количество заданий:'); readln(n);

{ assign(fa,FileName);

rewrite(fa);

} writeln(f,'Решите уравнение в целых числах:');

for i:=1 to n do

begin

repeat

{генерация чисел}

a:=Random(R);

b:=Random(R);

c:=Random(R);

d:=Random(R);

e:=Random(R);

f:=Random(R);

k:=Random(R);

m:=Random(R);

l:=Random(R);

{проверка существования целочисленного решения}

until Check(x,a,b,c,d,e,f,k,m,l);

writeln({f,}'(',a,'x+',b,')/(',c,'x+',d,')+(',

e,'x+',f,')/(',k,'x+',m,')=',l,' (x=',x,')');

end;

{ close(fa)}

end.