Вопросы к экзамену с ответами и демо-программами на Паскале / 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.