Вопросы к экзамену с ответами и демо-программами на Паскале / EX1-8

program ex;
uses crt;
{=======================================}
function ex03(f1: string):longint;
var
	inF:text;
	a:string;
	c,d:longint;
begin
c:=0;
d:=0;
assign(inF,f1);
{$I-}
reset(inF);
	if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
	while not EOF(inF) do
	begin
		while not EOLN(inF) do
		begin
			read(inF,a);
			inc(c);
		end;
	readln(inF);
	d:=d+c;
	end;
close(inF);
ex03:=d;
end;
{=======================================}
function ex02(f1: string; param:char):longint;
var
	inF:file of char;
	a:char;
	c:longint;
begin
c:=0;
assign(inF,f1);
{$I-}
reset(inF);
	if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
	while not EOF(inF)  do
	begin
		read(inF, a);
		a:=UpCase(a);
		if a=param then inc(c);
	end;
ex02:=c;
close(inF);
end;

{=======================================}
procedure ex01(f1,f2: string);
var
	inF:file of char;
	outF:text;
	mass: array ['A'..'Z'] of longint;
	a:char;
	c:longint;
begin
for a:='A' to 'Z'do mass[a]:=0;
assign(inF,f1);
assign(outF,f2);
{$I-}
reset(inF);
	if ioresult<>0 then begin write('File not found!'); exit; end;
reWrite(outF);
	if ioresult<>0 then begin write('Can not create file!');  close(inF); exit; end;
{$I+}
	while not EOF(inF)  do
	begin
		read(inF, a);
		a:=UpCase(a);
		if a in ['A'..'Z'] then inc(mass[a]);
	end;
for a:='A'to 'Z' do writeln(outF,a,': ',mass[a]);
close(inF);
close(outF);
end;
{=======================================}
function ex07(f1:string):string;
var
	inF:text;
	min,s:string;
begin
assign(inF,f1);
{$I-}
reset(inF);
	if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
min:='';
while (not EOF(inF)) and (min='') do	readln(inF,min);
while not EOF(inF) do
	begin
		readln(inF,s);
		if s<>'' then
		if length(min)>length(s) then min:=s;
	end;
ex07:=min;
close(inF);
end;
{=======================================}
procedure ex06(f1,f2,a:string);
var
	inF,outF:text;
	s:string;
	b:byte;
begin
assign(inF,f1);
assign(outF,f2);
{$I-}
reset(inF);
	if ioresult<>0 then begin write('File not found!'); exit; end;
rewrite(outF);
	if ioresult<>0 then begin write('Can not creat file!'); close(inF); exit; end;
{$I+}
b:=0;
	while not EOF(inF) do
	begin
		readln(inF,s);
		b:=pos(a,s);
		if b>0 then writeln(outF,s);
	end;
close(inF);
close(outF);
end;


{=======================================}
function ex05(f1,a:string):byte;
var
	inF:text;
	s:string;
	c:longint;
	b:byte;
begin
assign(inF,f1);
{$I-}
reset(inF);
{$I+}
	if ioresult<>0 then begin write('File not found!'); exit; end;
b:=0;
c:=0;
	while ((EOF(inF)=False) and (b=0)) do
	begin
		readln(inF,s);
		b:=pos(a,s);
		inc(c);
	end;
if b=0 then c:=0;
ex05:=c;
close(inF);
end;

{============================================}
procedure ex04(f1: string; b:byte);
var
	a,c:byte;
	inF:file of byte;
begin
assign(inF, f1);
{$I-}
reset(inF);
{$I+}
	if ioresult<>0 then begin write('File not found!'); exit; end;
	while not EOF(inF) do
	begin
		read(inF,a);
		seek(inF,FilePos(inF)-1);
		c:=(a xor b);
		write(inF,c);
	end;
close(inF);
end;

{=========================================}
function trans08(a:byte):string;
var
	i:byte;
	b: string;
begin
b:='';
i:=1;
	for i:=1 to 8 do
	begin
		if (a mod 2)=0 then b:='0'+b else b:='1'+b;
	a:= a div 2;
	end;
trans08:=b;
end;

procedure ex08(f1,f2:string);
var
	inF:file of byte;
	outF:text;
	a:byte;
begin
assign (inF,f1);
assign (outF,f2);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
reWrite(outF);
if ioresult<>0 then begin write('Can not create file!');  close(inF); exit; end;
{$I+}
	while not EOF(inF) do
	begin
		read(inF,a);
		write(outF, trans08(a),'; ');
	end;
close(inF);
close(outF);
end;
{========================================================}
begin
clrscr;
ex08('ex0801.txt','ex0802.txt');
ex04('ex0401.txt',12);
writeln(ex05('ex0501.txt','and'));
ex06('ex0601.txt','ex0602.txt','and');
writeln(ex07('ex0701.txt'));
ex01('ex0101.txt','ex0102.txt');
writeln(ex02('ex0201.txt','A'));
writeln(ex03('ex0301.txt'));
end.