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.
********************************************************
program ex11_16;
uses crt;
type
TMyRec=record
Key: word;
Name: string[12];
Year:word;
end;
var
RecGl: TMyRec;
f: longint;
t: boolean;
{======================================}
procedure RandomFill(f1:string);
var
i:byte;
inF: File of TMyRec;
Rec: TMyRec;
begin
randomize;
assign(inF,f1);
{$I-}
reWrite(inF);
if ioresult<>0 then begin write('Can not create file!'); exit; end;
{$I+}
for i:=1 to 6+random(5) do
begin
Rec.Name:='';
Rec.Key:=1+random(6);
Rec.Year:=1950+random(57);
while length(Rec.Name)<(8+random(6)) do Rec.Name:=Rec.Name+chr(ord('a')+random(26));
Rec.Name[1]:=UpCase(Rec.Name[1]);
write(inF, Rec);
end;
Close(inF);
end;
{=============================================}
procedure SortRandomFill(f1:string);
var
i:byte;
inF: File of TMyRec;
Rec: TMyRec;
begin
randomize;
assign(inF,f1);
{$I-}
reWrite(inF);
if ioresult<>0 then begin write('Can not create file!'); exit; end;
{$I+}
for i:=1 to 6+random(10) do
begin
Rec.Name:='';
Rec.Key:=i;
Rec.Year:=1950+random(57);
while length(Rec.Name)<(8+random(6)) do Rec.Name:=Rec.Name+chr(ord('a')+random(26));
Rec.Name[1]:=UpCase(Rec.Name[1]);
write(inF, Rec);
end;
Close(inF);
end;
{=============================================}
procedure RandomRec(var Rec: TMyRec);
begin
randomize;
Rec.Name:='';
Rec.Key:=1+random(6);
Rec.Year:=1950+random(57);
while length(Rec.Name)<(8+random(6)) do Rec.Name:=Rec.Name+chr(ord('a')+random(26));
Rec.Name[1]:=UpCase(Rec.Name[1]);
end;
{=========================================}
procedure ShowFile(f1:string);
var
inF: File of TMyRec;
Rec: TMyRec;
begin
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,Rec);
writeln ('Key: ',Rec.Key,'; Name: ',Rec.Name,'; Year: ',Rec.Year,';');
end;
close(inF);
end;
{=========================================}
procedure ShowRec(Rec: TMyRec);
begin
writeln ('Key: ',Rec.Key,'; Name: ',Rec.Name,'; Year: ',Rec.Year,';');
end;
{============================================}
procedure ex11(f1:string; DelKey:word);
var
Rec: TMyRec;
inF: File of TMyRec;
i,c:longint;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
i:=1;
c:=0;
while i<FileSize(inF)+1 do
begin
read(inF,Rec);
if Rec.Key=DelKey then begin inc(i); inc(c); end
else
begin
seek(inF,i-c-1);
Write(inF,Rec);
seek(inF,i);
inc(i);
end;
end;
seek(inF,FileSize(inF)-c);
truncate(inF);
Close(inF);
end;
{============================================}
procedure ex12(f1:string; Key: word; UpdRec: TMyRec);
var
Rec: TMyRec;
inF,outF: File of TMyRec;
i:longint;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
i:=1;
while i<FileSize(inF)+1 do
begin
read(inF,Rec);
if Rec.Key=Key then
begin
seek(inF,i-1);
Write(inF, UpdRec);
inc(i);
end
else inc(i);
end;
Close(inF);
end;
{============================================}
procedure ex13(f1: string; var NewRec: TMyRec);
var
inF: File of TMyRec;
Rec: TMyRec;
max: word;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
read(inF, Rec);
NewRec:=Rec;
while not EOF(inF) do
begin
read(inF, Rec);
if NewRec.Key<Rec.Key then NewRec:=Rec;
end;
end;
{============================================}
function ex14(f1:string):longint;
var
inF: File of TMyRec;
Rec: TMyRec;
i,c:longint;
min:word;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
i:=1;
c:=0;
read(inF,Rec);
min:=Rec.Key;
while not EOF(inF) do
begin
read(inF,Rec);
if min>Rec.Key then begin min:=Rec.Key; i:=Filepos(inF); end;
inc(c);
end;
ex14:=i;
end;
{============================================}
function ex15(f1: string; max:word):Boolean;
var
Rec: TMyRec;
inF: File of TMyRec;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
seek(inF,FileSize(inF)-1);
read(inF,Rec);
ex15:=Rec.Key<max;
end;
{============================================}
procedure ex16(f1,f2: string; a,b:word);
var
Rec: TMyRec;
inF,outF: File of TMyRec;
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+}
read(inF,Rec);
while Rec.Key<=b do
begin
if (Rec.Key in [a..b]) then
begin
write(outF,Rec);
read(inF,Rec);
end
else read(inF,Rec);
end;
close(inF);
close(outF);
end;
{============================================}
begin
clrscr;
SortRandomFill('ex1101');
ShowFile('ex1101');
ex16('ex1101','ex1102', 4, 9);
ShowFile('ex1102');
{t:=ex15('ex1101',2);
writeln(t);
ex11('ex1101',6);
writeln('==========================================');
RandomRec(RecGl);
ShowRec(RecGl);
ex12('ex1101',5,RecGl);
writeln('==========================================');
writeln('File update:');
ShowFile('ex1101');
ex13('ex1101',RecGl);
ShowRec(RecGl);
writeln('==========================================');
f:=ex14('ex1101');
writeln('Minimalnoe znachenie polya "Key" codergitcyav v ',f,' zapisi tipa "TMyRec" ');
}repeat
until readkey=#27;
end.
********************************************************
program ex017;
uses crt;
type
TFileText=text;
List=^ListStr;
ListStr=record
Info: String;
Next,Prev:List;
end;
{*********************************************}
procedure AddToList(X: string; var PEndList:List);
begin
if PEndList=nil then
begin
New(PEndList);
PEndList^.Info:=X;
PEndList^.Next:=nil;
PEndList^.Prev:=nil;
end
else
begin
New(PEndList^.Next);
PEndList^.Prev:=PEndList;
PEndList:=PEndList^.Next;
PEndList^.Info:=X;
PEndList^.Next:=nil;
end;
end;
{*************************************}
Function CreateLists(var q: List; max:longint):List;
var
i:longint;
X: string;
Uk,ListBegin:List;
begin
X:='';
Uk:=nil;
q:=nil;
AddToList(X,Uk);
q:=Uk;
for i:=1 to max-1 do
begin
X:='';
AddToList(X,q);
end;
ListBegin:=Uk;
CreateLists:=ListBegin;
end;
{***************************************}
procedure ShowFile(f1:string; i:longint);
var
inF: TFileText;
Str: string;
a:longint;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then begin write('File not found!'); exit; end;
{$I+}
for a:=1 to i do
begin
readln(inF,Str);
writeln (Str);
end;
close(inF);
end;
{*****************************************}
function RandomFill(f1:string):longint;
var
i:longint;
inF: TFileText;
s:string;
begin
randomize;
assign(inF,f1);
{$I-}
reWrite(inF);
if ioresult<>0 then begin write('Can not create file!'); exit; end;
{$I+}
i:=1;
for i:=1 to random(10) do
begin
s:='';
while length(s)<=5+random(20) do
begin
s:=s+chr(ord('a')+random(26));
end;
writeln(inF,s);
end;
Close(inF);
ShowFile(f1,i);
randomFill:=i;
end;
{******************************************}
procedure ex17(S1,S2: string);
var
inF,outF: TFileText;
ListTmp,L1,L2,LEnd: List;
Str: string;
i:longint;
begin
i:=RandomFill(S1);
ListTmp:=nil;
assign(inF,S1);
assign(outF,S2);
{$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!'); exit; end;
{$I+}
if i=0 then writeln('File = Nill!');
L1:=CreateLists(ListTmp,i);
ListTmp:=L1;
L2:=L1^.Next;
while not EOF(inF) do
begin
readln(inF,str);
ListTmp^.Info:=str;
ListTmp:=L2;
L2:=ListTmp^.Prev;
end;
while ListTmp=nil do
begin
LEnd:=L2;
readln(inF,str);
L2:=ListTmp;
ListTmp:=ListTmp^.Prev;
writeln(outF, L2^.Info);
L2:=L2^.Prev;
end;
{ListTmp:=L1;
while not EOF(inF) do
begin
ListTmp:=L2;
readln(inF,str);
ListTmp^.Info:=str;
L2:=ListTmp^.Next;
end;
while ListTmp^.Next<>nil do
begin
str:='';
writeln(outF,ListTmp^.Info);
ListTmp^.Next:=ListTmp;
end;}
writeln('****************');
ShowFile(S2,i);
close(inF);
close(outF);
end;
{******************************************}
const
S2='ex1702.txt';
S1='ex1701.txt' ;
begin
clrscr;
randomize;
{RandomFill(S1); }
ex17(S1,S2);
{CreateLists(5);}
end.
********************************************************
program ex18;
uses crt;
type
TText=text;
PListItem=^TListItem;
TListItem=record
Data:string;
Next:PListItem;
end;
PFIFO=^TFIFO;
TFIFO=object
private
AList,BList:PListItem;
public
constructor Init;
destructor Done;
procedure Put(Element: string);
function Get:string;
function NotEmpty:boolean;
end;
constructor TFIFO.Init;
begin
AList:=Nil;
BList:=Nil;
end;
destructor TFIFO.Done;
var
P:PListItem;
begin
while AList<>Nil do
begin
P:=AList^.Next;
Dispose(AList);
AList:=P;
end;
end;
function TFIFO.Get:string;
var
P:PListItem;
GetData: string;
begin
if AList=Nil then begin Get:=''; exit; end;
P:=AList^.Next;
GetData:=AList^.Data;
Dispose(AList);
AList:=P;
if AList=nil then BList:=AList;
Get:=GetData;
end;
Procedure TFIFO.Put(Element: string);
var
P: PListItem;
begin
New(P);
P^.Data:=Element;
if (BList=nil) and (AList=nil) then
begin
P^.Next:=nil;
AList:=P;
BList:=P;
end
else
begin
BList^.Next:=P;
P^.Next:=nil;
BList:=P;
end;
end;
function TFIFO.NotEmpty;
begin
NotEmpty:=AList<>nil;
end;
procedure ShowFile(f1:string);
var
inF: TText;
Str: string;
begin
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then
begin
write('File not found!');
exit;
end;
{$I+}
while not EOF(inF) do
begin
readln(inF,str);
writeln ('1: ',str);
end;
close(inF);
end;
Procedure Sort(var f1:string);
var
inF: TText;
Str,max,StrTmp:string;
SortList,SortListTmp:TFIFO;
imax,j,i: Longint;
Tmp:PListItem;
begin
imax:=0;
SortList.init;
SortListTmp.init;
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then
begin
write('File not found!');
exit;
end;
{$I+}
while not EOF(inF) do
begin
readln(inF,Str);
SortList.Put(Str);
inc(imax);
end;
if SortList.AList=nil then exit;
for i:=1 to imax do
begin
max:=SortList.Get;
Tmp:=SortList.AList;
for j:=i to imax do
begin
if Tmp^.Data>max then
begin
StrTmp:=max;
max:=Tmp^.Data;
Tmp^.Data:=StrTmp;
Tmp:=Tmp^.Next;
end
else Tmp:=Tmp^.Next;
end;
SortListTmp.Put(max);
end;
{$I-} {
reWrite(inF);
if ioresult<>0 then
begin
write('Can not create file!');
exit;
end;
{$I+}
for i:=1 to imax do writeln(SortListTmp.Get);
{close(inF);}
SortList.Done;
SortListTmp.Done;
end;
var
List:TFIFO;
i:byte;
a:string;
begin
clrscr;
a:='ex1801.txt';
List.init;
Sort(a);
{ ShowFile(a);}
List.Done;
end.
{**********************************}
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T+,V+,X+,Y+}
{$M 16384,0,655360}
program ex19-23;
uses crt;
type
TText=text;
PListItem=^TListItem;
TListItem=record
Data:string;
Next:PListItem;
end;
PFIFO=^TFIFO;
TFIFO=object
private
AList,BList:PListItem;
public
constructor Init;
destructor Done;
procedure Put(Element: string);
function Get:string;
function NotEmpty:boolean;
function Count:longint;
end;
PChildFIFO=^TChildFIFO;
TChildFIFO=object (TFIFO)
procedure PutFirst(Str:string);
procedure PutInOrder(Str:string);
end;
constructor TFIFO.Init;
begin
AList:=Nil;
BList:=Nil;
end;
destructor TFIFO.Done;
var
P:PListItem;
begin
while AList<>Nil do
begin
P:=AList^.Next;
Dispose(AList);
AList:=P;
end;
end;
function TFIFO.Get:string;
var
P:PListItem;
GetData: string;
begin
if AList=Nil then begin Get:=''; exit; end;
P:=AList^.Next;
GetData:=AList^.Data;
Dispose(AList);
AList:=P;
if AList=nil then BList:=AList;
Get:=GetData;
end;
Procedure TFIFO.Put(Element: string);
var
P: PListItem;
begin
if MaxAvail<SizeOf(TListItem) then Exit; { Проверка на возможность выделения памяти. }
New(P);
P^.Data:=Element;
if (BList=nil) and (AList=nil) then
begin
P^.Next:=nil;
AList:=P;
BList:=P;
end
else
begin
BList^.Next:=P;
P^.Next:=nil;
BList:=P;
end;
end;
function TFIFO.NotEmpty;
begin
NotEmpty:=AList<>nil;
end;
function TFIFO.Count;
var
Tmp:PListItem;
i:longint;
begin
i:=0;
Tmp:=AList;
while Tmp<>nil do begin Tmp:=Tmp^.Next; inc(i); end;
Count:=i;
end;
procedure TChildFIFO.PutFirst;
var
Tmp: PListItem;
begin
if MaxAvail<SizeOf(TListItem) then Exit; { Проверка на возможность выделения памяти. }
if (AList=nil) and (BList=nil) then Put(Str)
else
begin
New(Tmp);
Tmp^.Next:=AList;
AList:=Tmp;
end;
end;
procedure TChildFIFO.PutInOrder;
var
Tmp,TmpPrev,TmpBetween: PListItem;
begin
if (AList=nil) and (BList=nil) then Put(Str)
else
begin
Tmp:=AList;
TmpPrev:=nil;
{$B-}
while (Tmp<>nil) and (Str>=Tmp^.Data) do
begin
TmpPrev:=Tmp;
Tmp:=Tmp^.Next;
end;
if TmpPrev=nil then putFirst(Str);
if Tmp=nil then Put(Str)
else
begin
New(TmpBetween);
TmpBetween^.Data:=Str;
TmpPrev^.Next:=TmpBetween;
TmpBetween^.Next:=Tmp;
end;
end;
end;
function Count(AList: PFIFO):longint;
var
Tmp:PListItem;
i:longint;
begin
i:=0;
Tmp:=AList^.AList;
while Tmp<>nil do begin Tmp:=Tmp^.Next; inc(i); end;
Count:=i;
end;
function ex22(f1: string; litera:char):pointer;
var
inF: text;
str:string;
TmpList:PFIFO;
begin
new(TmpList,Init);
assign(inF,f1);
{$I-}
reset(inF);
if ioresult<>0 then
begin
write('File not found!');
exit;
end;
{$I+}
while not EOF(inF) do
begin
readln(inF,str);
if str<>'' then
if str[1]=litera then TmpList^.Put(str);
end;
close(inF);
ex22:=TmpList;
end;
function ex23(P: PFIFO; litera:char):pointer;
var
str:string;
TmpList:PFIFO;
Tmp:PListItem;
begin
New(TmpList, Init);
Tmp:=P^.AList;
while Tmp<>nil do
begin
str:=Tmp^.Data;
if str<>'' then
if str[1]=litera then TmpList^.Put(str);
Tmp:=Tmp^.Next;
end;
ex23:=TmpList;
end;
var
List:TChildFIFO;
p:PFIFO;
a:string;
Tmp:PListItem;
begin
clrscr;
List.init;
List.Put('akuxcfjyfg');
List.Put('ajh');
List.Put('butf');
List.Put('byr');
List.Put('dkiuh');
List.Put('afbgfddte');
{List.PutInOrder('c');
writeln(List.Count);
writeln(Count(@List));
while List.NotEmpty do writeln(List.Get); }
p:=ex23(@List,'a');
tmp:=p^.AList;
while tmp<>nil do begin writeln(Tmp^.Data); tmp:=tmp^.Next; end;
Dispose(p,Done);
List.Done;
end.
{***************************************}
program ex24;
uses AbsObj,crt;
type
PParamItem=^TParamItem;
TParamItem=record
Name,Value:string;
end;
PParamFifo=^TParamFifo;
TParamFifo=object (TFifo)
{ private
AList,BList:PListItem;
public
constructor Init;
destructor Done;
procedure Put(Element: pointer);
function Get:pointer;}
procedure SetParam(AName,AValue:string);
function GetParam(AName:string):string;
procedure FreeItem(AItem: pointer); virtual;
end;
procedure TParamFifo.FreeItem(AItem: pointer);
var
Tmp:PParamItem;
begin
Tmp:=AItem;
Dispose(Tmp);
end;
procedure TParamFifo.SetParam(AName,AValue:string);
var
Tmp:PParamItem;
begin
New(Tmp);
Tmp^.Name:=AName;
Tmp^.Value:=AValue;
Put(Tmp);
end;
function TParamFifo.GetParam(AName:string):string;
var
TmpList:PListItem;
Tmp:PParamItem;
Str:string;
begin
Tmplist:=AList;
while TmpList<>nil do
begin
Tmp:=TmpList^.Data;
if Tmp=nil then TmpList:=TmpList^.Next
else
if AName<>Tmp^.Name then TmpList:=TmpList^.Next
else
begin
GetParam:=Tmp^.Value;
exit;
end;
end;
if TmpList=nil then GetParam:='';
end;
var
List:PParamFifo;
begin
New(List,Init);
with List^ do
begin
SetParam('Name1','Value4');
SetParam('Name2','Value3');
SetParam('Name3','Value2');
SetParam('Name4','Value1');
writeln(Getparam('Name8'));
writeln(Getparam('Name1'));
writeln(Getparam('Name3'));
end;
Dispose(List,Done);
end.
{******************************}
Unit AbsObj;
Interface
type
PListItem=^TListItem;
TListItem=record
Data:pointer;
Next:PListItem;
end;
PFIFO=^TFIFO;
TFIFO=object
AList,BList:PListItem;
constructor Init;
destructor Done;
procedure Put(Element: pointer);
function Get:pointer;
procedure FreeItem(AItem: pointer); virtual;
end;
Implementation
constructor TFIFO.Init;
begin
AList:=Nil;
BList:=Nil;
end;
destructor TFIFO.Done;
var
P:PListItem;
begin
while AList<>Nil do
begin
P:=AList^.Next;
FreeItem(AList^.Data);
Dispose(AList);
AList:=P;
end;
end;
function TFIFO.Get:pointer;
var
P:PListItem;
GetData: pointer;
begin
if AList=Nil then begin Get:=nil; exit; end;
P:=AList^.Next;
GetData:=AList^.Data;
Dispose(AList);
AList:=P;
if AList=nil then BList:=AList;
Get:=GetData;
end;
Procedure TFIFO.Put(Element: pointer);
var
P: PListItem;
begin
New(P);
P^.Data:=Element;
if (BList=nil) and (AList=nil) then
begin
P^.Next:=nil;
AList:=P;
BList:=P;
end
else
begin
BList^.Next:=P;
P^.Next:=nil;
BList:=P;
end;
end;
procedure TFifo.FreeItem;
begin
end;
begin
end.
{//////////////////////////}
type
TIterator=procedure (AItem:pointer);
PListItem=^TListItem;
TListItem=record
Data:pointer;
Next:PListItem;
end;
PFIFO=^TFIFO;
TFIFO=object
AList,BList:PListItem;
constructor Init;
destructor Done;
procedure Put(Element: pointer);
function Get:pointer;
procedure FreeItem(AItem: pointer); virtual;
procedure ForEach(AIterator:TIterator);
end;
constructor TFIFO.Init;
begin
AList:=Nil;
BList:=Nil;
end;
destructor TFIFO.Done;
var
P:PListItem;
begin
while AList<>Nil do
begin
P:=AList^.Next;
FreeItem(AList^.Data);
Dispose(AList);
AList:=P;
end;
end;
function TFIFO.Get:pointer;
var
P:PListItem;
GetData: pointer;
begin
if AList=Nil then begin Get:=nil; exit; end;
P:=AList^.Next;
GetData:=AList^.Data;
Dispose(AList);
AList:=P;
if AList=nil then BList:=AList;
Get:=GetData;
end;
Procedure TFIFO.Put(Element: pointer);
var
P: PListItem;
begin
New(P);
P^.Data:=Element;
if (BList=nil) and (AList=nil) then
begin
P^.Next:=nil;
AList:=P;
BList:=P;
end
else
begin
BList^.Next:=P;
P^.Next:=nil;
BList:=P;
end;
end;
procedure TFifo.FreeItem;
begin
end;
procedure ForEach(AIterator:TIterator);
var
Tmp:PListItem;
begin
Tmp:=AList;
while Tmp<>nil do
begin
AIterator(Tmp);
Tmp:=Tmp^.Next;
end;
end;
begin
end.
{***********************}
Program GalkaVV;
uses crt;
const MaxCollectionSize = 65520 div SizeOf(Pointer);
type
{*****************************************************}
PStr=^TStr;
TSrt=string;
{*****************************************************}
PObject=^TObject;
TObject=object
constructor Init;
destructor Done; virtual;
end;
{******************************************************}
TIterator=procedure (AItem: Pointer);
{******************************************************}
PItemList=^TItemList;
TItemList=array[0..MaxCollectionSize-1] of pointer;
{******************************************************}
PCollection=^TCollection;
TCollection=object
Items:PItemList;
Delta,Count,Limit: Integer;
constructor Init(ALimit, ADelta: Integer);
destructor Done;
procedure Insert(AItem: Pointer);
procedure AtInsert(AIndex: Integer; AItem: Pointer);
procedure Delete(AItem: pointer);
procedure AtDelete(AIndex: Integer);
function At(AIndex: Integer): Pointer;
procedure ForEach(Iterator:TIterator);
procedure FreeItem(AItem: Pointer); virtual;
end;
{******************************************************}
PObjCollection=^TObjCollection;
TObjCollection=object (TCollection)
procedure FreeItem(AItem: Pointer); virtual;
end;
{******************************************************}
PStrCollection=^TStrCollection;
TStrCollection=object (TCollection)
procedure FreeItem(AItem: Pointer); virtual;
procedure PutInOrder(AItem: string);
end;
{*****************************************************}
constructor TObject.Init;
begin
end;
destructor TObject.Done;
begin
end;
procedure TObjCollection.FreeItem(AItem: Pointer);
var
Tmp:PObject;
begin
Tmp:=AItem;
Dispose(Tmp,Done);
end;
constructor TCollection.Init(ALimit, ADelta: Integer);
var
i:integer;
begin
Limit:=ALimit;
Delta:=ADelta;
Count:=0;
GetMem(Items,SizeOf(Pointer)*Limit);
for i:=0 to Limit do Items^[i]:=nil;
end;
destructor TCollection.Done;
var
i:integer;
begin
for i:=0 to Limit do FreeItem(Items^[i]);
FreeMem(Items,SizeOf(Pointer)*Limit);
end;
procedure TCollection.Insert(AItem: Pointer);
var
i:integer;
Tmp:PItemList;
begin
if Count-1>=Limit then
begin
GetMem(Tmp,SizeOf(Pointer)*(Limit+Delta));
for i:=0 to Count-1 do
begin
Tmp^[i]:=Items^[i];
end;
FreeMem(Items,SizeOf(Pointer)*Limit);
Items:=Tmp;
Limit:=Limit+Delta;
end
else
begin
Items^[Count]:=AItem;
inc(Count);
end;
end;
procedure TCollection.AtInsert(AIndex: Integer; AItem: Pointer);
var
i:integer;
Tmp:PItemList;
begin
if Count-1>=Limit then
begin
GetMem(Tmp,SizeOf(Pointer)*(Limit+Delta));
for i:=0 to Count-1 do
begin
Tmp^[i]:=Items^[i];
end;
FreeMem(Items,SizeOf(Pointer)*Limit);
Items:=Tmp;
Limit:=Limit+Delta;
end
else
begin
inc(Count);
for i:=AIndex to Count-1 do Items^[Count-1-i]:=Items^[Count-i];
Items^[AIndex]:=AItem;
end;
end;
procedure TCollection.Delete(AItem: pointer);
var
i:integer;
begin
for i:=0 to Count-1 do
if AItem=Items^[i] then AtDelete(i);
end;
procedure TCollection.AtDelete(AIndex: Integer);
var
i:integer;
begin
FreeItem(Items^[AIndex]);
for i:=AIndex to Count-2 do
begin
Items^[i]:=Items^[i+1];
end;
dec(Count);
end;
function TCollection.At(AIndex: Integer): Pointer;
begin
At:=Items^[AIndex];
end;
procedure TCollection.FreeItem;
begin
end;
procedure TCollection.ForEach(Iterator:TIterator);
var
i:integer;
begin
for i:=0 to Count-1 do Iterator(Items^[i]);
end;
begin
end.
{*************************************}
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T+,V+,X+,Y+}
{$M 16384,0,655360}
program ex34;
uses crt;
type
TText=text;
PListItem=^TListItem;
TListItem=record
Data:string;
Next:PListItem;
end;
PFIFO=^TFIFO;
TFIFO=object
private
AList,BList:PListItem;
public
constructor Init;
destructor Done;
procedure Put(Element: string);
function Get:string;
function NotEmpty:boolean;
end;
constructor TFIFO.Init;
begin
AList:=Nil;
BList:=Nil;
end;
destructor TFIFO.Done;
var
P:PListItem;
begin
while AList<>Nil do
begin
P:=AList^.Next;
Dispose(AList);
AList:=P;
end;
end;
function TFIFO.Get:string;
var
P:PListItem;
GetData: string;
begin
if AList=Nil then begin Get:=''; exit; end;
P:=AList^.Next;
GetData:=AList^.Data;
Dispose(AList);
AList:=P;
if AList=nil then BList:=AList;
Get:=GetData;
end;
Procedure TFIFO.Put(Element: string);
var
P: PListItem;
begin
New(P);
P^.Data:=Element;
if (BList=nil) and (AList=nil) then
begin
P^.Next:=nil;
AList:=P;
BList:=P;
end
else
begin
BList^.Next:=P;
P^.Next:=nil;
BList:=P;
end;
end;
function TFIFO.NotEmpty;
begin
NotEmpty:=AList<>nil;
end;
procedure Change(s1,s2:string; var AFIFO:PFIFO);
var
Tmp:PListItem;
p:byte;
begin
Tmp:=AFIFO^.AList;
while Tmp<>nil do
begin
p:=pos(s1,Tmp^.Data);
while p<>0 do
begin
delete(Tmp^.Data,p,length(s1));
insert(s2,Tmp^.Data,p);
p:=pos(s1,Tmp^.Data);
end;
Tmp:=Tmp^.Next;
end;
end;
var
FiFo:PFIFO;
Tmp:PListItem;
str1,str2: string;
begin
clrscr;
New(FiFo,Init);
str1:='g';
str2:='BB';
Tmp:=FiFo^.AList;
FIFO^.put('sggasrger');
FIFO^.put('lksjrgla');
FIFO^.put('aoirugj');
FIFO^.put('ksagjh8848ujh');
Change(str1,str2,FiFo);
while Fifo^.AList<>nil do
begin
writeln(FiFo^.Get);
end;
Dispose(FiFo,Done);
end.