/
YakuninAV
/
Convertors
Обзор
Документация
Войти
/
YakuninAV
/
Convertors
Код
Запросы
0
Задачи
Вики
Пакеты
0
Релизы
0
Аналитика
Безопасность
master
Program Design/Delphi2007/Obj.pas
2 934 строки
67 KB
YakuninAV
begin with gitflick
31 июл 2026, 15:21
31 июл 2026, 15:21
1dc0fc6
Код
Авторство
О чём код?
unit obj; interface uses Classes,SysUtils,typinfo,Windows,ComUnit,Dialogs,ComObj; type TBaseClass= class of TBaseObject; TMultiHeader= packed record ItemsCount: integer; case IsAdr: Boolean of True: (IAT: TIntArray); False: (Buf: TByteArray); end; PObjHeader= ^TObjHeader; TObjHeader= packed record ObjSize : integer; case integer of 0: (Count: integer; ItemsSize: integer; IAT: array[0..MaxInt div 6] of integer); 1: (ObjData: array[0..MaxInt div 2] of byte); end; TSingleHeader= packed record Buf: TByteArray; end; THeaderRec= packed record case IsMulti: Boolean of True: (Multi: TMultiHeader); False: (Single: TSingleHeader); end; PHeaderRec= ^THeaderRec; TCollectorClass= Class of TCollector; TBaseObject= class(TInterfacedObject) protected function _Release: Integer; stdcall; public constructor Load(S: TStream);virtual; procedure Store(S: TStream); virtual; constructor Restore(var Buf); virtual; abstract; function GetPackSize: integer; virtual; abstract; procedure PackTo(var Buf); virtual; abstract; function BaseClassType:TBaseClass; function Get_Handles: pointer; virtual; function Connect(H: TObject): integer; virtual; procedure Disconnect(H: TObject);virtual; function Get_SelfCopy: pointer; virtual; abstract; property PackSize: integer read GetPackSize; end; TMultiObject= class(TBaseObject) FCount: integer; constructor Restore(var Buf); override; class function PointerToSelfPack(P: pointer): pointer; function GetItemPtr(N: integer): pointer; virtual; abstract; function GetSelfPackSize: integer; virtual; function GetItemsPackSize: integer; virtual; abstract; procedure SetCount(C: integer); virtual; abstract; procedure RestoreSelf(var Buf); virtual; abstract; procedure RestoreItems(var Buf); virtual; abstract; procedure PackSelf(var Buf); virtual; abstract; procedure PackItems(var Buf); virtual; abstract; function GetPackSize: integer; override; procedure InitializeItem(AItem: pointer); virtual; procedure PackTo(var Buf); override; property Count: integer read FCount write SetCount; property SelfPackSize: integer read GetSelfPackSize; property ItemsPackSize: integer read GetItemsPackSize; end; TStorage= class(TBaseObject) FCount,FItemSize,FDeltaSize,FCapacitySize: integer; FStorage: pointer; constructor Create(AItemSize,ADelta: integer); destructor Destroy;override; constructor Load(S: TStream);override; procedure Store(S:TStream); override; procedure Insert(Index: integer; var X); procedure DeleteItems(Index,ACount: integer); procedure GetItem(Index:integer; var X); procedure SetItem(Index: integer; var X); function GetCapacity: integer; procedure SetCapacity(C: integer); procedure SetCount(C: integer); property Capacity: integer read GetCapacity write SetCapacity; property Count: integer read FCount write SetCount; property BufferPtr: pointer read FStorage; private function Get_ItemPtr(Index: integer): pointer; end; TIntStorage= class(TStorage) constructor Create(ADelta: integer); function GetInt(Index: integer): integer; procedure SetInt(Index: integer; X: integer); procedure InsertWithShift(Index: integer; X: integer); procedure DeleteWithShift(AFrom,ACount: integer); function CreateArray: DIntArray; function Get_ItemPos(AItem: integer): integer; function Get_SelfCopy: pointer; override; property Item[Index: integer]: integer read GetInt write SetInt; end; TStrucAdress= class(TIntStorage) constructor Create; function IsEqualPath(A: TStrucAdress): boolean; property Deepness: integer read FCount; end; TOnSortAllProgressEvent = procedure(Sender: TObject; AIndex: Integer) of object; TSortObj= class(TBaseObject) FSort: TIntStorage; FDir : integer; FComp: TListSortCompare; FOnSortAllProgress: TOnSortAllProgressEvent; FUserIndex: boolean; constructor Create; destructor Destroy; override; constructor Load(S: TStream);override; procedure Store(S:TStream); override; function FindPlace(Atr: pointer): integer; function GetInsPos(Atr: pointer): integer; function FindBorderIndex(Atr: pointer; ADir: integer): integer; // ADir=1 - right border function Found(Attr: pointer): integer; procedure SortAll; procedure SetDir(D: integer); function GetCount: integer;virtual; abstract; function GetUserIndex(N: integer): integer;virtual; abstract; function Get_SortedN(AIndex: integer): integer; function GetAttr(N: integer): pointer; virtual; abstract; procedure DisposeAttr(var A: pointer); virtual; procedure AddAttr(A: pointer); procedure InsertAttr(A: pointer; N: integer); procedure RemoveAttrIndex(N: integer); property Count: integer read GetCount; property Dir: integer read FDir write SetDir; property Comp: TListSortCompare read FComp; end; TFixedBase= class(TSortObj) private FCount, FRecSize: integer; FStream: TStream; FMode: word; protected function ExtractAttr(R: pointer): pointer; virtual; abstract; public constructor Create(const AName: string; AMode: word; ARecSize: integer); destructor Destroy; override; function GetCount: integer; override; function GetAttr(N: integer): pointer; override; procedure AddRec(var ARec); procedure ReadRec(AIndex: integer; var ARec); end; TSortedStorage= class(TSortObj) FStorage: TStorage; constructor Create(AItemSize,ADelta: integer;AComp: TListSortCompare); function GetCount: integer; override; function GetAttr(N: integer): pointer; override; procedure DisposeAttr(var A: pointer); override; destructor Destroy; override; procedure Insert(Index: integer; var X); procedure Add(var X); property Storage: TStorage read FStorage; end; TSortTest= class(TSortObj) private FCount: integer; public constructor Create; function GetCount: integer; override; function GetAttr(N: integer): pointer; override; procedure ShowValues; end; TCollector= class(TMultiObject) FCapacity,FDelta: integer; FItems: PPointerList; constructor Create(ADelta: integer); function GetItemPtr(N: integer): pointer; override; function GetSelfPackSize: integer; override; function GetItemsPackSize: integer; override; procedure RestoreSelf(var Buf); override; procedure RestoreItems(var Buf); override; procedure PackSelf(var Buf); override; procedure PackItems(var Buf); override; class procedure PackItem(var Buf; AItem: pointer; ASize: integer); virtual; abstract; class function RestoreItem(var Buf; ASize: integer): pointer; virtual; abstract; function GetItemPackSize(P: pointer): integer; virtual; abstract; procedure SetCount(N: integer); override; destructor Destroy;override; constructor Load(S: TStream);override; procedure Store(S:TStream); override; function LoadItem(S:TStream):pointer; virtual; abstract; procedure StoreItem(S:TStream; AItem: pointer); virtual; abstract; function AllMem: integer; procedure DisposeItem(var p:pointer);virtual; procedure Clear(N: integer); procedure Delete(n:integer); function At(n:integer):pointer; function ItemIndex(AItem: pointer): integer; function SelectItem(N: integer; AItem: pointer):pointer; procedure ShiftFrom(N: integer); procedure Insert(N: integer; AItem: pointer); virtual; function Include(AItem: pointer): integer; function Add(AItem: pointer): integer;virtual; function GetFreePlace: integer; procedure SetItem(N: integer; P: pointer); function PlaceItem(P: pointer): integer; procedure ReplaceItem(P: pointer); procedure Squeeze; function GetExCount: integer; procedure ExcludeItem(AIndex: integer); property Items[N: integer]: pointer Read At Write SetItem; property ExCount: integer Read GetExCount; end; TObjectCollector= class(TCollector) procedure DisposeItem(var p:pointer); override; function At(N: integer): TObject; end; TAutoObjectCollector= class(TObjectCollector) procedure DisposeItem(var p:pointer); override; function At(N: integer): TAutoObject; end; TClassCollector= class(TObjectCollector) function ItemClass:TBaseClass; virtual; abstract; function LoadItem(S:TStream):pointer;override; procedure StoreItem(S:TStream; AItem: pointer); override; end; TAsciizCollector= class(TCollector) class procedure PackItem(var Buf; AItem: pointer; ASize: integer); override; class function RestoreItem(var Buf; ASize: integer): pointer; override; function GetItemPackSize(P: pointer): integer; override; procedure DisposeItem(var p:pointer);override; function At(n:integer): Asciiz; procedure WritelnTo(var T: Text); function TotLength: integer; function TotString(C: Char): string; procedure ReadlnFrom(var T: text; N: integer); function LoadItem(S:TStream):pointer; override; procedure StoreItem(S:TStream; AItem: pointer); override; function Get_MaxCompatibleLevel(A: Asciiz): integer; function Get_MaxCompatibleLevelMulti(A: TAsciizCollector): integer; procedure AddString(const S: string); procedure WinToDos; function Get_StrAt(AIndex: integer): string; procedure Set_StrAt(AIndex: integer;const AStr: string); function ExistDuplicate: boolean; procedure EraseDuplicates; function IndexOfStr(const Str: String): Integer; function SuchAsStr(Str: Asciiz): integer; function SuchAs(const Str: string): integer; property StrAt[AIndex: integer]:string read Get_StrAt write Set_StrAt; end; TAsciizSortedCollector= class(TAsciizCollector) function Get_InsIndex(AKey: Asciiz): integer; function Get_KeyIndex(AKey: Asciiz): integer; function Add(AItem: pointer): integer; override; end; const ListSetPrefix='=LIST'; ListSetSeparator=','; type TFixList= class(TAsciizCollector) private FCurrent : integer; FStatus : byte; public function Get_SelfCopy: pointer;override; procedure RestoreSelf(var Buf); override; function GetSelfPackSize: integer; override; procedure PackSelf(var Buf); override; constructor Create(ADelta: integer); procedure SetCurrent(AIndex: integer); procedure SetUpFromStr(Str: Asciiz; Separator: char); procedure SetUpFrom(const Str: string; Separator: char); function GetText(Separator: char): string; function GetCurrentString: string; property Current: integer read FCurrent write SetCurrent; property CurrentString: string read GetCurrentString; end; TAccess= class(TSortObj) FStream: TStream; FIndex : TIntStorage; FCount : integer; function LoadRec(S: TStream): pointer;virtual; abstract; function LoadAttr(S: TStream): pointer;virtual; abstract; procedure StoreRec(ARec: pointer; S: TStream);virtual; abstract; end; TLimb= class(TObjectCollector) FOwner: TLimb; constructor Create(AOwner: TLimb); constructor Load(S: TStream);override; function Deepness:integer; function Get_MaxDeepnessFromSelf: integer; function GetItemByAddress(const A:string; var D: integer): pointer; function GetItemByText(Adr: string): pointer; function GetStrAddress: string; function GetSub(X: DIntArray; N: integer): pointer; function GetSubCount: integer; function At(N: integer): TLimb; function IsIncludedIn(L: TLimb): boolean; function WhereSub(L: TLimb): integer; function LoadItem(S:TStream):pointer; override; procedure StoreItem(S:TStream; AItem: pointer); override; function GetLast(ADeepness: integer): pointer; function AbsLast: pointer; procedure Insert(N: integer; AItem: pointer); override; function IsRoot: boolean; function Get_Root: TLimb; function Get_NextAfter(L: TLimb): TLimb; function Get_Next: pointer; function Get_Prev: pointer; function CreatePath: DIntArray; function GotoPath(P: DIntArray): pointer; property Next: pointer read Get_Next; end; PContensItem= ^TContensItem; TContensItem= record Text,Address: string; Deepness,SubCount: integer; Opened,IsPos: wordbool; Prev,Next: integer; end; TContensArray= array of TContensItem; TContensInfo= class(TBaseObject) private FItems : TContensArray; FIsList,FShowRoot: boolean; FRootName: string; protected function CalcItemsCount: integer; virtual; abstract; procedure FillItems(var AItems: TContensArray); virtual; abstract; function Get_ItemsCount: integer; function Get_Item(N: integer): TContensItem; procedure OpenItem(N: integer); virtual; abstract; procedure CloseItem(N: integer); virtual; abstract; procedure PrepareToRefresh; virtual; abstract; procedure Refill; function CutAddress(const A: string;var Offset: integer): string; function Get_CurrentIndex: integer; virtual; abstract; procedure Set_CurrentIndex(AIndex: integer); virtual; abstract; procedure Set_ShowRoot(AShowRoot: boolean); virtual; procedure Set_RootName(const ARootName: string); public constructor Create(AsList: boolean); destructor Destroy; override; procedure ClickItem(AIndex: integer); procedure Refresh; property ItemsCount: integer read Get_ItemsCount; property Item[N: integer]: TContensItem read Get_Item; property CurrentIndex: integer read Get_CurrentIndex write Set_CurrentIndex; property IsList: boolean read FIsList; property ShowRoot: boolean read FShowRoot write Set_ShowRoot; property RootName: string write Set_RootName; end; TFilledContensInfo = class(TContensInfo) private FOpened: string; FBase,FOffset: integer; protected procedure FillItems(var AItems: TContensArray); override; function IsOpened(const Adr: string): boolean; function ReadItem(const Adr: string; var ADeepness, ASubCount: integer; var APos: wordbool): string; virtual; abstract; function FillAddr(const A: string; var AItems: TContensArray; APos: integer): integer; function CalcItemsCount: integer; override; procedure PrepareToRefresh; override; procedure OpenItem(N: integer); override; procedure CloseItem(N: integer); override; function Get_CurrentIndex: integer; override; procedure Set_CurrentIndex(AIndex: integer); override; function Get_CurrentAddress: string; procedure Set_CurrentAddress(const Adr: string); property CurrentAddress: string read Get_CurrentAddress write Set_CurrentAddress; end; TStringVarList= class(TBaseObject) private FKeys: TAsciizSortedCollector; FValues: TAsciizCollector; protected function Get_Count: integer; function Get_Value(const AKey: string): string; function Get_IntValue(const AKey: string): integer; function Get_KeyByIndex(AIndex: integer): string; function Get_ValueByIndex(AIndex: integer): string; procedure Set_ValueByIndex(AIndex: integer;const V: string); function Get_KeyIndex(const AKey: string): integer; public constructor Create(ADelta: integer); destructor Destroy; override; procedure AddItem(const AKey,AValue: string); function DeleteItem(const AKey: string): integer; procedure ReindexIntValues(AFrom,ADelta: integer); property Count: integer read Get_Count; property Value[const AKey: string]: string read Get_Value; property IntValue[const AKey: string]: integer read Get_IntValue; property Keys[N: integer]: string read Get_KeyByIndex; property Values[N: integer]: string read Get_ValueByIndex write Set_ValueByIndex; property KeyIndex[const AKey: string]:integer read Get_KeyIndex; end; TDLLModule= class(TObject) private FModule: HModule; FModuleFileName: string; function GetAvailable: boolean; function Get_ModuleName: string; public constructor Create(const AModuleFileName: string); destructor Destroy; override; function ProcAddress(const AProcName: string) : pointer; property Available: boolean read GetAvailable; property FileName: string read FModuleFileName; property Name: string read Get_ModuleName; end; function StrVarDistribution(A: Asciiz; GlobSep,LocSep: AnsiChar): TStringVarList; function StrDistribution(A: Asciiz; Sep: AnsiChar): TAsciizCollector; function GetNumAdress(S: string; Sep: char): DIntArray; function ReadlnAC(var T: Text;N : integer): TAsciizCollector; function StrResDistr(AStr:Asciiz;ARes:integer;Sep:Asciiz):TAsciizCollector; function PackObject(O: TBaseObject): pointer; function UnPackObject(R: pointer; AClass: TBaseClass): pointer; procedure DisposePackedObject(R: pointer); procedure PutPackedObject(R: pointer; S: TStream); function GetPackedObject(S: TStream):pointer; procedure ReadPackedObject(var Buf;S: TStream); function GetPackedItemPtr(R: pointer; N: integer; var ASize: integer): pointer; function GetPackedItem(R: pointer; N: integer; AClass: TCollectorClass): pointer; implementation function StrVarDistribution(A: Asciiz; GlobSep,LocSep: AnsiChar): TStringVarList; var AA: TAsciizCollector; S,K,V: string; i: integer; begin AA:=StrDistribution(A,GlobSep); Result:=TStringVarList.Create(8); for i:=0 to AA.Count-1 do begin BreakString(AA.StrAt[i],LocSep,K,V); Result.AddItem(K,V); end; AA.Free; end; function StrDistribution(A: Asciiz; Sep: AnsiChar): TAsciizCollector; var S: Asciiz; I,L,X: integer; R: TAsciizCollector; begin S:=StrNew(A); L:=AsciizLen(A); R:=TAsciizCollector.Create(20); X:=0; if L>0 then begin for I:=0 to L-1 do if S[I]=Sep then begin S[I]:=#0; R.Add(StrNew(@S[X])); S[I]:='#'; X:=I+1; end; R.Add(StrNew(@S[X])); end; StrDispose(S); Result:=R; end; function GetNumAdress(S: string; Sep: char): DIntArray; var A: TAsciizCollector; D: DIntArray; i: integer; begin A:=StrDistribution(PChar(S),Sep); SetLength(D,A.Count); for i:=0 to A.Count-1 do D[i]:=StringToInt(A.At(i)); A.Free; Result:=D; end; function ReadlnAC(var T: Text;N : integer): TAsciizCollector; var i: integer; AC: TAsciizCollector; begin AC:=TAsciizCollector.Create(16); for i:=1 to N do AC.Add(AsciizReadln(T)); Result:=AC; end; function StrResDistr(AStr:Asciiz;ARes:integer;Sep:Asciiz):TAsciizCollector; var X,i,L: integer; R,A: TAsciizCollector; S: Asciiz; begin L:= AsciizLen(AStr); R:=TAsciizCollector.Create(8); if L<=ARes then begin S:=StrNew(AStr); R.Add(S); end else begin X:=ARes-1; while (X>0) and (StrScan(Sep,AStr[X])=NIL) do dec(X); if X=0 then X:=ARes else inc(X); S:=StrAlloc(X+1); {GetMem(S,X+1);} move(AStr^,S^,X); S[X]:=#0; R.Add(S); A:=StrResDistr(@AStr[X],ARes,Sep); if A.Count>0 then for i:=0 to A.Count-1 do begin S:=A.SelectItem(i,NIL); R.Add(S); end; A.Free; end; StrResDistr:=R; end; function AllocObjMem(Bytes: integer): pointer; begin GetMem(Result,Bytes); end; procedure FreeObjMem(var P: pointer;Bytes:integer); begin FreeMem(P); P:=NIL; end; function PackObject(O: TBaseObject): pointer; var R: PObjHeader; S: integer; begin S:=O.PackSize; R:=AllocObjMem(S+SizeOf(Integer)); //GetMem(R,S+SizeOf(integer)); //R:=GlobalAllocPtr(gmem_Fixed,S+SizeOf(integer)); R^.ObjSize:=S; O.PackTo(R^.ObjData); Result:=R; end; procedure PackObjectTo(O: TBaseObject; BufPtr: pointer); var R: PObjHeader; S: integer; begin S:=O.PackSize; R:=BufPtr; //GetMem(R,S+SizeOf(integer)); //R:=GlobalAllocPtr(gmem_Fixed,S+SizeOf(integer)); R^.ObjSize:=S; O.PackTo(R^.ObjData); end; function UnPackObject(R: pointer; AClass: TBaseClass): pointer; var O: PObjHeader; S: integer; begin O:=R; Result:=AClass.Restore(O^.ObjData); end; procedure DisposePackedObject(R: pointer); var O: PObjHeader; begin O:=R; //FreeMem(O,O^.ObjSize+SizeOf(integer)); FreeObjMem(R,O^.ObjSize+SizeOf(integer)); end; procedure PutPackedObject(R: pointer; S: TStream); var O: PObjHeader; begin O:=R; S.Write(O^,O^.ObjSize+SizeOf(Integer)); end; function GetPackedObject(S: TStream):pointer; var O: PObjHeader; Z: integer; begin S.Read(Z,SizeOf(Integer)); O:=AllocObjMem(Z+SizeOf(integer)); //GetMem(O,Z+SizeOf(Integer)); O^.ObjSize:=Z; S.Read(O^.ObjData,Z); Result:=O; end; procedure ReadPackedObject(var Buf;S: TStream); var O: PObjHeader; Z: integer; begin S.Read(Z,SizeOf(Integer)); O:=@Buf; // GetMem(O,Z+SizeOf(Integer)); O^.ObjSize:=Z; S.Read(O^.ObjData,Z); //Result:=O; end; function GetPackedItemPtr(R: pointer; N: integer; var ASize: integer): pointer; var O: PObjHeader; A: integer; begin O:=R; if N=0 then A:=O.Count*SizeOf(Integer) else A:=O^.IAT[N-1]; ASize:=O^.IAT[N]-A; Result:=@O^.ObjData[SizeOf(integer)*2+A]; end; function GetPackedItem(R: pointer; N: integer; AClass: TCollectorClass): pointer; var O: PObjHeader; S: integer; I: pointer; begin O:=R; I:=GetPackedItemPtr(R,N,S); Result:=AClass.RestoreItem(I^,S); end; {TBaseObject} function TBaseObject._Release: Integer; begin Result := InterlockedDecrement(FRefCount); {if Result = 0 then Destroy;} end; constructor TBaseObject.Load(S: TStream); begin inherited Create; end; procedure TBaseObject.Store(S: TStream); begin end; function TBaseObject.BaseClassType:TBaseClass; begin BaseClassType:=TBaseClass(ClassType); end; constructor TMultiObject.Restore(var Buf); var B: PByteArray; S: pointer; Z: integer; begin Move(Buf,FCount,SizeOf(FCount)); B:=@Buf; S:=@B^[SizeOf(FCount)]; Move(S^,Z,SizeOf(integer)); S:=@B^[SizeOf(integer)*2+Z]; RestoreSelf(S^); S:=@B^[SizeOf(integer)*2]; RestoreItems(S^); end; class function TMultiObject.PointerToSelfPack(P: pointer): pointer; var PP: pointer; Z: integer; begin PP:=Pointer(Integer(P)+SizeOf(Integer)); Move(PP^,Z,SizeOf(Z)); Result:=Pointer(Integer(P)+SizeOf(Integer)*2+Z); end; function TMultiObject.GetSelfPackSize: integer; begin Result:=0; end; function TMultiObject.GetPackSize: integer; begin Result:=GetSelfPackSize+SizeOf(integer)*2+GetItemsPackSize; end; procedure TMultiObject.InitializeItem(AItem: pointer); begin end; procedure TMultiObject.PackTo(var Buf); var A: PIntArray; B: PByteArray; O,S: integer; D: pointer; begin A:=@Buf; Move(FCount,Buf,SizeOf(FCount)); O:=SizeOf(FCount); S:=GetItemsPackSize; B:=@Buf; D:=@B^[O]; Move(S,D^,SizeOf(S)); inc(O,SizeOf(S)); D:=@B^[O]; PackItems(D^); Inc(O,S); D:=@B^[O]; PackSelf(D^); //ShowMessage(IntToStr(A[0])); end; function TBaseObject.Connect(H: TObject): integer; var HH: TObjectCollector; begin HH:=Get_Handles; if HH<>NIL then Result:=HH.PlaceItem(H); end; procedure TBaseObject.Disconnect(H: TObject); var HH: TObjectCollector; begin HH:=Get_Handles; if HH<>NIL then HH.ReplaceItem(H); end; function TBaseObject.Get_Handles: pointer; begin Result:=NIL; end; { TStorage } constructor TStorage.Create(AItemSize,ADelta: integer); begin inherited Create; FItemSize:=AItemSize; FDeltaSize:=FItemSize*ADelta; if FDeltaSize<=0 then FDeltaSize:=FItemSize*16; FCount:=0; FCapacitySize:=FDeltaSize; GetMem(FStorage,FCapacitySize); end; destructor TStorage.Destroy; begin FreeMem(FStorage); Inherited Destroy; end; constructor TStorage.Load(S: TStream); var C: integer; begin inherited Create; S.Read(FCount,4); S.Read(FItemSize,4); S.Read(FDeltaSize,4); S.Read(FCapacitySize,4); C:=FCount*FItemSize; GetMem(FStorage,C+FCapacitySize); S.Read(FStorage^,C); end; procedure TStorage.Store(S:TStream); begin S.Write(FCount,4); S.Write(FItemSize,4); S.Write(FDeltaSize,4); S.Write(FCapacitySize,4); S.Write(FStorage^,FCount*FItemSize); end; procedure TStorage.Insert(Index: integer; var X); var S: integer; P: pointer; begin if FCapacitySize=0 then begin S:=FCount*FItemSize; FCapacitySize:=(FCount shr 4)*FItemSize; if FCapacitySize<FDeltaSize then FCapacitySize:=FDeltaSize; GetMem(P,S+FCapacitySize); Move(FStorage^,P^,S); FreeMem(FStorage); FStorage:=P; end; P:=pointer(cardinal(FStorage)+(Index*FItemSize)); S:=(FCount-Index)*FItemSize; if S<>0 then Move(P^,pointer(cardinal(P)+FItemSize)^,S); Move(X,P^,FItemSize); {if S=0 then begin Move(X,Pointer(Integer(FStorage)+Index*FItemSize)^,FItemSize) end else asm push EDI push ESI pushfd mov EAX,Self mov EBX,[EAX].TStorage.FCount inc EBX mov EAX,[EAX].TStorage.FItemSize imul EBX mov EDI,EAX dec EDI mov EAX,Self add EDI,[EAX].TStorage.FStorage mov ESI,EDI sub ESI,[EAX].TStorage.FItemSize mov ECX,S or ECX,ECX jz @Z std rep movsb @Z: mov EBX,[EAX].TStorage.FItemSize mov EAX,Index imul EBX mov EDI,EAX mov EAX,Self add EDI,[EAX].TStorage.FStorage mov ESI,X mov ECX,[EAX].TStorage.FItemSize cld rep movsb popfd pop ESI pop EDI end;} inc(FCount); dec(FCapacitySize,FItemSize); end; procedure TStorage.DeleteItems(Index, ACount: integer); var Z,M: integer; S,D: pointer; begin Z:=ACount*FItemSize; D:=Ptr(Integer(FStorage)+Index*FItemSize); S:=Ptr(Integer(D)+Z); M:=(FCount-Index)*FItemSize-Z; move(S^,D^,M); inc(FCapacitySize,Z); dec(FCount,ACount); end; function TStorage.Get_ItemPtr(Index: integer): pointer; begin Result:=ShiftPtr(FStorage,Index*FItemSize); end; procedure TStorage.GetItem(Index:integer; var X); begin asm pushad mov EAX,Self mov ESI,[EAX].TStorage.FStorage mov EBX,Index mov ECX,[EAX].TStorage.FItemSize mov EAX,ECX imul EBX add ESI,EAX mov EDI,X cld rep movsb popad end; end; procedure TStorage.SetItem(Index: integer; var X); begin asm pushad mov EAX,Self mov EDI,[EAX].TStorage.FStorage mov EBX,Index mov ECX,[EAX].TStorage.FItemSize mov EAX,ECX imul EBX add EDI,EAX mov ESI,X cld rep movsb popad end; end; function TStorage.GetCapacity: integer; begin Result:= FCapacitySize div FItemSize; end; procedure TStorage.SetCapacity(C: integer); var S,NCS: integer; F: pointer; begin S:=FCount*FItemSize; NCS:=C*FItemSize; GetMem(F,S+NCS); Move(FStorage^,F^,S); FreeMem(FStorage); FCapacitySize:=NCS; FStorage:=F; end; procedure TStorage.SetCount(C: integer); var D: integer; P: pointer; begin D:=FCount-C; if D>=0 then begin FCapacitySize:=FCapacitySize+D*FItemSize; FCount:=C; end else begin GetMem(P,C*FItemSize+FCapacitySize); FillChar(P^,C*FItemSize,0); move(FStorage^,P^,FCount*FItemSize); FreeMem(FStorage); FStorage:=P; FCount:=C; end; end; {TIntStorage} constructor TIntStorage.Create(ADelta: integer); begin Inherited Create(SizeOf(integer),ADelta); end; function TIntStorage.CreateArray: DIntArray; var D: pointer; begin SetLength(Result,FCount); if FCount>0 then begin D:=@Result[0]; Move(FStorage^,D^,FCount*4) end; end; function TIntStorage.GetInt(Index: integer): integer; begin GetItem(Index,Result); end; procedure TIntStorage.InsertWithShift(Index, X: integer); begin IncIntegersFrom(FStorage,FCount,X); Insert(Index,X); end; procedure TIntStorage.DeleteWithShift(AFrom, ACount: integer); var i,X,S,Z,Lim: integer; A: PIntArray; begin if ACount<=0 then Exit; S:=0; Lim:=AFrom+ACount; A:=FStorage; for i:=0 to FCount-1 do begin X:=A[i]; if X>=AFrom then begin if X>=Lim then begin X:=X-ACount; A[S]:=X; inc(S); end; end else begin A[S]:=X; inc(S); end; end; FCapacitySize:=FCapacitySize+(FCount-S)*FItemSize; FCount:=S; end; procedure TIntStorage.SetInt(Index: integer; X: integer); begin {asm pushad mov EAX,Self mov EDI,[EAX].TStorage.FStorage mov EBX,Index mov ECX,[EAX].TStorage.FItemSize mov EAX,ECX imul EBX add EDI,EAX mov EDX,X mov [EDI],EDX popad end;} PIntArray(FStorage)[Index]:=X; end; function TIntStorage.Get_ItemPos(AItem: integer): integer; begin Result:=ScanInteger(AItem,FStorage,FCount); end; function TIntStorage.Get_SelfCopy: pointer; var C: TIntStorage; i: integer; begin C:=TIntStorage.Create(FDeltaSize div FItemSize); C.Count:=FCount; for i:=0 to FCount-1 do C.Item[i]:=Item[i]; Result:=C; end; {TSortObj} constructor TSortObj.Create; begin inherited Create; @FComp:=@AsciizPtrComp; FDir:=-1; FUserIndex:=false; FSort:=TIntStorage.Create(64); end; destructor TSortObj.Destroy; begin FSort.Free; inherited Destroy; end; constructor TSortObj.Load(S: TStream); begin @FComp:=@AsciizPtrComp; S.Read(FDir,SizeOf(FDir)); FSort:=TIntStorage.Load(S); FUserIndex:=false; end; procedure TSortObj.Store(S:TStream); begin S.Write(FDir,SizeOf(FDir)); FSort.Store(S); end; function TSortObj.FindBorderIndex(Atr: pointer; ADir: integer): integer; var CN,Left,Right,Cent,D: integer; A: pointer; begin CN:=FSort.FCount; Result:=-1; if CN=0 then Exit; Left:=0; Right:=CN-1; Cent:=(Left+Right) div 2; while (Left<Cent) and (Cent<Right) do begin A:=GetAttr(FSort.Item[Cent]); D:=FComp(A,Atr); DisposeAttr(A); if D=0 then begin if ADir=1 then Left:=Cent else Right:=Cent; end else if D=FDir then Left:=Cent else Right:=Cent; Cent:=(Left+Right) div 2; end; if ADir=1 then begin A:=GetAttr(FSort.Item[Left]); D:=FComp(Atr,A); DisposeAttr(A); if not(D=FDir) then begin A:=GetAttr(FSort.Item[Right]); D:=FComp(Atr,A); DisposeAttr(A); if D=FDir then Result:=Left else Result:=Right; end; end else begin A:=GetAttr(FSort.Item[Right]); D:=FComp(A,Atr); DisposeAttr(A); if not(D=FDir) then begin A:=GetAttr(FSort.Item[Left]); D:=FComp(A,Atr); DisposeAttr(A); if D=FDir then Result:=Right else Result:=Left; end end; end; function TSortObj.FindPlace(Atr: pointer): integer; var CN,Left,Right,Cent,D: integer; A: pointer; begin CN:=FSort.FCount; case CN of 0: Result:=0; 1: begin A:=GetAttr(FSort.Item[0]); if FComp(A,Atr)=FDir then Result:=1 else Result:=0; DisposeAttr(A); end; else begin Left:=0; Right:=CN-1; Cent:=(Left+Right) div 2; while (Left<Cent) and (Cent<Right) do begin A:=GetAttr(FSort.Item[Cent]); D:=FComp(A,Atr); {if D=0 then begin Result:=Cent; Exit; end;} DisposeAttr(A); if D=FDir then Left:=Cent else Right:=Cent; Cent:=(Left+Right) div 2; end; A:=GetAttr(FSort.Item[Left]); D:=FComp(A,Atr); //ShowMessage(IntToStr(Left)+' '+StrPas(PChar(Atr))); DisposeAttr(A); if not(D=FDir) then begin Result:=Left; end else begin A:=GetAttr(FSort.Item[Right]); D:=FComp(A,Atr); DisposeAttr(A); if D=FDir then Result:=Right+1 else Result:=Right; end; end; end; {case} end; function TSortObj.Found(Attr: pointer): integer; var CN,Left,Right,Cent,D,R: integer; A,Atr: PChar; begin Atr:=Attr; {if Atr='513' then begin ShowMessage(Atr); Result:=-1; end;} CN:=FSort.FCount; case CN of 0: R:=-1; 1: begin A:=GetAttr(FSort.Item[0]); if FComp(A,Atr)=0 then R:=0 else R:=-1; DisposeAttr(pointer(A)); end; else begin Left:=0; Right:=CN-1; Cent:=(Left+Right) div 2; while (Left<Cent) and (Cent<Right) do begin A:=GetAttr(FSort.Item[Cent]); D:=FComp(A,Atr); DisposeAttr(pointer(A)); if D=FDir then Left:=Cent else Right:=Cent; Cent:=(Left+Right) div 2; end; A:=GetAttr(FSort.Item[Left]); D:=FComp(A,Atr); DisposeAttr(pointer(A)); if D=0 then begin R:=Left; end else begin A:=GetAttr(FSort.Item[Right]); D:=FComp(A,Atr); DisposeAttr(pointer(A)); if D=0 then R:=Right else R:=-1; end; end; end; {case} if R=-1 then Result:=-1 else Result:=FSort.Item[R]; end; procedure TSortObj.SortAll; var C,P,i,X: integer; A: pointer; begin FSort.Count:=0; C:= GetCount; if C>0 then for i:=0 to C-1 do begin A:=GetAttr(i); P:=FindPlace(A); DisposeAttr(A); X:=i; FSort.Insert(P,X); if Assigned(FOnSortAllProgress) then FOnSortAllProgress(Self, i); end; end; procedure TSortObj.SetDir(D: integer); begin if (D<>FDir) and ((D=1) or (D=-1)) then begin FDir:=D; SortAll; end; end; procedure TSortObj.DisposeAttr(var A: pointer); begin StrDispose(A); end; procedure TSortObj.AddAttr(A: pointer); var C,P: integer; begin C:=GetCount; P:=FindPlace(A); FSort.Insert(P,C); end; procedure TSortObj.InsertAttr(A: pointer; N: integer); var P: integer; S: string; begin //S:=StrPas(PChar(A)); P:=FindPlace(A); if N<FSort.Count then FSort.InsertWithShift(P,N) else FSort.Insert(P,N); //S:='P='+IntToStr(P)+' N='+IntToStr(N)+' '+S; //ShowMessage(S); end; procedure TSortObj.RemoveAttrIndex(N: integer); var I: integer; begin I:=FSort.Get_ItemPos(N); if I>=0 then FSort.DeleteItems(I,1); end; function TSortObj.Get_SortedN(AIndex: integer): integer; begin Result:=FSort.GetInt(AIndex); end; function TSortObj.GetInsPos(Atr: pointer): integer; var N: integer; begin N:=FindPlace(Atr); if N<GetCount then Result:=FSort.Item[N] else Result:=N; end; {TSortTest} constructor TSortTest.Create; var A: Asciiz; i: integer; begin Inherited Create; FCount:=0; for i:=0 to 9 do begin A:=GetAttr(i); AddAttr(A); StrDispose(A); inc(FCount); end; end; function TSortTest.GetCount: integer; begin GetCount:=FCount; end; function TSortTest.GetAttr(N: integer): pointer; const VCount= 10; Values: array[0..VCount-1] of integer= ( 123,323,555,344,444,999,666,566,444,612); begin GetAttr:=AsciizStrInt(Values[N]); end; procedure TSortTest.ShowValues; var A: Asciiz; i: integer; begin for i:= 0 to FCount-1 do begin A:=GetAttr(FSort.Item[i]); writeln(A); StrDispose(A); end; end; {TCollector} constructor TCollector.Create(ADelta: integer); begin inherited Create; FDelta:=ADelta; if FDelta<=0 then FDelta:=64; FCapacity:=FDelta; GetMem(FItems,FCapacity*4); FCount:=0; end; function TCollector.GetItemPtr(N: integer): pointer; begin Result:=FItems[N]; end; procedure TCollector.RestoreSelf(var Buf); var A: PIntArray; begin A:=@Buf; FDelta:=A^[0]; FCapacity:=A^[1]; end; procedure TCollector.RestoreItems(var Buf); var i,O,Z: integer; A: PIntArray; B: PByteArray; S: pointer; begin A:=@Buf; B:=@Buf; O:=FCount*SizeOf(O); GetMem(FItems,AllMem); if FCount>0 then for i:=0 to FCount-1 do begin S:=@B^[O]; Z:=A^[i]-O; if Z>0 then begin FItems[i]:=RestoreItem(S^,Z); InitializeItem(FItems[i]); end else FItems[i]:=NIL; O:=A^[i]; end; end; function TCollector.GetSelfPackSize: integer; begin Result:=SizeOf(FDelta)+SizeOf(FCapacity); end; function TCollector.GetItemsPackSize: integer; var i,R: integer; P : pointer; begin R:=FCount*SizeOf(integer); if FCount>0 then for i:=0 to FCount-1 do begin P:=GetItemPtr(i); if P<>NIL then Inc(R,GetItemPackSize(P)); end; Result:=R; end; procedure TCollector.PackSelf(var Buf); var A: PIntArray; begin A:=@Buf; A^[0]:=FDelta; A^[1]:=FCapacity; end; procedure TCollector.PackItems(var Buf); var A: PIntArray; B: PByteArray; i,O,X,S: integer; P,D: pointer; begin O:=FCount*SizeOf(O); X:=0; B:=@Buf; A:=@Buf; if FCount>0 then for i:=0 to FCount-1 do begin P:=GetItemPtr(i); D:=@B^[O]; S:=GetItemPackSize(P); PackItem(D^,P,S); if P<>NIL then Inc(O,S); D:=@B^[X]; //Move(O,D^,SizeOf(O)); A^[i]:=O; inc(X,SizeOf(O)); end; end; procedure TCollector.SetCount(N: integer); begin if N<0 then Exit; while FCount<N do Add(NIL); while FCount>N do Delete(FCount-1); end; destructor TCollector.Destroy; var i: integer; begin if FCount>0 then for i:=0 to FCount-1 do if FItems[i]<>NIL then DisposeItem(FItems[i]); FreeMem(FItems); Inherited Destroy; end; constructor TCollector.Load(S: TStream); var i : integer; begin S.Read(FCount,4); S.Read(FDelta,4); S.Read(FCapacity,4); GetMem(FItems,AllMem); if FCount>0 then for i:=0 to FCount-1 do begin FItems[i]:=LoadItem(S); if FItems[i]<>NIL then InitializeItem(FItems[i]); end; end; procedure TCollector.Store(S:TStream); var i : integer; begin S.write(FCount,4); S.write(FDelta,4); S.Write(FCapacity,4); if FCount>0 then for i:=0 to FCount-1 do StoreItem(S,FItems[i]); end; function TCollector.AllMem: integer; begin AllMem:=(FCount+FCapacity)*4; end; procedure TCollector.DisposeItem(var p:pointer); begin end; procedure TCollector.Clear(N: integer); begin if FItems^[N]<>NIL then DisposeItem(FItems^[N]); FItems[N]:=NIL; end; procedure TCollector.Delete(N:integer); var D,S: pointer; begin S:=FItems^[N]; FItems^[N]:=NIL; if S<>NIL then DisposeItem(S); if N+1<FCount then begin D:=@FItems^[N]; S:=@FItems^[N+1]; move(S^,D^,(FCount-N-1)*4); end; dec(FCount); inc(FCapacity); if FCapacity=2*FDelta then begin GetMem(D,(FCount+FDelta)*4); move(FItems^,D^,FCount*4); FreeMem(FItems); FItems:=D; FCapacity:=FDelta; end; end; function TCollector.At(n:integer):pointer; begin At:=FItems^[N]; end; function TCollector.ItemIndex(AItem: pointer): integer; var i: integer; begin Result:=-1; i:=0; while (i<FCount) and (Result=-1) do begin if FItems^[i]=AItem then Result:=i; inc(i); end; end; {function TCollector.ItemIndex(AItem: pointer): integer;assembler; asm push EDI push ECX pushf mov ECX,[EAX].FCount or ECX,ECX jz @NF mov EDI,[EAX].FItems mov EAX,AItem cld repne scasd je @F @NF: mov EAX,-1 jmp @E @F: mov EAX,ECX @E: popf pop ECX pop EDI end;} function TCollector.SelectItem(N: integer; AItem: pointer):pointer; begin if (N>=0) and (N<FCount) then begin Result:=FItems^[N]; FItems^[N]:=AItem; end else Result:=NIL; end; procedure TCollector.ShiftFrom(N: integer); assembler; asm pushad pushf mov ECX,[EAX].FCount mov EDI,ECX shl EDI,2 add EDI,[EAX].FItems mov ESI,EDI sub ESI,4 mov EBX,[ESI] sub ECX,N std rep movsd mov EBX,[EDI+4] popf popad end; procedure TCollector.Insert(N: integer; AItem: pointer); var P : pointer; begin if FCapacity=0 then begin GetMem(P,(FCount+FDelta)*4); move(FItems^,P^,FCount*4); FreeMem(FItems); FItems:=P; FCapacity:=FDelta; end; if N<FCount then ShiftFrom(N); FItems^[N]:=AItem; inc(FCount); dec(FCapacity); end; function TCollector.Include(AItem: pointer): integer; var N: integer; begin N:=ItemIndex(NIL); if N=-1 then N:=FCount; Insert(N,AItem); Include:=N; end; function TCollector.Add(AItem: pointer): integer; begin Insert(FCount,AItem); Result:=FCount; end; function TCollector.GetFreePlace: integer; var i,U: integer; begin i:=0; U:=-1; while (i<FCount) and (U=-1) do begin if FItems[i]=NIL then U:=i; inc(i); end; if U=-1 then begin U:=FCount; Add(NIL); end; GetFreePlace:=U; end; procedure TCollector.SetItem(N: integer; P: pointer); begin if N>=FCount then Count:=N+1; Clear(N); FItems[N]:=P; end; function TCollector.PlaceItem(P: pointer): integer; begin {ShowMessage('PI1');} Result:=GetFreePlace; Items[Result]:=P; {ShowMessage('PI2');} end; procedure TCollector.ReplaceItem(P: pointer); var I: integer; begin I:= ItemIndex(P); if I>=0 then FItems[I]:=NIL; Squeeze; end; procedure TCollector.Squeeze; var i: integer; begin i:= FCount-1; while (i>=0) and (FItems[i]=NIL) do begin Delete(i); Dec(i); end; end; function TCollector.GetExCount: integer; var i: integer; begin Result:=0; if FCount>0 then for i:=0 to FCount-1 do if FItems[i]<>NIL then inc(Result); end; procedure TCollector.ExcludeItem(AIndex: integer); begin FItems[AIndex]:=NIL; Delete(AIndex); end; {TObjectCollector} procedure TObjectCollector.DisposeItem(var p:pointer); var O: TObject; begin O:=p; if O<>NIL then O.Free; end; function TObjectCollector.At(N: integer): TObject; begin At:=FItems[N]; end; {TAutoObjectCollector} procedure TAutoObjectCollector.DisposeItem(var p:pointer); var A: TAutoObject; begin if p<>NIL then begin A:=p; A.ObjRelease; end; p:=NIL; end; function TAutoObjectCollector.At(N: integer): TAutoObject; begin Result:=FItems[N]; end; {TClassCollector} function TClassCollector.LoadItem(S: TStream):pointer; begin LoadItem:=ItemClass.Load(S); end; procedure TClassCollector.StoreItem(S: TStream; AItem: pointer); var O: TBaseObject; begin O:=AItem; O.Store(S); end; {TAsciizCollector} class procedure TAsciizCollector.PackItem(var Buf; AItem: pointer; ASize: integer); begin Move(AItem^,Buf,ASize); end; class function TAsciizCollector.RestoreItem(var Buf; ASize: integer): pointer; var A: Asciiz; begin if ASize>0 then begin A:=StrAlloc(ASize+1); Move(Buf,A^,ASize); A[ASize]:=#0; Result:=A; end else Result:=NIL; end; function TAsciizCollector.GetItemPackSize(P: pointer): integer; begin Result:=AsciizLen(P); end; procedure TAsciizCollector.DisposeItem(var p:pointer); begin StrDispose(p); end; function TAsciizCollector.At(n:integer): Asciiz; begin At:=FItems[N]; end; {$I-} procedure TAsciizCollector.WritelnTo(var T: Text); var i: integer; begin if FCount>0 then for i:=0 to FCount-1 do WritelnAsciiz(T,At(i)); end; {$I+} function TAsciizCollector.TotLength: integer; var i: integer; begin Result:=0; if FCount>0 then for i:=0 to FCount-1 do inc(Result,AsciizLen(At(i))); end; function TAsciizCollector.TotString(C: Char): string; var i: integer; S: string; begin S:=''; if FCount>0 then for i:=0 to FCount-1 do begin S:=S+string(At(i)); if i+1<FCount then S:=S+C; end; //ShowMessage(IntToStr(Ord(C))+' '+S); Result:=S; end; procedure TAsciizCollector.ReadlnFrom(var T: text; N: integer); var i : integer; S : string; begin for i:=1 to N do begin Readln(T,S); Add(PasAsciiz(S)); end; end; function TAsciizCollector.LoadItem(S: TStream): pointer; begin Result:=LoadAsciiz(S); end; procedure TAsciizCollector.StoreItem(S: TStream; AItem: pointer); begin StoreAsciiz(S,AItem); end; function TAsciizCollector.Get_MaxCompatibleLevel(A: Asciiz): integer; var i,L: integer; begin Result:=0; if (AsciizLen(A)=0) or (FCount=0) then Exit; for i:=0 to FCount-1 do begin L:=StringCompatibleLevel(A,FItems[i]); if L> Result then Result:=L; end; end; function TAsciizCollector.Get_MaxCompatibleLevelMulti( A: TAsciizCollector): integer; var i: integer; begin Result:=0; if A.Count=0 then Exit; for i:=0 to A.Count-1 do Result:=Result+Get_MaxCompatibleLevel(A.At(i)); end; function TAsciizCollector.Get_StrAt(AIndex: integer): string; begin if (AIndex>=0) and (AIndex<FCount) then Result:=String(At(AIndex)) else Result:=''; end; procedure TAsciizCollector.Set_StrAt(AIndex: integer; const AStr: string); var i: integer; begin if AIndex<FCount then begin StrDispose(FItems[AIndex]); FItems[AIndex]:=StrNew(PChar(AStr)); end else begin for i:=FCount to AIndex do Add(NIL); FItems[AIndex]:=StrNew(PChar(AStr)); end; end; function TAsciizCollector.IndexOfStr(const Str: String): Integer; begin for Result := 0 to FCount-1 do if String(At(Result)) = Str then Exit; Result := -1; end; procedure TAsciizCollector.AddString(const S: string); begin Add(StrNew(PChar(S))); end; procedure TAsciizCollector.WinToDos; var i: integer; begin for i:=0 to FCount-1 do ComUnit.WinToDos(FItems[i]); end; function TAsciizCollector.ExistDuplicate: boolean; var i,j: integer; begin Result:=false; if FCount<2 then Exit; i:=0; while (i<FCount-1) and (not Result) do begin j:=i+1; while (j<FCount) and (not Result) do begin Result:=AnsiStrComp(FItems[i],FItems[j])=0; inc(j); end; inc(i); end; end; procedure TAsciizCollector.EraseDuplicates; var i,j: integer; begin if FCount<2 then Exit; i:=0; while (i<FCount-1) do begin j:=i+1; while (j<FCount) do begin if AnsiStrComp(FItems[i],FItems[j])=0 then Delete(j) else inc(j); end; inc(i); end; end; function TAsciizCollector.SuchAsStr(Str: Asciiz): integer; var i: integer; begin Result:=-1; i:=0; while (i<FCount) and (Result=-1) do begin if AnsiStrIComp(Str,FItems[i])=0 then Result:=i; inc(i); end; end; function TAsciizCollector.SuchAs(const Str: string): integer; begin Result:=SuchAsStr(PChar(Str)); end; {TLimb} constructor TLimb.Create(AOwner: TLimb); begin inherited Create(16); FOwner:=AOwner; end; constructor TLimb.Load(S: TStream); var i: integer; begin inherited Load(S); FOwner:=NIL; if FCount>0 then for i:=0 to FCount-1 do At(i).FOwner:=Self; end; function TLimb.Deepness:integer; begin if FOwner=NIL then Result:=0 else Result:=FOwner.Deepness+1; end; function TLimb.GetSub(X: DIntArray; N: integer): pointer; begin if N+1<= Length(X) then Result:=At(X[N]).GetSub(X,N+1) else Result:=Self; end; function TLimb.GetSubCount: integer; var R,i: integer; begin R:=FCount; if FCount>0 then for i:=0 to FCount-1 do R:=R+At(i).GetSubCount; Result:=R; end; function TLimb.At(N: integer): TLimb; begin At:= FItems[N]; end; function TLimb.IsIncludedIn(L: TLimb): boolean; begin if L=Self then Result:=true else if FOwner=L then Result:= true else if FOwner=NIL then Result:= false else Result:=FOwner.IsIncludedIn(L); end; function TLimb.WhereSub(L: TLimb): integer; var i: integer; begin i:=0; Result:=-1; while (i<FCount) and (Result=-1) do begin if L.IsIncludedIn(At(i)) then Result:=i; inc(i); end; end; function TLimb.LoadItem(S:TStream):pointer; begin LoadItem:=BaseClassType.Load(S); end; procedure TLimb.StoreItem(S:TStream; AItem: pointer); var A: TBaseObject; begin A:=AItem; (A as BaseClassType).Store(S); end; function TLimb.GetItemByText(Adr: string): pointer; var D: DIntArray; begin D:=GetNumAdress(Adr,','); Result:=GetSub(D,1); end; function TLimb.AbsLast: pointer; begin if FCount=0 then Result:=Self else Result:=At(FCount-1).AbsLast; end; function TLimb.GetLast(ADeepness: integer): pointer; begin if (FCount=0) or (ADeepness<=Deepness) then Result:=Self else Result:=At(FCount-1).GetLast(ADeepness); end; procedure TLimb.Insert(N: integer; AItem: pointer); begin TLimb(AItem).FOwner:=Self; Inherited Insert(N,AItem); end; function TLimb.IsRoot: boolean; begin Result:=(FOwner=NIL) or (FOwner=Self); end; function TLimb.Get_Root: TLimb; begin if IsRoot then Result:=Self else Result:=FOwner.Get_Root; end; function TLimb.Get_Next: pointer; begin if FCount>0 then Result:=FItems^[0] else if IsRoot then Result:=NIL else Result:=FOwner.Get_NextAfter(Self); end; function TLimb.Get_NextAfter(L: TLimb): TLimb; var N: integer; begin N:=ItemIndex(L); if not(N+1=FCount) then Result:=FItems^[N+1] else if IsRoot then Result:=NIL else Result:=FOwner.Get_NextAfter(Self); end; function TLimb.Get_Prev: pointer; var N: integer; begin if (IsRoot) then begin Result:=Self; Exit; end; N:=FOwner.ItemIndex(Self); if N=0 then begin Result:=FOwner; Exit; end; Result:=FOwner.At(N-1).AbsLast; end; function TLimb.CreatePath: DIntArray; var D: integer; C: TLimb; begin D:=Deepness; SetLength(Result,D); C:=Self; while D>0 do begin dec(D); if C.FOwner<>NIL then Result[D]:=C.FOwner.ItemIndex(C); C:=C.FOwner; end; end; function TLimb.GotoPath(P: DIntArray): pointer; var R: TLimb; D,i: integer; begin D:=Length(P); R:=Self; i:=0; while i<D do begin if P[i]>=R.Count then begin Result:=nil; Exit; end; R:=R.At(P[i]); inc(i); end; Result:=R; end; function TLimb.GetItemByAddress(const A: string; var D: integer): pointer; var P: DIntArray; i: integer; X: TLimb; begin P:=GetNumAdress(A,','); D:=Length(P); X:=Self; if D>0 then for i:=0 to D-1 do X:=X.At(P[i]); Result:=X; end; function TLimb.GetStrAddress: string; var S: string; X: TLimb; begin X:=Self; S:=''; while not(X.IsRoot) do begin if Length(S)>0 then S:=','+S; S:=IntToStr(X.FOwner.ItemIndex(X))+S; X:=X.FOwner; end; Result:=S; end; function TLimb.Get_MaxDeepnessFromSelf: integer; var i,R: integer; begin Result:=0; if Count>0 then begin for i:=0 to Count-1 do begin R:=At(i).Get_MaxDeepnessFromSelf; if R>Result then Result:=R; end; inc(Result); end; end; { TSortedStorage } procedure TSortedStorage.Add(var X); begin Insert(FStorage.Count,X); end; constructor TSortedStorage.Create(AItemSize, ADelta: integer;AComp: TListSortCompare); begin inherited Create; FStorage:=TStorage.Create(AItemSize,ADelta); FComp:=AComp; end; destructor TSortedStorage.Destroy; begin FStorage.Free; inherited Destroy; end; procedure TSortedStorage.DisposeAttr(var A: pointer); begin end; function TSortedStorage.GetAttr(N: integer): pointer; begin Result:=FStorage.Get_ItemPtr(N); end; function TSortedStorage.GetCount: integer; begin Result:=FStorage.Count; end; procedure TSortedStorage.Insert(Index: integer; var X); begin InsertAttr(@X,Index); FStorage.Insert(Index,X); end; { TStrucAdress } constructor TStrucAdress.Create; begin Inherited Create(8); end; function TStrucAdress.IsEqualPath(A: TStrucAdress): boolean; var i,M: integer; begin M:=FCount; if A.FCount<M then M:=A.FCount; i:=0; Result:=true; while (i<M) and (Result) do begin if GetInt(i)<>A.GetInt(i) then Result:=false; inc(i); end; end; { TContensInfo } procedure TContensInfo.ClickItem(AIndex: integer); begin if FIsList then begin Set_CurrentIndex(AIndex); Exit; end; with FItems[AIndex] do if SubCount>0 then if Opened then CloseItem(AIndex) else OpenItem(AIndex) else Set_CurrentIndex(AIndex); end; constructor TContensInfo.Create(AsList: boolean); begin inherited Create; FShowRoot:=false; FRootName:=''; SetLength(FItems,0); FIsList:=AsList; end; function TContensInfo.CutAddress(const A: string;var Offset: integer): string; var S: string; P,L: integer; begin S:=A; L:=Length(S); P:=L; while (P>0) and (S[P]<>',') do Dec(P); if P=0 then begin Result:=''; Offset:=StringToInt(S); end else begin Result:=Copy(S,1,P-1); Offset:=StringToInt(copy(S,P+1,L-P)); end; end; destructor TContensInfo.Destroy; begin SetLength(FItems,0); inherited Destroy; end; function TContensInfo.Get_Item(N: integer): TContensItem; begin Result:=FItems[N]; end; function TContensInfo.Get_ItemsCount: integer; begin Result:=Length(FItems); end; procedure TContensInfo.Refill; begin SetLength(FItems,CalcItemsCount); FillItems(FItems); end; procedure TContensInfo.Refresh; begin PrepareToRefresh; Refill; if (FShowRoot) and (Length(FItems)>0) then FItems[0].Text:=FRootName; end; procedure TContensInfo.Set_RootName(const ARootName: string); begin FRootName:=ARootName; if (FShowRoot) and (Length(FItems)>0) then FItems[0].Text:=FRootName; end; procedure TContensInfo.Set_ShowRoot(AShowRoot: boolean); begin FShowRoot:=AShowRoot; Refresh; end; { TFilledContensInfo } procedure TFilledContensInfo.FillItems(var AItems: TContensArray); var D,C,i,P,OP: integer; ExP: wordbool; begin if (FOpened='') or (FShowRoot) then FBase:=0; ReadItem('',D,C,ExP); P:=0; if FShowRoot then P:=P+FillAddr('',AItems,P) else if C>0 then for i:=0 to C-1 do begin P:=P+FillAddr(IntToStr(i),AItems,P); //if i=18 then ShowMessage(IntToStr(P)); end; if (FShowRoot) and (Length(FItems)>0) then begin FItems[0].Text:=FRootName; FItems[0].IsPos:=ExP; end; end; function TFilledContensInfo.FillAddr(const A: string;var AItems: TContensArray; APos: integer): integer; var R: TContensItem; D,C,i,j,P,N: integer; AA: string; begin if A=FOpened then FBase:=APos; R.Opened:=IsOpened(A); R.Address:=A; R.Text:=ReadItem(A,R.Deepness,R.SubCount,R.IsPos); AItems[APos]:=R; j:=APos; if j=0 then begin AItems[j].Prev:=-1; end else begin N:=-1; while (N=-1) and (j>0) do begin dec(j); if AItems[j].Deepness=R.Deepness then N:=j; end; AItems[APos].Prev:=N; if N>=0 then AItems[N].Next:=APos; end; P:=APos+1; if A='' then AA:='' else AA:=A+','; if (R.SubCount>0) and (R.Opened) then begin for i:=0 to R.SubCount-1 do begin P:=P+FillAddr(AA+IntToStr(i),AItems,P); end; end; Result:=P-APos; end; function TFilledContensInfo.IsOpened(const Adr: string): boolean; begin Result:=(FIsList) or ((Adr=FOpened) or (Adr='') or ((Pos(Adr,FOpened)=1) and (FOpened[Length(Adr)+1]=','))); end; function TFilledContensInfo.CalcItemsCount: integer; var A: TAsciizCollector; S: string; i,D,C: integer; ExP: wordbool; function CalcAmount(const Adr: string):integer; var CC,DD,ii: integer; SS: string; ExPP: wordbool; begin ReadItem(Adr,DD,CC,ExPP); Result:=CC; SS:= Adr; if Length(SS)>0 then SS:=SS+','; for ii:=0 to CC-1 do Result:=Result+CalcAmount(SS+IntToStr(ii)); end; begin if FIsList then begin Result:=CalcAmount(''); if FShowRoot then Inc(Result); Exit; end; A:=StrDistribution(PChar(FOpened),','); S:=''; Result:=0; i:=-1; if FShowRoot then Inc(Result); repeat if i>=0 then begin if Length(S)>0 then S:=S+','; S:=S+A.StrAt[i]; end; ReadItem(S,D,C,ExP); inc(Result,C); inc(i); until i>=A.Count; A.Free; end; procedure TFilledContensInfo.CloseItem(N: integer); var D: integer; begin D:=FItems[N].Deepness; FOpened:=CutAddress(FItems[N].Address,FOffset); Refill; if ((FShowRoot) and (D>0)) or (D>1) then inc(FOffset); end; procedure TFilledContensInfo.OpenItem(N: integer); begin FOpened:=FItems[N].Address; FOffset:=0; Refill; end; procedure TFilledContensInfo.PrepareToRefresh; begin FOpened:=''; end; procedure TFilledContensInfo.Set_CurrentIndex(AIndex: integer); var A,AA: string; O: integer; begin if FIsList then begin FBase:=0; FOffset:=AIndex; Exit; end; //if FShowRoot then FBase:=0; AA:=FItems[AIndex].Address; if FItems[AIndex].SubCount=0 then begin A:=CutAddress(AA,O); if ((FShowRoot) and (FItems[AIndex].Deepness>0)) or (FItems[AIndex].Deepness>1) then inc(O); end else begin O:=0; A:=AA; end; if A<>FOpened then begin FOpened:=A; Refill; end; FOffset:=O; end; function TFilledContensInfo.Get_CurrentIndex: integer; begin Result:=FBase+FOffset; end; function TFilledContensInfo.Get_CurrentAddress: string; begin Result:=FItems[Get_CurrentIndex].Address; end; procedure TFilledContensInfo.Set_CurrentAddress(const Adr: string); var A,AA: string; O,D,C,i,N: integer; ExP: wordbool; begin if FIsList then begin N:=-1; i:=0; C:=Length(FItems); while (i<C) and (N=-1) do begin if Adr=FItems[i].Address then N:=i; inc(i); end; if N>=0 then CurrentIndex:=N; Exit; end; AA:=Adr; ReadItem(AA,D,C,ExP); if C=0 then begin A:=CutAddress(AA,O); if ((FShowRoot) and (D>0)) or (D>1) then inc(O); end else begin O:=0; A:=AA; end; if A<>FOpened then begin FOpened:=A; Refill; end; FOffset:=O; end; { TFixedBase } procedure TFixedBase.AddRec(var ARec); var P: integer; A: pointer; begin A:=ExtractAttr(@ARec); InsertAttr(A,FCount); DisposeAttr(A); FStream.Position:=FCount*FRecSize; FStream.Write(ARec,FRecSize); inc(FCount); end; constructor TFixedBase.Create(const AName: string; AMode: word; ARecSize: integer); var F: TStream; begin inherited Create; FMode:=AMode; FStream:=TFileStream.Create(AName,AMode); FRecSize:=ARecSize; FCount:=FStream.Size div (FRecSize+4); if not(FMode=fmCreate) then begin FStream.Position:=FCount*FRecSize; FSort.Count:=FCount; FStream.Read(FSort.FStorage^,FCount*4); {F:=FStream; FStream:=TMemoryStream.Create; FStream.Position:=0; TMemoryStream(FStream).LoadFromStream(F); //FStream.Size:=FCount*FRecSize; //F.Position:=0; //FStream.CopyFrom(F,FCount*FRecSize); F.Free;} end; end; destructor TFixedBase.Destroy; begin if FMode=fmCreate then begin FStream.Position:=FCount*FRecSize; FStream.Write(FSort.FStorage^,FCount*4); end; FStream.Free; inherited Destroy; end; function TFixedBase.GetAttr(N: integer): pointer; var Buf: pointer; begin GetMem(Buf,FRecSize); ReadRec(N,Buf^); Result:=ExtractAttr(Buf); FreeMem(Buf,FRecSize); end; function TFixedBase.GetCount: integer; begin Result:=FCount; end; procedure TFixedBase.ReadRec(AIndex: integer; var ARec); begin FStream.Position:=AIndex*FRecSize; FStream.Read(ARec,FRecSize); end; { TStringVarList } procedure TStringVarList.AddItem(const AKey, AValue: string); var N: integer; begin N:=FKeys.Add(StrNew(PChar(AKey))); FValues.Insert(N,StrNew(PChar(AValue))); end; constructor TStringVarList.Create(ADelta: integer); begin FKeys:=TAsciizSortedCollector.Create(ADelta); FValues:=TAsciizCollector.Create(ADelta); end; destructor TStringVarList.Destroy; begin FKeys.Free; FValues.Free; inherited; end; function TStringVarList.Get_Count: integer; begin Result:=FKeys.Count; end; function TStringVarList.Get_KeyByIndex(AIndex: integer): string; begin Result:=FKeys.StrAt[AIndex]; end; function TStringVarList.Get_Value(const AKey: string): string; var N: integer; begin N:=FKeys.Get_KeyIndex(PChar(AKey)); if N>=0 then Result:=FValues.StrAt[N] else Result:=''; end; function TStringVarList.Get_IntValue(const AKey: string): integer; var N: integer; begin N:=FKeys.Get_KeyIndex(PChar(AKey)); //ShowMessage(FKeys.StrAt[N]+' '+IntToStr(N)+'COUNT'+IntToStr(FKeys.Count)); if N>=0 then Result:=StringToInt(FValues.StrAt[N]) else Result:=-1; end; function TStringVarList.Get_ValueByIndex(AIndex: integer): string; begin Result:=FValues.StrAt[AIndex]; end; procedure TStringVarList.Set_ValueByIndex(AIndex: integer; const V: string); begin FValues.StrAt[AIndex]:=V; end; function TStringVarList.DeleteItem(const AKey: string): integer; var N: integer; begin N:=FKeys.Get_KeyIndex(PChar(AKey)); Result:=N; if N>=0 then begin FKeys.Delete(N); FValues.Delete(N); end; end; function TStringVarList.Get_KeyIndex(const AKey: string): integer; begin Result:=FKeys.Get_KeyIndex(PChar(AKey)); end; procedure TStringVarList.ReindexIntValues(AFrom, ADelta: integer); var i,v: integer; begin for i:=0 to Count-1 do begin v:=StringToInt(FValues.StrAt[i]); if v>=AFrom then FValues.StrAt[i]:=IntToStr(v+ADelta); end; end; { TFixList } constructor TFixList.Create(ADelta: integer); begin inherited Create(ADelta); FCurrent:=0; FStatus:=0; end; function TFixList.GetCurrentString: string; begin if (FCurrent<0) or (FCurrent>=FCount) then Result:='' else Result:=String(At(FCurrent)); end; function TFixList.GetSelfPackSize: integer; begin Result:=SizeOf(FDelta)+SizeOf(FCurrent)+SizeOf(FStatus); end; function TFixList.GetText(Separator: char): string; begin Result:=ListSetPrefix+'('+TotString(Separator)+')'; if Current>0 then Result:=Result+'['+IntToStr(Current+1)+']'; end; function TFixList.Get_SelfCopy: pointer; var C: TFixList; i: integer; begin C:=TFixList.Create(FDelta); C.Count:=FCount; for i:=0 to FCount-1 do C.Items[i]:=StrNew(At(i)); C.FCurrent:=FCurrent; C.FStatus:=FStatus; Result:=C; end; procedure TFixList.PackSelf(var Buf); var D: pointer; begin D:=@Buf; D:=MoveDataD(FDelta,D^,SizeOf(FDelta)); D:=MoveDataD(FCurrent,D^,SizeOf(FCurrent)); D:=MoveDataD(FStatus,D^,SizeOf(FStatus)); end; procedure TFixList.RestoreSelf(var Buf); var S: pointer; begin S:=@Buf; S:=MoveDataS(S^,FDelta,SizeOf(FDelta)); FCapacity:=FCount mod FDelta; S:=MoveDataS(S^,FCurrent,SizeOf(FCurrent)); S:=MoveDataS(S^,FStatus,SizeOf(FStatus)); end; procedure TFixList.SetCurrent(AIndex: integer); begin if (AIndex>=0) and (AIndex<FCount) then FCurrent:=AIndex; end; procedure TFixList.SetUpFrom(const Str: string; Separator: char); begin SetUpFromStr(PChar(Str),Separator); end; procedure TFixList.SetUpFromStr(Str: Asciiz; Separator: char); var A: TAsciizCollector; i: integer; S: Asciiz; begin A:=StrDistribution(Str,Separator); Count:=A.Count; for i:=0 to FCount-1 do begin S:=SelectItem(i,A.SelectItem(i,NIL)); StrDispose(S); end; A.Free; if FCurrent>=FCount then FCurrent:=0; end; { TAsciizSortedCollector } function TAsciizSortedCollector.Add(AItem: pointer): integer; var N: integer; begin N:=Get_InsIndex(AItem); Insert(N,AItem); Result:=N; end; function TAsciizSortedCollector.Get_InsIndex(AKey: Asciiz): integer; var LP,RP,CP,C: integer; LA,RA,CA: Asciiz; begin C:=FCount; Result:=C; if C=0 then Exit; LP:=0; RP:=C-1; LA:=FItems[LP]; RA:=FItems[RP]; repeat CP:=(LP+RP) div 2; CA:=FItems[CP]; if AnsiStrComp(AKey,CA)<=0 then begin RP:=CP; RA:=CA; end else begin LP:=CP; LA:=CA; end; until RP-LP<=1; if AnsiStrComp(AKey,RA)>0 then Result:=RP+1 else if AnsiStrComp(AKey,LA)<=0 then Result:=LP else Result:=RP; end; function TAsciizSortedCollector.Get_KeyIndex(AKey: Asciiz): integer; var LP,RP,CP,C: integer; LA,RA,CA: Asciiz; begin C:=FCount; Result:=-1; if C=0 then Exit; LP:=0; RP:=C-1; LA:=FItems[LP]; RA:=FItems[RP]; repeat CP:=(LP+RP) div 2; CA:=FItems[CP]; if AnsiStrComp(AKey,CA)<=0 then begin RP:=CP; RA:=CA; end else begin LP:=CP; LA:=CA; end; until RP-LP<=1; if AnsiStrComp(AKey,RA)=0 then Result:=RP else if AnsiStrComp(AKey,LA)=0 then Result:=LP else Result:=-1; end; { TDLLModule } constructor TDLLModule.Create(const AModuleFileName: string); begin FModuleFileName:=AModuleFileName; FModule:=LoadLibrary(PChar(FModuleFileName)); end; destructor TDLLModule.Destroy; begin if GetAvailable then FreeLibrary(FModule); inherited; end; function TDLLModule.GetAvailable: boolean; begin Result:=not(FModule=0); end; function TDLLModule.Get_ModuleName: string; begin Result:=ExtractFileName(FileName); end; function TDLLModule.ProcAddress(const AProcName: string): pointer; begin Result:=GetProcAddress(FModule,PChar(AProcName)); end; end.