home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / OBJSTR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  10.5 KB  |  449 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit ObjStr;
  13.  
  14. interface
  15.  
  16. {$I RX.INC}
  17.  
  18. uses SysUtils, Classes, RTLConsts;
  19.  
  20. type
  21.  
  22. { TObjectStrings }
  23.  
  24.   TDestroyEvent = procedure(Sender, AObject: TObject) of object;
  25.   TObjectSortCompare = function (const S1, S2: string;
  26.     Item1, Item2: TObject): Integer of object;
  27.  
  28.   TObjectStrings = class(TStringList)
  29.   private
  30.     FOnDestroyObject: TDestroyEvent;
  31.   protected
  32.     procedure DestroyObject(AObject: TObject); virtual;
  33.     procedure PutObject(Index: Integer; AObject: TObject); override;
  34.   public
  35.     procedure Clear; override;
  36.     procedure Delete(Index: Integer); override;
  37.     procedure Move(CurIndex, NewIndex: Integer); override;
  38.     procedure Remove(Index: Integer);
  39.     procedure ParseStrings(const Values: string);
  40.     procedure SortList(Compare: TObjectSortCompare);
  41.     property OnDestroyObject: TDestroyEvent read FOnDestroyObject
  42.       write FOnDestroyObject;
  43.   end;
  44.  
  45. { THugeList class }
  46.  
  47. const
  48. {$IFDEF WIN32}
  49.   MaxHugeListSize = MaxListSize;
  50. {$ELSE}
  51.   MaxHugeListSize = (MaxLongint div SizeOf(Pointer)) - 4;
  52. {$ENDIF}
  53.  
  54. type
  55. {$IFDEF WIN32}
  56.   THugeList = class(TList);
  57. {$ELSE}
  58.   THugeList = class(TObject)
  59.   private
  60.     FList: TMemoryStream;
  61.     FCount: Longint;
  62.     FCapacity: Longint;
  63.   protected
  64.     function Get(Index: Longint): Pointer;
  65.     procedure Grow; virtual;
  66.     procedure Put(Index: Longint; Item: Pointer);
  67.     procedure SetCapacity(NewCapacity: Longint);
  68.     procedure SetCount(NewCount: Longint);
  69.   public
  70.     destructor Destroy; override;
  71.     function Add(Item: Pointer): Longint;
  72.     procedure Clear;
  73.     procedure Delete(Index: Longint);
  74.     procedure Exchange(Index1, Index2: Longint);
  75.     function Expand: THugeList;
  76.     function First: Pointer;
  77.     function IndexOf(Item: Pointer): Longint;
  78.     procedure Insert(Index: Longint; Item: Pointer);
  79.     function Last: Pointer;
  80.     procedure Move(CurIndex, NewIndex: Longint);
  81.     function Remove(Item: Pointer): Longint;
  82.     procedure Pack;
  83.     property Capacity: Longint read FCapacity write SetCapacity;
  84.     property Count: Longint read FCount write SetCount;
  85.     property Items[Index: Longint]: Pointer read Get write Put; default;
  86.   end;
  87. {$ENDIF WIN32}
  88.  
  89. {$IFDEF WIN32}
  90.  
  91. { TSortCollection }
  92.  
  93. type
  94.   TItemSortCompare = function (Item1, Item2: TCollectionItem): Integer of object;
  95.  
  96.   TSortCollection = class(TCollection)
  97.   protected
  98.     procedure QuickSort(L, R: Integer; Compare: TItemSortCompare); virtual;
  99.   public
  100.     procedure Sort(Compare: TItemSortCompare);
  101.   end;
  102.  
  103. {$ENDIF WIN32}
  104.  
  105. implementation
  106.  
  107. uses {$IFNDEF WIN32} VCLUtils, {$ENDIF} Consts, rxStrUtils;
  108.  
  109. { TObjectStrings }
  110.  
  111. procedure QuickSort(SortList: TStrings; L, R: Integer;
  112.   SCompare: TObjectSortCompare);
  113. var
  114.   I, J: Integer;
  115.   P: TObject;
  116.   S: string;
  117. begin
  118.   repeat
  119.     I := L;
  120.     J := R;
  121.     P := SortList.Objects[(L + R) shr 1];
  122.     S := SortList[(L + R) shr 1];
  123.     repeat
  124.       while SCompare(SortList[I], S, SortList.Objects[I], P) < 0 do Inc(I);
  125.       while SCompare(SortList[J], S, SortList.Objects[J], P) > 0 do Dec(J);
  126.       if I <= J then begin
  127.         SortList.Exchange(I, J);
  128.         Inc(I);
  129.         Dec(J);
  130.       end;
  131.     until I > J;
  132.     if L < J then QuickSort(SortList, L, J, SCompare);
  133.     L := I;
  134.   until I >= R;
  135. end;
  136.  
  137. procedure TObjectStrings.DestroyObject(AObject: TObject);
  138. begin
  139.   if Assigned(FOnDestroyObject) then FOnDestroyObject(Self, AObject)
  140.   else if AObject <> nil then AObject.Free;
  141. end;
  142.  
  143. procedure TObjectStrings.Clear;
  144. var
  145.   I: Integer;
  146. begin
  147.   if Count > 0 then begin
  148.     Changing;
  149.     for I := 0 to Count - 1 do Objects[I] := nil;
  150.     BeginUpdate;
  151.     try
  152.       inherited Clear;
  153.     finally
  154.       EndUpdate;
  155.     end;
  156.     Changed;
  157.   end;
  158. end;
  159.  
  160. procedure TObjectStrings.Delete(Index: Integer);
  161. begin
  162.   Objects[Index] := nil;
  163.   inherited Delete(Index);
  164. end;
  165.  
  166. procedure TObjectStrings.Remove(Index: Integer);
  167. begin
  168.   inherited Delete(Index);
  169. end;
  170.  
  171. procedure TObjectStrings.Move(CurIndex, NewIndex: Integer);
  172. var
  173.   TempObject: TObject;
  174.   TempString: string;
  175. begin
  176.   if CurIndex <> NewIndex then
  177.   begin
  178.     TempString := Get(CurIndex);
  179.     TempObject := GetObject(CurIndex);
  180.     inherited Delete(CurIndex);
  181.     try
  182.       InsertObject(NewIndex, TempString, TempObject);
  183.     except
  184.       DestroyObject(TempObject);
  185.       raise;
  186.     end;
  187.   end;
  188. end;
  189.  
  190. procedure TObjectStrings.PutObject(Index: Integer; AObject: TObject);
  191. begin
  192.   Changing;
  193.   BeginUpdate;
  194.   try
  195.     if (Index < Self.Count) and (Index >= 0) then
  196.       DestroyObject(Objects[Index]);
  197.     inherited PutObject(Index, AObject);
  198.   finally
  199.     EndUpdate;
  200.   end;
  201.   Changed;
  202. end;
  203.  
  204. procedure TObjectStrings.ParseStrings(const Values: string);
  205. var
  206.   Pos: Integer;
  207. begin
  208.   Pos := 1;
  209.   BeginUpdate;
  210.   try
  211.     while Pos <= Length(Values) do Add(ExtractSubstr(Values, Pos, [';']));
  212.   finally
  213.     EndUpdate;
  214.   end;
  215. end;
  216.  
  217. procedure TObjectStrings.SortList(Compare: TObjectSortCompare);
  218. begin
  219.   if Sorted then
  220. {$IFDEF RX_D3}
  221.     Error(SSortedListError, 0);
  222. {$ELSE}
  223.     raise EListError.Create(LoadStr(SSortedListError));
  224. {$ENDIF}
  225.   if Count > 0 then begin
  226.     BeginUpdate;
  227.     try
  228.       QuickSort(Self, 0, Count - 1, Compare);
  229.     finally
  230.       EndUpdate;
  231.     end;
  232.   end;
  233. end;
  234.  
  235. {$IFNDEF WIN32}
  236.  
  237. { THugeList }
  238.  
  239. function ReturnAddr: Pointer; assembler;
  240. asm
  241.         MOV     AX,[BP].Word[2]
  242.         MOV     DX,[BP].Word[4]
  243. end;
  244.  
  245. procedure ListError(Index: Longint);
  246. begin
  247.   raise EListError.Create(LoadStr(SListIndexError) +
  248.     Format(' (%d)', [Index])) at ReturnAddr;
  249. end;
  250.  
  251. destructor THugeList.Destroy;
  252. begin
  253.   Clear;
  254. end;
  255.  
  256. function THugeList.Add(Item: Pointer): Longint;
  257. begin
  258.   Result := FCount;
  259.   if Result = FCapacity then Grow;
  260.   FList.Position := Result * SizeOf(Pointer);
  261.   FList.WriteBuffer(Item, SizeOf(Pointer));
  262.   Inc(FCount);
  263. end;
  264.  
  265. procedure THugeList.Clear;
  266. begin
  267.   SetCount(0);
  268.   SetCapacity(0);
  269. end;
  270.  
  271. procedure THugeList.Delete(Index: Longint);
  272. begin
  273.   if (Index < 0) or (Index >= FCount) then ListError(Index);
  274.   Dec(FCount);
  275.   if Index < FCount then
  276.     HugeMove(FList.Memory, Index, Index + 1, FCount - Index);
  277. end;
  278.  
  279. function THugeList.Get(Index: Longint): Pointer;
  280. begin
  281.   if (Index < 0) or (Index >= FCount) then ListError(Index);
  282.   FList.Position := Index * SizeOf(Pointer);
  283.   FList.ReadBuffer(Result, SizeOf(Pointer));
  284. end;
  285.  
  286. procedure THugeList.Put(Index: Longint; Item: Pointer);
  287. begin
  288.   if (Index < 0) or (Index >= FCount) then ListError(Index);
  289.   FList.Position := Index * SizeOf(Pointer);
  290.   FList.WriteBuffer(Item, SizeOf(Pointer));
  291. end;
  292.  
  293. procedure THugeList.Exchange(Index1, Index2: Longint);
  294. var
  295.   Item: Pointer;
  296. begin
  297.   Item := Get(Index1);
  298.   Put(Index1, Get(Index2));
  299.   Put(Index2, Item);
  300. end;
  301.  
  302. function THugeList.Expand: THugeList;
  303. begin
  304.   if FCount = FCapacity then Grow;
  305.   Result := Self;
  306. end;
  307.  
  308. function THugeList.First: Pointer;
  309. begin
  310.   Result := Get(0);
  311. end;
  312.  
  313. procedure THugeList.Grow;
  314. var
  315.   Delta: Longint;
  316. begin
  317.   if FCapacity > 8 then Delta := 16
  318.   else if FCapacity > 4 then Delta := 8
  319.   else Delta := 4;
  320.   SetCapacity(FCapacity + Delta);
  321. end;
  322.  
  323. function THugeList.IndexOf(Item: Pointer): Longint;
  324. begin
  325.   Result := 0;
  326.   while (Result < FCount) and (Get(Result) <> Item) do
  327.     Inc(Result);
  328.   if Result = FCount then Result := -1;
  329. end;
  330.  
  331. procedure THugeList.Insert(Index: Longint; Item: Pointer);
  332. begin
  333.   if (Index < 0) or (Index > FCount) then ListError(Index);
  334.   if FCount = FCapacity then Grow;
  335.   if Index < FCount then
  336.     HugeMove(FList.Memory, Index + 1, Index, FCount - Index);
  337.   FList.Position := Index * SizeOf(Pointer);
  338.   FList.WriteBuffer(Item, SizeOf(Pointer));
  339.   Inc(FCount);
  340. end;
  341.  
  342. function THugeList.Last: Pointer;
  343. begin
  344.   Result := Get(FCount - 1);
  345. end;
  346.  
  347. procedure THugeList.Move(CurIndex, NewIndex: Longint);
  348. var
  349.   Item: Pointer;
  350. begin
  351.   if CurIndex <> NewIndex then begin
  352.     if (NewIndex < 0) or (NewIndex >= FCount) then ListError(NewIndex);
  353.     Item := Get(CurIndex);
  354.     Delete(CurIndex);
  355.     Insert(NewIndex, Item);
  356.   end;
  357. end;
  358.  
  359. function THugeList.Remove(Item: Pointer): Longint;
  360. begin
  361.   Result := IndexOf(Item);
  362.   if Result <> -1 then Delete(Result);
  363. end;
  364.  
  365. procedure THugeList.Pack;
  366. var
  367.   I: Longint;
  368. begin
  369.   for I := FCount - 1 downto 0 do
  370.     if Items[I] = nil then Delete(I);
  371. end;
  372.  
  373. procedure THugeList.SetCapacity(NewCapacity: Longint);
  374. var
  375.   NewList: TMemoryStream;
  376. begin
  377.   if (NewCapacity < FCount) or (NewCapacity > MaxHugeListSize) then
  378.     ListError(NewCapacity);
  379.   if NewCapacity <> FCapacity then begin
  380.     if NewCapacity = 0 then NewList := nil
  381.     else begin
  382.       NewList := TMemoryStream.Create;
  383.       NewList.SetSize(NewCapacity * SizeOf(Pointer));
  384.       if FCount <> 0 then begin
  385.         FList.Position := 0;
  386.         FList.ReadBuffer(NewList.Memory^, FCount * SizeOf(Pointer));
  387.       end;
  388.     end;
  389.     if FCapacity <> 0 then FList.Free;
  390.     FList := NewList;
  391.     FCapacity := NewCapacity;
  392.   end;
  393. end;
  394.  
  395. procedure THugeList.SetCount(NewCount: Longint);
  396. begin
  397.   if (NewCount < 0) or (NewCount > MaxHugeListSize) then
  398.     ListError(NewCount);
  399.   if NewCount > FCapacity then SetCapacity(NewCount);
  400.   FCount := NewCount;
  401. end;
  402.  
  403. {$ENDIF}
  404.  
  405. {$IFDEF WIN32}
  406.  
  407. { TSortCollection }
  408.  
  409. procedure TSortCollection.QuickSort(L, R: Integer; Compare: TItemSortCompare);
  410. var
  411.   I, J: Integer;
  412.   P, P1, P2: TCollectionItem;
  413. begin
  414.   repeat
  415.     I := L;
  416.     J := R;
  417.     P := Items[(L + R) shr 1];
  418.     repeat
  419.       while Compare(Items[I], P) < 0 do Inc(I);
  420.       while Compare(Items[J], P) > 0 do Dec(J);
  421.       if I <= J then begin
  422.         P1 := Items[I];
  423.         P2 := Items[J];
  424.         P1.Index := J;
  425.         P2.Index := I;
  426.         Inc(I);
  427.         Dec(J);
  428.       end;
  429.     until I > J;
  430.     if L < J then QuickSort(L, J, Compare);
  431.     L := I;
  432.   until I >= R;
  433. end;
  434.  
  435. procedure TSortCollection.Sort(Compare: TItemSortCompare);
  436. begin
  437.   if Count > 0 then begin
  438.     BeginUpdate;
  439.     try
  440.       QuickSort(0, Count - 1, Compare);
  441.     finally
  442.       EndUpdate;
  443.     end;
  444.   end;
  445. end;
  446.  
  447. {$ENDIF WIN32}
  448.  
  449. end.