src/DynamicArrays/DynamicArrays.pas - main - lasersquad/XFinder

src/DynamicArrays/DynamicArrays.pas
3 806 строк98 KB
lasersquad0
Fixed compiler warnings
24 июн 2026, 17:58
24 июн 2026, 17:584f9efb1
unit DynamicArrays;

{
 Dynamic arrays and hashes for storing and manupulating with a various types of data.

 Arrays:
  THArray - Common array. Parent of all dynamic arrays.
  THArrayObjects,  THArrayByte,     THArraySmallInt, THArrayWord,      THArrayInt64,
  THArrayLongWord, THArrayInteger,  THArrayPointer,  THArrayBoolean,   THArrayDouble,
  THArrayCurrency, THArrayExtended, THArrayString,   THArrayStringFix, THArrayAnsiStringFix,
  THArrayWideStrings

 Hashes:
  THash - Common hash. Parent of all hashes.
  THashExists,   THashBoolean, THashInteger, THashPointer,
  THashCurrency, THashDouble,  THashString.

 Double Hashes:
  Like a table. Each value has two keys. Keys are always Integer values.
  See DynamicArrays.html for detail.
  THash2 - Common double hash. Parent of all double hashes.
  THash2Exists, THash2Currency, THash2Integer, THash2String.
}

interface

{$IF CompilerVersion >= 22} // unit names like Data.Bind.Consts, introduced in Delphi XE
{$DEFINE UNIT_PREFIXES}
{$IFEND}

{$IF CompilerVersion >=20}
{$DEFINE TBYTES}
{$IFEND}

uses Classes, SysUtils;

 resourcestring
   SItemNotFound = 'Element with index %d not found !';
   SKeyNotFound  = 'Element with index%d not found in Read-only hash !';
   SNoCompareProc = 'Cannot sort without CompareProc!';
   SNoFindProc = 'Cannot do QuickFind without FindProc!';
   SWrongCallSetItemSize = 'Impossible to set item size for array contining defined types.';
   SUseCreateSizeConsructor = 'Constructor %0:s.Create() is prohibited, use %0:s.CreateSize(SizeOfItem: Cardinal) instead.';

 type

  // Delphi7 generates Internal compiler error if pointer arithmetic done via NativeUInt
  // Hovewer it compiles well when we use NativeInt.
  // This define makes use NativeInt for old Delphi versions and NativeUInt for newer
  ConvertInt = {$IFDEF UNIT_PREFIXES}type NativeUInt;{$ELSE} type NativeInt;{$ENDIF}

  THarray = class;

  (**************************************************************)
  (*          Compare callback functions                        *)
  (*  Return values must be:                                    *)
  (*    0 - elements are equal                                  *)
  (*    1 - arr[i] > arr[j]                                     *)
  (*   -1 - arr[i] < arr[j] }                                   *)
  (**************************************************************)

  // this function is useful when you need access other elements than arr[i], arr[j] for comparing
  // or you have quicker method of access ith and jth elements in the array
  TCompareProc = function(arr : THArray; i, j : Cardinal) : Integer of object;

  (**************************************************************)
  (*          Find callback function                            *)
  (* FindData - pointer to the seaching data.                   *)
  (* Seaching data can be int, float, string and any other type.*)
  (* Return values must be.                                     *)
  (*   0 - arr[i] = FindData as <needed type>                   *)
  (*   1 - arr[i] > FindData as <needed type>                   *)
  (*  -1 - arr[i] < FindData as <needed type>                   *)
  (* See example application how to use TFindProc.              *)
  (**************************************************************)

  TFindProc = function(arr : THArray; i : Cardinal; FindData: Pointer): Integer of object;
  TSwapProc = procedure(arr : THArray; i, j : Cardinal) of object;


  (***********************   THArray   **************************)
  (*  Common class of all dynamic arrays.                       *)
  (*  Does not depend on a type of stored data.                 *)
  (*  Stores data as pieces of memory with ItemSize size each   *)
  (**************************************************************)

  THArray = class
  private
   FCount:    Cardinal;         // number of elements
   FCapacity: Cardinal;         // number of elements on which memory is allocated
   FHelperBuf: Pointer;
   FHelperBufSize: Cardinal;
  protected
   FValues: Pointer;
   FItemSize: Cardinal;         // size of one element in bytes
   procedure Error(Value, MaxValue: Cardinal);
   function  CalcAddr(Index: Cardinal): Pointer; virtual;
   procedure SetItemSize(Size: Cardinal); virtual;
   //procedure InternalInsertSort(CompareProc: TCompareProc; L, R: Cardinal);
   procedure InternalQuickSort(CompareProc: TCompareProc; SwapProc: TSwapProc; L,R: Cardinal);
   function  InternalQuickFind(FindProc: TFindProc; FindData: Pointer; L, R: Cardinal): Integer;

  public
   type InnerType = Byte; //TODO: it is difficult to define type for THArray, byte for now.
   constructor Create; virtual;
   destructor Destroy; override;
   procedure Clear; virtual;
   procedure ClearMem; virtual;
   function  Add(pValue: Pointer): Cardinal; virtual;
   procedure AddMany(pValue: Pointer; Cnt: Cardinal);
   function  AddFillValues(Cnt: Cardinal; Value: Byte = 0): Pointer;
   procedure Delete(Index: Cardinal); virtual;
   procedure Hold;
   function  GetAddr(Index: Cardinal): Pointer;
   procedure Get(Index: Cardinal; pValue: Pointer); virtual;
   function  GetMany(StartIndex: Cardinal; pValue: Pointer; Cnt: Cardinal): Cardinal;
   procedure Grow;
   procedure GrowTo(Cnt: Cardinal);
   function  Insert(Index: Cardinal; pValue: Pointer): Cardinal; virtual;
   procedure InsertMany(StartIndex: Cardinal; pValue: Pointer; Cnt: Cardinal);
   function  IndexOf(Value: Pointer): Integer;
   function  IndexOfFrom(Value: Pointer; Start: Cardinal): Integer;
   procedure MoveData(FromPos, Cnt: Cardinal; Offset: Integer); virtual;
   procedure SetCapacity(Value: Cardinal);
   procedure Update(Index: Cardinal; pValue: Pointer); virtual; // fills Index value with zero if pValue=nil
   // Expand parameter: whether to automatically expand array if StartIndex+Cnt>Count or (Expand=False) generate and Index out of bounds exception
   procedure UpdateMany(StartIndex: Cardinal; pValue: Pointer; Cnt: Cardinal; Expand: Boolean = False);
   procedure Zero;
   procedure LoadFromStream(s: TStream); virtual; // read values will be added to existing ones
   procedure SaveToStream(s: TStream); virtual;
{$IFDEF TBYTES}
   function  ToBytes: TBytes;
{$ENDIF}
   procedure Swap(Index1, Index2: Cardinal); virtual;
   procedure BubbleSort(CompareProc: TCompareProc);
   procedure SelectionSort(CompareProc : TCompareProc);
   //procedure InsertSort(CompareProc : TCompareProc);
   procedure ShakerSort(CompareProc : TCompareProc);
   procedure QuickSort(CompareProc: TCompareProc);
   function  QuickFind(FindProc: TFindProc; FindData: Pointer): Integer; // Finds value in SORTED array!!

   property Capacity: Cardinal read FCapacity;
   property Count: Cardinal read FCount;
   property ItemSize: Cardinal read FItemSize write SetItemSize;
   property Memory: Pointer read FValues;
  end;

  THArrayObjects = class(THArray)
  protected
   function GetValue(Index: Cardinal): TObject;
   procedure SetValue(Index: Cardinal; const Value: TObject);
  public
   type InnerType = TObject;
   constructor Create; override;
   procedure ClearMem; override;              // (!) destroyes all saved objects! and deletes all references on them.
   procedure SafeClearMem;                    // deletes only references on all stored objects. Objects are leave safe
   procedure Delete(Index: Cardinal); override; // (!) destroyes object with index Index and deletes reference on it.
   procedure SafeDelete(Index: Cardinal);       // deletes only reference on object with index Index. Object is left as is.
   function AddValue(Value: TObject): Cardinal;
   function IndexOf(Value: TObject): Integer;
   function IndexOfFrom(Value: TObject; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: TObject read GetValue write SetValue; default;
  end;

  THArrayShortInt = class(THArray)
  private
   procedure SetItemSize(Size: Cardinal); override;
  protected
   function GetValue(Index: Cardinal): ShortInt;
   procedure SetValue(Index: Cardinal; Value: ShortInt);
  public
   type InnerType = ShortInt;
   constructor Create; override;
   function AddValue(Value: ShortInt): Cardinal;
   function IndexOf(Value: ShortInt): Integer;
   function IndexOfFrom(Value: ShortInt; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: ShortInt read GetValue write SetValue; default;
  end;

  THArrayByte = class(THArray)
  protected
   function GetValue(Index: Cardinal): Byte;
   procedure SetValue(Index: Cardinal; Value: Byte);
  public
   type InnerType = Byte;
   constructor Create; override;
   function AddValue(Value: Byte): Cardinal;
   function IndexOf(Value: Byte): Integer;
   function IndexOfFrom(Value: Byte; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: Byte read GetValue write SetValue; default;
  end;

  THArraySmallInt = class(THArray)
  private
   procedure SetItemSize(Size: Cardinal); override;
  protected
   function GetValue(Index: Cardinal): SmallInt;
   procedure SetValue(Index: Cardinal; Value: SmallInt);
  public
   type InnerType = SmallInt;
   constructor Create; override;
   function AddValue(Value: SmallInt): Cardinal;
   function IndexOf(Value: SmallInt): Integer;
   function IndexOfFrom(Value: SmallInt; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: SmallInt read GetValue write SetValue; default;
  end;

  THArrayWord = class(THArray)
  protected
   function GetValue(Index: Cardinal): Word;
   procedure SetValue(Index: Cardinal; Value: Word);
  public
   type InnerType = Word;
   constructor Create; override;
   function AddValue(Value: word): Cardinal;
   function InsertValue(Index: Cardinal; Value: Word): Cardinal;
   function IndexOf(Value: word): Integer;
   function IndexOfFrom(Value: word; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: word read GetValue write SetValue; default;
  end;

  THArrayInt64 = class(THArray)
  protected
   function GetValue(Index: Cardinal): int64;
   procedure SetValue(Index: Cardinal; Value: int64);
  public
   type InnerType = Int64;
   constructor Create; override;
   function AddValue(Value: int64): Cardinal;
   function IndexOf(Value: int64): Integer;
   function IndexOfFrom(Value: int64; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: int64 read GetValue write SetValue; default;
  end;

  THArrayUInt64 = class(THArray)
  protected
   function GetValue(Index: Cardinal): UInt64;
   procedure SetValue(Index: Cardinal; Value: UInt64);
  public
   type InnerType = UInt64;
   constructor Create; override;
   function AddValue(Value: UInt64): Cardinal;
   function IndexOf(Value: UInt64): Integer;
   function IndexOfFrom(Value: UInt64; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: UInt64 read GetValue write SetValue; default;
  end;

  THArrayLongWord = class(THArray)
  protected
   function GetValue(Index: Cardinal): LongWord;
   procedure SetValue(Index: Cardinal; Value: LongWord);
  public
   type InnerType = LongWord;
   constructor Create; override;
   function AddValue(Value: LongWord): Cardinal;
   function IndexOf(Value: LongWord): Integer;
   function IndexOfFrom(Value: LongWord; Start: Cardinal): Integer;
   property Value[Index: Cardinal]:LongWord read GetValue write SetValue; default;
  end;

  //TODO: InnerType might be wrong for THArrayCardinal here
  THArrayCardinal = THArrayLongWord; // alias

  THArrayInteger = class(THArray)
  protected
   function GetValue(Index: Cardinal): Integer;
   procedure SetValue(Index: Cardinal; Value: Integer);
  public
   type InnerType = Integer;
   constructor Create; override;
   function IndexOf(Value: Integer): Integer;
   function IndexOfFrom(Value: Integer; Start: Cardinal): Integer;
   function AddValue(Value: Integer): Cardinal;
   function InsertValue(Index: Cardinal; Value: Integer): Cardinal;
   function Pop: Integer;
   procedure Push(Value: Integer);
   property Value[Index: Cardinal]: Integer read GetValue write SetValue; default;
   function GetAsString: string;
   procedure AddFromString(InputString, Delimiters: string);
   function CalcMax: Integer;
//   procedure QuickSort(l,r:Integer);overload;
  end;

  THArrayPointer = class(THArray)
  protected
   function GetValue(Index: Cardinal): Pointer;
   procedure SetValue(Index: Cardinal; Value: Pointer);
  public
   type InnerType = Pointer;
   constructor Create; override;
   function IndexOf(Value: Pointer): Integer;
   function IndexOfFrom(Value: Pointer; Start: Cardinal): Integer;
   function AddValue(Value: Pointer): Cardinal;
   property Value[Index: Cardinal]: Pointer read GetValue write SetValue; default;
  end;

  THArrayBoolean = class(THArray)
  protected
   function GetValue(Index: Cardinal): Boolean;
   procedure SetValue(Index: Cardinal; Value: Boolean);
  public
   type InnerType = Boolean;
   constructor Create; override;
   function AddValue(Value: Boolean): Cardinal;
   function InsertValue(Index: Cardinal; Value: Boolean): Cardinal;
   function IndexOf(Value: Boolean): Integer;
   function IndexOfFrom(Value: Boolean; Start: Cardinal): Integer;
   property Value[Index:Cardinal]: Boolean read GetValue write SetValue; default;
  end;

  THArrayDouble = class(THArray)
  protected
   function GetValue(Index: Cardinal): Double;
   procedure SetValue(Index: Cardinal; Value: Double);
  public
   type InnerType = Double;
   constructor Create; override;
   function AddValue(Value: Double): Cardinal;
   function IndexOf(Value: Double): Integer;
   function IndexOfFrom(Value: Double; Start: Cardinal): Integer;
   property Value[Index:Cardinal]: Double read GetValue write SetValue; default;
  end;

  THArrayCurrency = class(THArray)
  protected
   function GetValue(Index: Cardinal): Currency;
   procedure SetValue(Index: Cardinal; Value: Currency);
  public
   type InnerType = Currency;
   constructor Create; override;
   function AddValue(Value: Currency): Cardinal;
   function IndexOf(Value: Currency):Integer;
   function IndexOfFrom(Value: Currency; Start: Cardinal): Integer;
   property Value[Index:Cardinal]: Currency read GetValue write SetValue; default;
  end;

  THArrayExtended = class(THArray)
  protected
   function GetValue(Index: Cardinal): Extended;
   procedure SetValue(Index: Cardinal; Value: Extended);
  public
   type InnerType = Extended;
   constructor Create; override;
   function AddValue(Value: Extended): Cardinal;
   function IndexOf(Value: Extended): Integer;
   function IndexOfFrom(Value: Extended; Start: Cardinal): Integer;
   property Value[Index:Cardinal]: Extended read GetValue write SetValue; default;
  end;

  THArraySingle = class(THArray)
  protected
   function GetValue(Index: Cardinal): Single;
   procedure SetValue(Index: Cardinal; Value: Single);
  public
   type InnerType = Single;
   constructor Create; override;
   function AddValue(Value: Single): Cardinal;
   function IndexOf(Value: Single): Integer;
   function IndexOfFrom(Value: Single; Start: Cardinal): Integer;
   property Value[Index:Cardinal]: Single read GetValue write SetValue; default;
  end;

  TWideString = class
  private
   FStr: WideString;
  public
   constructor Create(Value: WideString);
  end;

  THArrayWideStrings = class(THArrayObjects)
  protected
   function GetValue(Index: Cardinal): WideString;
   procedure SetValue(Index: Cardinal; Value: WideString);
  public
   type InnerType = WideString;
   function AddValue(Value: WideString): Cardinal;
   function IndexOf(Value: WideString): Integer;
   function IndexOfFrom(Value: WideString; Start: Cardinal): Integer;
   property Value[Index:Cardinal]: WideString read GetValue write SetValue; default;
  end;

{  THArrayString_ = class(THArray)
  private
   str_ptr: THArrayPointer;
  protected
   function GetValue(Index: Cardinal): string;
   procedure SetValue(Index: Cardinal; Value: string);
   function CalcAddr(num: Cardinal): Pointer; override;
  public
   constructor Create; override;
   destructor Destroy; override;
   function AddValue(Value: string): Cardinal;
   function Add(pValue: Pointer): Cardinal; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(num: Cardinal); override;
   procedure Get(num:Cardinal; pValue: Pointer); override;
   function Insert(num: Cardinal; pValue: Pointer): Cardinal; override;
   function IndexOf(Value:string): Integer;
   function IndexOfFrom(Value: string; Start: Cardinal): Integer;
   procedure MoveData(FromPos, Cnt: Cardinal; Offset: Integer); override;
   procedure Swap(Index1, Index2: Cardinal); override;
   procedure Update(num: Cardinal; pValue: Pointer); override;
   property Value[Index: Cardinal]: string read GetValue write SetValue; default;
  end;
                 }
  THArrayString = class(THArrayPointer)
  private
   procedure ClearStrings;
   function DublicateStr(pValue: Pointer): PChar;
  protected
   function GetValue(Index: Cardinal): string;
   procedure SetValue(Index: Cardinal; Value: string);
  public
   type InnerType = string;
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   function Add(pValue: Pointer): Cardinal; override;
   function AddValue(Value: string): Cardinal;
   procedure Delete(num: Cardinal); override;
   //function Insert(num: Cardinal; pValue: Pointer): Cardinal; overload; override;
   function Insert(num: Cardinal; Value: string): Cardinal; reintroduce; overload;
   procedure Update(num: Cardinal; pValue: Pointer); override;
   function IndexOf(Value: string): Integer;
   function IndexOfFrom(Value: string; Start: Integer): Integer;
   procedure LoadFromStream(s: TStream); override; // readed values will be added to existing
   procedure SaveToStream(s: TStream); override;
   property Value[Index: Cardinal]: string read GetValue write SetValue; default;
  end;

  THArrayAnsiStringFix = class(THArray)
  protected
   FHelperBuf: PAnsiChar;
   FHelperBufSize: Cardinal;

   function GetValue(Index: Cardinal): AnsiString;
   procedure SetValue(Index: Cardinal; Value: AnsiString);
   procedure SetItemSize(Size: Cardinal); override;
  public
   type InnerType = AnsiString;
   constructor Create; override;
   constructor CreateSize(SizeOfItem: Cardinal);
   destructor Destroy; override;
   function AddValue(Value: AnsiString): Cardinal;
   function IndexOf(Value: AnsiString): Integer;
   function IndexOfFrom(Value: AnsiString; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: AnsiString read GetValue write SetValue; default;
  end;

  THArrayStringFix = class(THArray)
  protected
   //HelperBuf: PChar;

   function GetValue(Index: Cardinal): string;
   procedure SetValue(Index: Cardinal; Value: string);
   procedure SetItemSize(Size: Cardinal); override;
  public
   type InnerType = string;
   constructor Create; override;
   constructor CreateSize(SizeOfItem: Cardinal);
   function AddValue(Value: string): Cardinal;
   function IndexOf(Value: string): Integer;
   function IndexOfFrom(Value: string; Start: Cardinal): Integer;
   property Value[Index: Cardinal]: string read GetValue write SetValue; default;
  end;


(***********************************************************)
(*  Hashes                                                 *)
(*                                                         *)
(* Keys are always Integer type, Values may be any type    *)
(***********************************************************)

  THash = class
  private
   FReadOnly: Boolean;
   FAIndex: THArrayInteger;
   function GetKey(Index: Cardinal): Integer;
   function GetCount: Cardinal;
  public
   constructor Create; virtual;
   destructor Destroy; override;
   procedure Clear; virtual;
   procedure ClearMem; virtual;
   function IfExist(Key: Integer): Boolean;  // check if values with key Key is exists in hash
   procedure Delete(Key: Integer); virtual; abstract;// deletes value with key=Key
   property Count: Cardinal read GetCount;
   property Keys[Index: Cardinal]: Integer read GetKey;
   property AIndexes: THArrayInteger read FAIndex;
  end;

  THashExists = class (THash)
  private
   procedure SetValue(Key: Integer; Value: Boolean);
   function GetValue(Key: Integer): Boolean;
  public
   constructor Create; override;
   destructor Destroy; override;
   procedure Delete(Key: Integer); override;
   property Value[Key: Integer]: Boolean read GetValue write SetValue; default;
  end;

  THashBoolean = class (THash)
  private
   FAValues: THArrayBoolean;
   procedure SetValue(Key: Integer; Value: Boolean);
   function GetValue(Key: Integer): Boolean;
  public
   constructor Create; override;
   constructor CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayBoolean);
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(Key: Integer); override;
   property Value[Key: Integer]: Boolean read GetValue write SetValue; default;
  end;

  THashInteger = class (THash)
  private
   FAValues: THArrayInteger;
   procedure SetValue(Key: Integer; Value: Integer);
   function GetValue(Key: Integer): Integer;
  public
   constructor Create; override;
   constructor CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayInteger);
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(Key: Integer); override;
   property AValues: THArrayInteger read FAValues;
   property Value[Key: Integer]: Integer read GetValue write SetValue; default;
  end;

  THashPointer = class (THash)
  private
   FAValues: THArrayPointer;
   procedure SetValue(Key: Integer; Value: Pointer);
   function GetValue(Key: Integer): Pointer;
  public
   constructor Create; override;
   constructor CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayPointer);
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(Key: Integer); override;
   property AValues: THArrayPointer read FAValues;
   property Value[Index: Integer]: Pointer read GetValue write SetValue; default;
  end;

  THashCurrency = class (THash)
  private
   FAValues:THArrayCurrency;
   procedure SetValue(Key:Integer;Value:currency);
   function GetValue(Key:Integer):currency;
  public
   constructor Create; override;
   constructor CreateFromHArrays(IndexHArray:THArrayInteger;ValueHArray:THArrayCurrency);
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(Key:Integer); override;
   procedure Inc(Key:Integer;Value:currency); // increases stored value with key=Key on a Value. If value with key=Key does not exists then it will be created with value=Value.
   property Value[Index:Integer]:currency read GetValue write SetValue; default;
  end;

  THashDouble = class (THash)
  private
   FAValues:THArrayDouble;
   procedure SetValue(Key:Integer;Value:Double);
   function GetValue(Key:Integer):Double;
  public
   constructor Create; override;
   constructor CreateFromHArrays(IndexHArray:THArrayInteger;ValueHArray:THArrayDouble);
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(Key:Integer); override;
   procedure Inc(Key:Integer;Value:Double); // increases stored value with key=Key on a Value. If value with key=Key does not exists then it will be created with value=Value.
   property Value[Index:Integer]:Double read GetValue write SetValue; default;
  end;

  THashString = class (THash)
  private
   FAllowEmptyStr: Boolean;
   FAValues: TStrings;
   procedure SetValue(Key: Integer; Value: string);
   function GetValue(Key: Integer): string;
  public
   constructor Create; override;
   destructor Destroy; override;
   procedure Clear; override;
   procedure ClearMem; override;
   procedure Delete(Key: Integer); override;
   property AllowEmptyStr: Boolean read FAllowEmptyStr write FAllowEmptyStr;
   property Value[Index: Integer]: string read GetValue write SetValue; default;
  end;

  THash2 = class
  private
   MainListIndex: THArrayInteger;
   MainListValue: THArrayPointer;
//   function GetKey(Index:Integer):Integer;
   function GetChildHash(Key: Integer): THash;
  public
   constructor Create; virtual;
   destructor Destroy; override;
//   function Count:Integer;
   procedure Clear; virtual; abstract;  // Creares hash. Allocated memory do not frees.
   procedure ClearMem;                  // Cleares hash. Allocated memory frees too.
   procedure Delete(MainIndex, Index: Integer);
//   function ExistMainHash(MainIndex:Integer):boolean;
//   function ExistIndex(Index:Integer):boolean;
//   property Keys[Index:Integer]:Integer read GetKey;
   property MainIndexes: THArrayInteger read MainListIndex;
  end;

  THash2Exists = class (THash2)
  public
   procedure SetValue(MainIndex, Index: Integer; Value: Boolean); // creates new record with keys MainIndex, Index
   procedure Clear; override;
   function GetValue(MainIndex, Index: Integer): Boolean;        // Gets Value by keys MainIndex, Index
   function CreateMainHash(MainIndex: Integer): THashExists;
   function CreateHash(Index: Integer): THashExists;
//   procedure ExportChildHash(Hash:THashBoolean);
//   procedure DeleteMainIndex(MainIndex:Integer);
//   procedure DeleteIndex(Index:Integer);
  end;

  THash2Currency = class(THash2)
  public
   procedure SetValue(MainIndex, Index: Integer; Value: Currency); // creates new record with keys MainIndex, Index
   procedure Inc(MainIndex, Index: Integer; Value: Currency);      // increases exists/create new record with keys MainIndex, Index
   procedure Clear; override;
   function GetValue(MainIndex, Index: Integer): Currency;         // Gets Value by keys MainIndex, Index
   function CreateMainHash(MainIndex: Integer): THashCurrency;
   function CreateHash(Index: Integer): THashCurrency;
//   procedure ExportChildHash(Hash:THashCurrency);
  end;

  THash2Integer = class(THash2)
  public
   procedure SetValue(MainIndex, Index: Integer; Value: Integer); // creates new record with keys MainIndex, Index
   procedure Clear; override;
   function GetValue(MainIndex, Index: Integer): Integer;        // Gets Value by keys MainIndex, Index
   function CreateMainHash(MainIndex: Integer): THashInteger;
   function CreateHash(Index: Integer): THashInteger;
//   procedure ExportChildHash(Hash:THashInteger);
  end;

  THash2String = class(THash2)
  protected
   procedure SetValue(MainIndex, Index: Integer; Value: string); // creates new record with keys MainIndex, Index
   function GetValue(MainIndex, Index: Integer): string;        // Gets Value by keys MainIndex, Index
  public
   procedure Clear; override;
   function CreateMainHash(MainIndex: Integer): THashString;
   function CreateHash(Index: Integer): THashString;
//   procedure ExportChildHash(Hash:THashCurrency);
   property Value[MainIndex, Index: Integer]: string read GetValue write SetValue; default;
  end;

  
{$IF CompilerVersion <21}
EArgumentException = class(Exception);
ENotSupportedException = class(Exception);
PUInt64 = ^UInt64;
{$IFEND}


procedure memcpy(pi, po: Pointer; Count: Cardinal); stdcall;
procedure memclr(po: Pointer; Count: Cardinal); stdcall;
procedure memset(po: Pointer; Value: Byte; Count: Cardinal); stdcall;
function memfinddword(pi: Pointer; Value: Integer; Count: Cardinal): Integer; stdcall;
function memfindbyte(pi: Pointer; Value: Byte; Count: Cardinal): Integer; stdcall;
function memfindword(pi: Pointer; Value: Word; Count: Cardinal): Integer; stdcall;
function memfindint64(pi: Pointer; Value: int64; Count: Cardinal): Integer; stdcall;
function memfindgeneral(pi, pValue: Pointer; ValueSize: Cardinal; Count: Cardinal): Integer; stdcall;

function HGetToken(InputString: string; Delimiters: string; OnlyOneDelimiter: Boolean; Index: Integer): string;
function HGetTokenCount(InputString:string; Delimiters:string; OnlyOneDelimiter:boolean):Integer;

implementation

uses Math, StrUtils;

//const
// BLOCK=1024;

function HGetToken(InputString: string; Delimiters: string; OnlyOneDelimiter: Boolean; Index: Integer): string;
var
  i,p: Integer;
  len: Integer;
begin
  Result := '';
  p := 1;
  len := length(InputString);
  while (p <= len) and (Pos(InputString[p], Delimiters) <> 0) do Inc(p); // bypass leading delimiters
  for i := 1 to index do begin
    while (p <= len) and (Pos(InputString[p], Delimiters) = 0) do Inc(p); // iterating till next delimiter
      if OnlyOneDelimiter
        then Inc(p)
        else while (p <= len) and (Pos(InputString[p],Delimiters) <> 0) do Inc(p);
  end;

  while (p <= len) and (Pos(InputString[p], Delimiters) = 0) do begin
    Result := Result + InputString[p];
    Inc(p);
  end;
end;

function HGetTokenCount(InputString: string; Delimiters: string; OnlyOneDelimiter: Boolean): Integer;
var p: Integer;
begin
  Result := 0;
  if InputString = '' then exit;
  p := 1;
  while (p <= length(InputString)) and (Pos(InputString[p], Delimiters) <> 0) do Inc(p);
  while (p <= length(InputString)) do begin
    while (p <= length(InputString)) and (Pos(InputString[p], Delimiters) = 0) do Inc(p);
    if OnlyOneDelimiter
      then Inc(p)
      else while (p <= length(InputString)) and (Pos(InputString[p], Delimiters) <> 0) do Inc(p);
   Result := Result + 1;
  end;

  //Result := Result;
end;


{$IFDEF CPUX86}
 procedure memcpyfromend(pi, po: Pointer; Count: Cardinal);
 asm
  pushad
  pushfd
  mov ECX, Count
  mov EDI,po
  mov ESI,pi
  add ESI,ECX
  add EDI,ECX
  dec ESI
  dec EDI
  std
  repne MOVSB
  popfd
  popad
 end;

procedure memcpyfrombegin(pi, po: Pointer; Count: Cardinal);  // copying from begin
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  mov ESI,pi
  cld
  repne MOVSB
  popfd
  popad
end;

procedure memclr(po: Pointer; Count: Cardinal);
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  xor AL,AL
  cld
  repne STOSB
  popfd
  popad
 end;

procedure memset(po: Pointer; Value: Byte; Count: Cardinal);
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  mov AL,Value
  cld
  repne STOSB
  popfd
  popad
 end;

function memfinddword(pi: Pointer; Value: Integer; Count: Cardinal): Integer;
 asm
  pushad
  pushfd
  mov Result, 0
  mov ECX, Count
  cmp ECX, 0
  jz @ex
  mov EAX, Value
  mov EDI, pi
  cld
  repne SCASD
  jne @ex
  mov EAX, Count
  sub EAX, ECX
  mov Result, EAX
@ex:
  dec Result
  popfd
  popad
 end;

function memfindbyte(pi: Pointer; Value: Byte; Count: Cardinal): Integer;
 asm
  pushad
  pushfd
  mov @Result, 0
  mov ECX, Count
  cmp ECX, 0
  jz @ex
  mov AL, Value
  mov EDI, pi
  cld
  repne SCASB
  jne @ex
  mov EAX, Count
  sub EAX, ECX
  mov @Result, EAX
@ex:
  dec @Result
  popfd
  popad
 end;

 function memfindword(pi: Pointer; Value: Word; Count: Cardinal): Integer;
//label ex;
//begin
 asm
  pushad
  pushfd
  mov @Result, 0
  mov ECX, Count
  cmp ECX, 0
  jz @ex
  mov AX, Value
  mov EDI, pi
  cld
  repne SCASW
  jne @ex
  mov EAX, Count
  sub EAX, ECX
  mov @Result, EAX
@ex:
  dec @Result
  popfd
  popad
 end;
//end;

function memfindint64(pi: Pointer; Value: int64; Count: Cardinal): Integer;
asm
  pushad
  pushfd
  mov @Result, 0
  mov ECX, Count
  cmp ECX, 0
  jz @ex
  mov EAX, dword ptr Value
  mov EBX, dword ptr (Value+4)
  mov EDI, pi
@loop:
  cmp EAX, [EDI]
  je @found1
  dec ECX
  jz @ex
  add EDI, 8     // go to next int 64 value
  jmp @loop
@found1:
  add EDI, 4     // go to next half of current int64 value
  cmp EBX, [EDI]
  je @found2
  dec ECX
  jz @ex
  add EDI, 4
  jmp @loop
@found2:
  mov EAX, Count
  sub EAX, ECX
  mov @Result, EAX
@ex:
  dec @Result
  popfd
  popad
end;

function memfindgeneral(
  pi: Pointer;        // start address for finding
  pValue: Pointer;    // pointer to the finding value
  ValueSize: Cardinal; // the size of finding value in bytes
  Count: Cardinal      // number of values in array
  ): Integer; stdcall;
 asm
  pushad
  pushfd
  mov @Result, 0
  mov EBX, Count
  cmp EBX, 0
  jz @ex
  mov EDI, pi
@loop:
  mov ESI, pValue
  mov ECX, ValueSize;
  cld
  repe CMPSB
  jz @ex1
  add EDI, ECX
  dec EBX
  jnz @loop
  jmp @ex
@ex1:
  dec EBX
  mov EAX, Count
  sub EAX, EBX
  mov @Result, EAX
@ex:
  dec @Result
  popfd
  popad
 end;
{$ENDIF CPUX86}

{$IFDEF CPUX64}
 // in 64bit mode order of parameters in procedure: RCX, RDX, R8, R9, stack... (differs from x86)
procedure memcpyfromend(pi, po: Pointer; Count: Cardinal);
asm
  push RDI
  push RSI
  push RCX
  mov RSI, RCX   // pi is in RCX
  mov RDI, RDX   // po is in RDX
  mov RCX, R8    // count is in R8
  add RSI, RCX
  add RDI, RCX
  dec RSI
  dec RDI
  std
  repne MOVSB
  pop RCX
  pop RSI
  pop RDI
end;

// in 64bit mode order of parameters in procedure: RCX, RDX, R8, R9, stack... (differs from x86)
procedure memcpyfrombegin(pi, po: Pointer; Count: Cardinal);  // copying from begin
asm
  push RDI
  push RSI
//  push RCX
  mov RSI, RCX   // pi is in RCX
  mov RDI, RDX   // po is in RDX
  mov RCX, R8    // count is in R8
  cld
  repne MOVSB
//  pop RCX
  pop RSI
  pop RDI
end;

// in 64bit mode order of parameters in procedure: RCX, RDX, R8, R9, stack... (differs from x86)
procedure memclr(po: Pointer; Count: Cardinal);
asm
  push RDI
  push RCX
  mov RDI, RCX
  mov RCX, RDX
  xor AL, AL
  cld
  repnz STOSB // repne STOSB
  pop RCX
  pop RDI
end;

procedure memset(po: Pointer; Value: Byte; Count: Cardinal);
asm
  push RDI
//  push RSI
  push RCX
  mov RDI, RCX
  mov RCX, R8
  mov AL, DL
  cld
  repne STOSB
  pop RCX
//  pop RSI
  pop RDI
 end;

 // Value parameter is always 32bit here and does not depend on 32 or 64bit platform
 // in 64bit mode order of parameters in procedure: RCX, RDX, R8, R9, stack... (differs from x86)
 // 64bit calling conversion does not depend on stdcall, fastcall and other convention words, they are ignored and take effect only for 32bit.
function memfinddword(pi: Pointer; Value: Integer; Count: Cardinal): Integer;
 asm
  push RAX
  push RDI
  //push RSI
  push RCX
  mov Result, 0
  cmp R8, 0       // Count is in R8, handle case where Count=0
  jz @ex
  mov RDI, RCX    // pi is in RCX
  mov RCX, R8
  mov EAX, EDX
  cld
  repne SCASD
  jne @ex
  mov RAX, R8    // original Count
  sub EAX, ECX
  mov Result, EAX
@ex:
  dec Result
  pop RCX
  //pop RSI
  pop RDI
  pop RAX
 end;


// Value parameter is always 32bit here and does not depend on 32 or 64bit platform
// in 64bit mode order of parameters in procedure: RCX, RDX, R8, R9, stack... (differs from x86)
// 64bit calling conversion does not depend on stdcall, fastcall and other convention words, they are ignored and take effect only for 32bit.
function memfindbyte(pi: Pointer; Value: Byte; Count: Cardinal): Integer;
asm
  push RAX
  push RDI
  push RSI
  push RCX
  mov Result, 0
  cmp R8, 0
  jz @ex
  mov RDI, RCX
  mov RCX, R8
  mov AL, DL
  cld
  repne SCASB
  jne @ex
  mov RAX, R8
  sub EAX, ECX
  mov Result, EAX //mov qword ptr Result,RAX
@ex:
  dec Result
  pop RCX
  pop RSI
  pop RDI
  pop RAX
end;

function memfindword(pi: Pointer; Value: word; Count: Cardinal): Integer;
asm
  push RAX
  push RDI
  push RSI
  push RCX
  mov Result, 0
  cmp R8, 0
  jz @ex
  mov RDI, RCX
  mov RCX, R8
  mov AX, DX
  cld
  repne SCASW
  jne @ex
  mov RAX, R8
  sub RAX, RCX
  mov Result, EAX
@ex:
  dec Result
  pop RCX
  pop RSI
  pop RDI
  pop RAX
 end;

function memfindint64(pi: Pointer; Value: int64; Count: Cardinal): Integer;
asm
  push RAX
  push RBX
  push RDI
  push RSI
  push RCX
  mov Result, 0
  cmp R8, 0
  jz @ex
  mov RDI, RCX
  mov RCX, R8
  mov RAX, RDX
  cld
  repne SCASQ
  jne @ex
  mov RAX, R8
  sub RAX, RCX
  mov Result, EAX

  {
  mov RBX, qword ptr (Value+4)
@loop:
  cmp RAX,[RDI]
  je @found1
  dec RCX
  jz @ex
  add RDI,8     // go to next int 64 value
  jmp @loop
@found1:
  add RDI,4     // go to next half of current int64 value
  cmp RBX,[RDI]
  je @found2
  dec RCX
  jz @ex
  add RDI,4
  jmp @loop
@found2:
  mov RAX,[ LARGE Count]
  sub RAX,RCX
  mov qword ptr Result,RAX}
@ex:
  dec Result
  pop RCX
  pop RSI
  pop RDI
  pop RBX
  pop RAX
end;


function memfindgeneral(
  pi: Pointer;        // start address for finding
  pValue: Pointer;    // pointer to the finding value
  ValueSize: Cardinal; // the size of finding value in bytes
  Count: Cardinal      // number of values in array
  ): Integer;
 asm
  push RAX
  push RBX
  push RDI
  push RSI
  push RCX
  mov Result, 0
  cmp R9, 0
  jz @ex
  mov RDI, RCX    // pi
  mov RBX, R9     // Count
@loop:
  mov RSI, RDX    // pValue
  mov RCX, R8;    // ValueSize
  cld
  repe CMPSB
  jz @ex1
  add RDI, RCX
  dec RBX
  jnz @loop
  jmp @ex
@ex1:
  dec RBX
  mov RAX, R9
  sub RAX, RBX
  mov Result, EAX
@ex:
  dec Result
  pop RCX
  pop RSI
  pop RDI
  pop RBX
  pop RAX
 end;
{$ENDIF CPUX64}

procedure memcpy(pi, po: Pointer; Count: Cardinal);
begin
 if ((ConvertInt(pi) + ConvertInt(Count)) > ConvertInt(po)) and (ConvertInt(pi) < ConvertInt(po))
 then memcpyfromend(pi, po, Count) // copy from end
 else memcpyfrombegin(pi, po, Count); //Move(PPointer(pi)^, PPointer(po)^, Count);

end;

 { THArray }

constructor THArray.Create;
begin
  inherited Create;
  FCount := 0;
  FCapacity := 0;
  FItemSize := 1;
  FValues := nil;
  GetMem(FHelperBuf, FItemSize);
  FHelperBufSize := FItemSize;
end;

destructor THArray.Destroy;
begin
  ClearMem;
  FItemSize := 0;
  FreeMem(FHelperBuf);
  FHelperBuf := nil;
  FHelperBufSize := 0;
  inherited Destroy;
end;

procedure THArray.Delete(Index: Cardinal);
begin
  Error(Index, FCount);
  if Index < (FCount - 1) then memcpy(GetAddr(Index+1), GetAddr(Index), (FCount-Index-1)*FItemSize);
  Dec(FCount);
end;

procedure THArray.Clear;
begin
  FCount := 0;
end;

procedure THArray.ClearMem;
begin
  FCount := 0;
  FCapacity := 0;
  FreeMem(FValues);
  FValues := nil;
end;

function THArray.Add(pValue: Pointer): Cardinal;
begin
  Result := Insert(FCount, pValue);
end;

procedure THArray.AddMany(pValue: Pointer; Cnt: Cardinal);
begin
  //if Cnt <= 0 then exit;
  InsertMany(FCount, pValue, Cnt);
end;

procedure THarray.Hold;
// frees unused memory
begin
  SetCapacity(FCount);
end;

procedure THArray.SetCapacity(Value: Cardinal);
begin
  ReAllocMem(FValues, Value*FItemSize);
  FCapacity := Value;
  if FCount > FCapacity then FCount := FCapacity;
end;

function THArray.AddFillValues(Cnt: Cardinal; Value: Byte = $0): Pointer;
begin
  if FCount + Cnt > Capacity then GrowTo(FCount + Cnt);
  Result := CalcAddr(FCount);
  //FillChar(PByte(CalcAddr(FCount))^, Cnt * ItemSize, 0);
  //memclr(Result, Cnt*FItemSize);
  memset(Result, Value, Cnt*FItemSize);
  FCount := FCount + Cnt;
end;

procedure THArray.Zero;
begin
  if FCount = 0 then exit;
  memclr(FValues, FCount*FItemSize);
  //FillChar(PByte(FValues)^, FCount * ItemSize, 0);
end;

procedure THArray.Grow;
// allocates memory for more number of elements by the next rules
//     the size of allocated memory increases on 25% if array has more than 64 elements
//     the size of allocated memory increases on 16 elements if array has from 8 to 64 elements
//     the size of allocated memory increases on 4 elements if array has less than 8 elements
var Delta: Cardinal;
begin
  if FCapacity > 64 then Delta := FCapacity div 4
  else if FCapacity > 8 then Delta := 16 else Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

procedure THArray.GrowTo(Cnt: Cardinal);
// increases size of allocated memory till Cnt elements (if count enough large) or
// to a number as described in Grow procedure
var Delta: Cardinal;
begin
  if Cnt <= FCapacity then exit;
  if FCapacity > 64 then Delta := FCapacity div 4
  else if FCapacity > 8 then Delta := 16 else Delta := 4;

  if (FCapacity + Delta) < Cnt then Delta := Cnt - FCapacity;
  SetCapacity(FCapacity + Delta);
end;

function THArray.Insert(Index: Cardinal; pValue: Pointer): Cardinal;
begin
  Error(Index, FCount + 1);
  Inc(FCount);
  if FCount >= FCapacity then Grow;
  memcpy(CalcAddr(Index), CalcAddr(Index + 1), (FCount - Index- 1 ) * FItemSize); // make place to insert
  Update(Index, pValue);
  Result := Index;
end;

procedure THArray.InsertMany(StartIndex: Cardinal; pValue: Pointer; Cnt: Cardinal);
begin
  if Cnt = 0 then exit; // nothing to do
  Assert(pValue <> nil);

  Error(StartIndex, FCount + 1);
  if FCount + Cnt > FCapacity then GrowTo(FCount + Cnt);
  FCount := FCount + Cnt;
  memcpy(CalcAddr(StartIndex), CalcAddr(StartIndex + Cnt), (FCount - StartIndex - Cnt) * FItemSize);  // make place to insert
  UpdateMany(StartIndex, pValue, Cnt);
end;

//TODO: shall we implement function Update with Count parameter when less then ITemSize bytes need to be copied into array
// remaing space should be filled by zeros then
procedure THArray.Update(Index: Cardinal; pValue: Pointer);
begin
  Error(Index, FCount);
  if pValue = nil
    then memclr(GetAddr(Index), FItemSize)
    else memcpy(pValue, GetAddr(Index), FItemSize);
end;

procedure THArray.UpdateMany(StartIndex: Cardinal; pValue: Pointer; Cnt: Cardinal; Expand: Boolean = False);
var
  Last: Cardinal;
begin
  if Cnt = 0 then exit;  // nothing to update
  Assert(pValue <> nil);

//TODO: shall we allow StartIndex to be >FCount? In this case we may have 'holes' with random data in THarray
  Last := StartIndex + Cnt;
  if Expand then begin
    if Last > FCount then begin
      GrowTo(Last);
      FCount := Last;
    end;
  end
  else Error(Last - 1, FCount);

  memcpy(pValue, GetAddr(StartIndex), FItemSize*Cnt);
end;

function THArray.GetMany(StartIndex: Cardinal; pValue: Pointer; Cnt: Cardinal): Cardinal;
begin
  Error(StartIndex, FCount);
  Assert(pValue <> nil);

  Result := Cardinal(IfThen(StartIndex + Cnt > FCount, FCount - startIndex, Cnt));
  //if StartIndex + Cnt > FCount
  //  then Result := FCount - startIndex
  //  else Result := Cnt;
  memcpy(CalcAddr(StartIndex), pValue, FItemSize*Result);
end;

procedure THArray.Get(Index: Cardinal; pValue: Pointer);
begin
  Assert(pValue <> nil);
  memcpy(GetAddr(Index), pValue, FItemSize);
end;

function THArray.GetAddr(Index: Cardinal): Pointer;
begin
  Error(Index, FCount);
  Result := CalcAddr(Index);
end;

function THArray.CalcAddr(Index: Cardinal): Pointer;
begin
  Result := Pointer(ConvertInt(FValues) + ConvertInt(Index * FItemSize));
end;

procedure THArray.Error(Value, MaxValue: Cardinal);
begin
  if Value >= MaxValue then raise ERangeError.CreateFmt(SItemNotFound, [Value]);
end;

// intentionally done: SetItemSize does not generate an exception when Size=0.
// need for Oracle components when they define ItemSize after creating THarray instance.
procedure THArray.SetItemSize(Size: Cardinal);
begin
  ClearMem;
  FItemSize := Size;
  ReallocMem(FHelperBuf, FItemSize);
  FHelperBufSize := FItemSize;
end;

procedure THArray.MoveData(FromPos, Cnt: Cardinal; Offset: Integer);
var mem: Pointer;
begin
  Assert(Integer(FromPos) + Offset > 0);

  Error(FromPos + Cnt, FCount);
  Error(Integer(FromPos) + Offset, FCount); // Offset can be negative number
  Error(Integer(FromPos + Cnt) + Offset, FCount);

  mem := AllocMem(Cnt * FItemSize);
  try
    memcpy(CalcAddr(FromPos), mem, Cnt * FItemSize);
    if Offset < 0 then memcpy(CalcAddr(Integer(FromPos) + Offset), CalcAddr(Integer(FromPos + Cnt) + Offset), Cardinal(-Offset) * FItemSize);
    if Offset > 0 then memcpy(CalcAddr(FromPos + Cnt), CalcAddr(FromPos), Cardinal(Offset) * FItemSize);
    memcpy(mem, CalcAddr(Integer(FromPos) + Offset), Cnt * FItemSize);
  finally
    FreeMem(mem);
  end;
end;

procedure THArray.Swap(Index1, Index2: Cardinal);
var a1, a2: Pointer;
begin
  if FHelperBufSize <> FItemSize then ReallocMem(FHelperBuf, FItemSize);

  a1 := GetAddr(Index1);
  a2 := GetAddr(Index2);
  memcpy(a1, FHelperBuf, FItemSize);
  memcpy(a2, a1, FItemSize);
  memcpy(FHelperBuf, a2, FItemSize);
end;

// this is actually Selection Sort algorithm
procedure THArray.SelectionSort(CompareProc : TCompareProc);
var
  maxEl: Cardinal;
  i, j : Cardinal;
begin
  if FCount < 2 then exit;
  if @CompareProc = nil then raise EArgumentException.Create(SNoCompareProc);

  for i := FCount - 1 downto 1 do begin
    maxEl := i;
    j := 0;
    while j < i do begin
      if CompareProc(self, maxEl, j) < 0 then maxEl := j;
      Inc(j);
    end;

    if maxEl <> i then Swap(i, maxEl);
  end;
end;

// Bubble sort
// Everybody knows it
procedure THArray.BubbleSort(CompareProc: TCompareProc);
var
  i, j  : Cardinal;
  WasSwap: Boolean;
begin
  if FCount < 2 then exit; // one or zero elements in array, no need to sort
  if @CompareProc = nil then raise EArgumentException.Create(SNoCompareProc);

  for i := 0 to FCount - 2 do begin
    WasSwap := False;
    for j := 0 to FCount - 2 - i do
      if CompareProc(self, j, j + 1) > 0 then begin
        Swap(j, j + 1);
        WasSwap := True;
      end;
    if NOT WasSwap then break; // there was no Swap in internal for. it means that whole array is sorted already
  end;
end;

{ // LOOKS LIKE WE CANNOT IMPLEMENT GENERIC INSERTION SORT WITHOUT USING GENERICS
  // BECAUSE CompareProc(self, j, i) DOES NOT WORK WELL IN THIS ALGORITHM
// Insertion sort
// L..i-1 this is already sorted part of array
// we take i'th element and find a proper place where to insert it in in sorted part
// then we take i+1'th element, find place for it and so on
procedure THArray.InternalInsertSort(CompareProc: TCompareProc; L, R: Cardinal);
var
  i, j: Cardinal;
  tmp: Pointer;
begin
  GetMem(tmp, FItemSize);
  try
    for i := L + 1 to R do begin
      memcpy(CalcAddr(i), tmp, FItemSize);
      j := i - 1;
      while (j >= L) and (CompareProc(self, j, i) > 0) do begin
        memcpy(CalcAddr(j), CalcAddr(j + 1), FItemSize);
        Dec(j);
      end;
      memcpy(tmp, CalcAddr(j + 1), FItemSize);
    end;
  finally
    FreeMem(tmp);
  end;
end;

// see InternalInsertSort for brief description of algorithm.
procedure THArray.InsertSort(CompareProc: TCompareProc);
begin
  if FCount < 2 then exit;
  if @CompareProc = nil then raise EArgumentException.Create(SNoCompareProc);

  InternalInsertSort(CompareProc, 0, FCount - 1);
end;
 }
// Shaker Sort
procedure THArray.ShakerSort(CompareProc: TCompareProc);
var
  i, j: Cardinal;
  Min, Max: Cardinal;
begin
  if FCount < 2 then exit;
  if @CompareProc = nil then raise EArgumentException.Create(SNoCompareProc);

    for i := 0 to (FCount div 2) - 1 do begin
      if CompareProc(self, i, i + 1) > 0 then begin
        Max := i;
        Min := i + 1;
      end else begin
        Max := i + 1;
        Min := i;
      end;

      for j := i + 2 to FCount - i - 1 do
        if CompareProc(self, j, Max) > 0 then Max := j
        else if CompareProc(self, j, Min) < 0 then Min := j;

      Swap(i, Min);
      if Max = i then Max := Min; // this is new place of Max element after Swap(i, Min);
      Swap(FCount - i - 1, Max);
    end;
end;

procedure THArray.QuickSort(CompareProc: TCompareProc);
begin
  if FCount < 2 then exit;
  InternalQuickSort(CompareProc, nil, 0, FCount - 1);
end;

procedure THArray.InternalQuickSort(CompareProc: TCompareProc; SwapProc: TSwapProc; L, R: Cardinal);
var
  I,J: Cardinal;
  P: Cardinal;
begin
  if @CompareProc = nil then raise EArgumentException.Create(SNoCompareProc);

  i := L;
  j := R;
  P := (i + j) shr 1;
 //	repeat
  while i < j do begin
    while ((CompareProc(self, i, P) < 0) { and(I<=J) } ) do Inc(i);
    while ((CompareProc(self, j, P) > 0) { and(I<=J) } ) do Dec(j);

    if i <= j then begin
      if i = P then P := j // count a case when element with index P will be swapped and receive another index
      else if j = P then P := i;
      //Swap(i, j);
      if @SwapProc = nil then Swap(i, j) else SwapProc(self, i, j);
      Inc(i);

      //TODO: to avoid out of range exception then Dec(j) when j=0. I think there should be better solution to bypasss this situation
      // for example do not call InternalQuickSort when R-L=1 because sorting is trivial in a such interval
      // another solution might be to call InsertSort instead of QuickSort for intervals less then some value (e.g. 40)
      if j = 0 then break;
      Dec(j);
    end;
  end;
  //until i > j;
  if L < j then
    InternalQuickSort(CompareProc, SwapProc, L, j);
  if i < R then
    InternalQuickSort(CompareProc, SwapProc, i, R);
    {
  if @CompareProc=nil then exit;

    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while ((CompareProc(self,I,P) < 0){and(I<=J)}{) do Inc(I);
      while ((CompareProc(self,J,P) > 0){and(I<=J)}{) do Dec(J);
      if I <= J then begin
        if I = P then P := J
         else if J = P then P := I;
        if @SwapProc = nil
         then Swap(I,J)
         else SwapProc(self, I, J);
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then InternalQuickSort(CompareProc,SwapProc, L, J);
    if I < R then InternalQuickSort(CompareProc,SwapProc, I, R);
    }
end;

function THArray.QuickFind(FindProc: TFindProc; FindData: Pointer): Integer;
var
  L, R: Cardinal;
begin
  Result := -1; // 'not found' by default
  if FCount = 0 then exit;

  if @FindProc = nil then raise EArgumentException.Create(SNoFindProc);

  L := 0;
  R := FCount - 1;
  if FindProc(self, R, FindData) > 0 then begin // FindData is larger than last element in the array
    Result := -Integer(R + 2);
    exit;
  end;
  if FindProc(self, L, FindData) < 0 then begin // FindData is smaller than first element in the array
    Result := -1;
    exit;
  end;

  Result := InternalQuickFind(FindProc, FindData, L, R);
end;

function THArray.InternalQuickFind(FindProc: TFindProc; FindData: Pointer; L, R: Cardinal): Integer;
var
  middle: Cardinal;
  res: Integer;
begin
begin
  Result := -1; // may be default value not needed here

  if L = R then begin
    res := FindProc(self, L, FindData);
    if res < 0 then Result := -Integer(L + 1)
    else if res > 0 then Result := -Integer(L + 2)
    else Result := Integer(L);
  end
  else
  if R - L = 1 then begin
    res := FindProc(self, L, FindData);
    if res = 0 then Result := Integer(L)
    else if res < 0 then Result := -Integer(L + 1)
    else if res > 0 then begin
      res := FindProc(self, R, FindData);
      if res = 0 then Result := Integer(R)
      else if res < 0 then Result := -Integer(R + 1)
      else if res > 0 then Result := -Integer(R + 2)
    end;
  end
  else
  begin
    while True do begin
      middle := (L + R) div 2;
      res := FindProc(self, middle, FindData);
      if res < 0 then begin Result := InternalQuickFind(FindProc, FindData,  L, middle - 1); break; end  // searched element is on the left
      else if res > 0 then begin Result := InternalQuickFind(FindProc, FindData,  middle + 1, R); break; end  // searched elemnt is on the right
      else begin  // we've found element being searched
        if middle = L then break;
        Dec(middle);
        while (True) do // look for lowest index in case several elements =Value exist in the array
          if FindProc(self, middle, FindData) = 0 then begin
            if middle > L
              then Dec(middle)
              else break; // stop if we arrived to Start index
          end else begin
            Inc(middle);
            break;
          end;
        Result := Integer(middle);
        exit;
      end;
    end;
  end;
end;
{
  Result := -1;
  if FCount = 0 then exit;
  if @FindProc = nil then exit;
  L := 0;
  R := FCount - 1;
  if FindProc(self, R, FindData) < 0 then begin
    Result := -1;//R;
    exit;
  end;

  while True do begin
    was1 := abs(R-L) = 1;
    Result := (L+R) shr 1;
    if Integer(L) = Result then goto fin;//exit;
    res := FindProc(self, Result, FindData);
    if res < 0 then L := Result
     else if res > 0 then R := Result
      else goto fin;//exit;
    if was1 then goto fin;//exit;
  end;
fin: }
end;

{$IFDEF TBYTES}
function THArray.ToBytes: TBytes;
begin
  if FCount = 0 then Exit;

  SetLength(Result, FCount*FItemSize);
  memcpy(FValues, @Result[0], FCount*FItemSize);
end;
{$ENDIF}

procedure THArray.LoadFromStream(s: TStream);
var i, oc: Cardinal;
begin
  s.Read(i, sizeof(i));
  oc := FCount;
  AddFillValues(i);
  s.Read(CalcAddr(oc)^, i * FItemSize);
end;

procedure THArray.SaveToStream(s: TStream);
begin
  s.Write(FCount, sizeof(Integer));
  s.Write(PChar(FValues)^, FCount * FItemSize);
end;

function THArray.IndexOf(Value: Pointer): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArray.IndexOfFrom(Value: Pointer; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then Exit;
  if Value = nil then Exit;
 //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindgeneral(GetAddr(Start), Value, FItemSize, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayObjects }

function THArrayObjects.AddValue(Value: TObject): Cardinal;
begin
  Result := inherited Add(@Value);
end;

procedure THArrayObjects.ClearMem;
var i: Cardinal;
begin
  for i := 1 to FCount do GetValue(i - 1).Free;
  inherited;
end;

procedure THArrayObjects.SafeClearMem;
begin
  inherited ClearMem;
end;

constructor THArrayObjects.Create;
begin
  inherited;
  FItemSize := sizeof(TObject);
end;

procedure THArrayObjects.Delete(Index: Cardinal);
var o: TObject;
begin
  o := GetValue(Index);
  inherited;
  FreeAndNil(o);
end;

// SafeDelete does not free TObject only deletes its pointer from the array
procedure THArrayObjects.SafeDelete(Index: Cardinal);
begin
  inherited Delete(Index);
end;

function THArrayObjects.GetValue(Index: Cardinal): TObject;
begin
  Result := TObject(GetAddr(Index)^);
end;

procedure THArrayObjects.SetValue(Index: Cardinal; const Value: TObject);
begin
  Update(Index, @Value);
end;

function THArrayObjects.IndexOf(Value: TObject): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

// memfindgeneral because TObject can be either 4 bytes or 8 bytes long depending on Windows 32bit or 64bit
function THArrayObjects.IndexOfFrom(Value: TObject; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindgeneral(GetAddr(Start), @Value, sizeof(Value), FCount - Start); //memfinddword(GetAddr(Start), NativeUInt(Value), FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayShortInt }

constructor THArrayShortInt.Create;
begin
  inherited Create;
  FItemSize := sizeof(ShortInt);
end;

function THArrayShortInt.AddValue(Value:ShortInt): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayShortInt.GetValue(Index: Cardinal): ShortInt;
begin
  Result := PShortInt(GetAddr(Index))^;
end;

procedure THArrayShortInt.SetItemSize(Size: Cardinal);
begin
  raise ENotSupportedException.Create(SWrongCallSetItemSize);
end;

procedure THArrayShortInt.SetValue(Index: Cardinal; Value: ShortInt);
begin
  Update(Index, @Value);
end;

function THArrayShortInt.IndexOf(Value: ShortInt): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayShortInt.IndexOfFrom(Value: ShortInt; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
 //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindword(GetAddr(Start), word(Value), FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayByte }

function THArrayByte.AddValue(Value: Byte): Cardinal;
begin
  Result := inherited Add(@Value);
end;

constructor THArrayByte.Create;
begin
  inherited Create;
  FItemSize := sizeof(Byte);
end;

function THArrayByte.GetValue(Index: Cardinal): Byte;
begin
  Result := PByte(GetAddr(Index))^;
end;

function THArrayByte.IndexOf(Value: byte): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayByte.IndexOfFrom(Value: Byte; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindbyte(GetAddr(Start), Value, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

procedure THArrayByte.SetValue(Index: Cardinal; Value: Byte);
begin
  Update(Index, @Value);
end;

{ THArraySmallInt }

constructor THArraySmallInt.Create;
begin
  inherited Create;
  FItemSize := sizeof(Smallint);
end;

function THArraySmallInt.AddValue(Value:SmallInt): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArraySmallInt.GetValue(Index: Cardinal):SmallInt;
begin
  Result := PSmallint(GetAddr(Index))^;
end;

procedure THArraySmallInt.SetItemSize(Size: Cardinal);
begin
  raise ENotSupportedException.Create(SWrongCallSetItemSize);
end;

procedure THArraySmallInt.SetValue(Index: Cardinal; Value: SmallInt);
begin
  Update(Index, @Value);
end;

function THArraySmallInt.IndexOf(Value: SmallInt): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArraySmallInt.IndexOfFrom(Value: SmallInt; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
 //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindword(GetAddr(Start), word(Value), FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayWord }

constructor THArrayWord.Create;
begin
  inherited Create;
  FItemSize := sizeof(Word);
end;

function THArrayWord.AddValue(Value: Word): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayWord.InsertValue(Index: Cardinal; Value: Word): Cardinal;
begin
  Result := inherited Insert(Index, @Value);
end;

function THArrayWord.GetValue(Index: Cardinal): Word;
begin
  Result := PWord(GetAddr(Index))^;
end;

procedure THArrayWord.SetValue(Index:Cardinal; Value: Word);
begin
  Update(Index,@Value);
end;

function THArrayWord.IndexOf(Value: word): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayWord.IndexOfFrom(Value: word; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindword(GetAddr(Start), Value, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayLongWord }

constructor THArrayLongWord.Create;
begin
  inherited Create;
  FItemSize := sizeof(LongWord);
end;

function THArrayLongWord.AddValue(Value: LongWord): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayLongWord.GetValue(Index: Cardinal): LongWord;
begin
  Result := PLongWord(GetAddr(Index))^;
end;

procedure THArrayLongWord.SetValue(Index: Cardinal; Value: LongWord);
begin
  Update(Index, @Value);
end;

function THArrayLongWord.IndexOf(Value: LongWord): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

//LongWord is unsigned and always 4 bytes long (on both 32bit and 64bit Windows platforms)
function THArrayLongWord.IndexOfFrom(Value: LongWord; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfinddword(GetAddr(Start), Integer(Value), FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

 { THArrayInt64 }

constructor THArrayInt64.Create;
begin
  inherited Create;
  FItemSize := sizeof(Int64);
end;

function THArrayInt64.AddValue(Value: Int64): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayInt64.GetValue(Index: Cardinal): Int64;
begin
  Result := PInt64(GetAddr(Index))^;
end;

procedure THArrayInt64.SetValue(Index: Cardinal; Value: Int64);
begin
  Update(Index, @Value);
end;

function THArrayInt64.IndexOf(Value: int64): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayInt64.IndexOfFrom(Value: int64; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindint64(GetAddr(Start), Value, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayUInt64 }

constructor THArrayUInt64.Create;
begin
  inherited Create;
  FItemSize := sizeof(UInt64);
end;

function THArrayUInt64.AddValue(Value: UInt64): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayUInt64.GetValue(Index: Cardinal): UInt64;
begin
  Result := PUInt64(GetAddr(Index))^;
end;

procedure THArrayUInt64.SetValue(Index: Cardinal; Value: UInt64);
begin
  Update(Index, @Value);
end;

function THArrayUInt64.IndexOf(Value: UInt64): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayUInt64.IndexOfFrom(Value: UInt64; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues <> nil then begin
    Result := memfindint64(GetAddr(Start), Int64(Value), FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;


{ THArrayInteger }

constructor THArrayInteger.Create;
begin
  inherited Create;
  FItemSize := sizeof(Integer);
end;

function THArrayInteger.AddValue(Value: Integer): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayInteger.InsertValue(Index: Cardinal; Value: Integer): Cardinal;
begin
  Result := inherited Insert(Index, @Value);
end;

function THArrayInteger.IndexOf(Value: Integer): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayInteger.IndexOfFrom(Value: Integer; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if FValues = nil
    then Result := -1
    else begin
      Result := memfinddword(GetAddr(Start), Value, FCount - Start);
      if Result <> -1 then Result := Result + Integer(Start);
    end;
end;

function THArrayInteger.GetValue(Index: Cardinal): Integer;
begin
  Result := PInteger(GetAddr(Index))^;
end;

procedure THArrayInteger.SetValue(Index: Cardinal; Value: Integer);
begin
  Update(Index, @Value);
end;

procedure THArrayInteger.Push(Value: Integer);
begin
  AddValue(Value);
end;

function THArrayInteger.Pop: Integer;
begin
  Result := Value[FCount - 1];
  Delete(FCount - 1);
end;

procedure THArrayInteger.AddFromString(InputString, Delimiters: string);
var i, c: Integer;
begin
  c := HGetTokenCount(InputString, Delimiters, False);
  for i := 0 to c - 1 do
    AddValue(StrToInt(HGetToken(InputString, Delimiters, False, i)));
end;

function THArrayInteger.GetAsString: string;
var i: Cardinal;
begin
  Result := ' ';
  for i := 1 to FCount do
    Result := Result + IntToStr(Value[i - 1]) + ' ';
end;

function THArrayInteger.CalcMax: Integer;
var i: Cardinal;
begin
  Result := -1;
  if FCount = 0 then exit;
  Result := Value[0];
  for i := 1 to FCount - 1 do
    if Value[i] > Result then Result := Value[i];
end;

{procedure THArrayInteger.QuickSort(L,R:Integer);
 var
  I,J,P,temp: Integer;
begin
  I:=L;
  J:=R;
  p:=(L+R) shr 1;
  repeat
    while Value[I]<Value[P] do Inc(I);
    while Value[J]>Value[P] do Dec(J);
    if I <= J then
    begin
      temp:=Value[I];
      Value[I]:=Value[J];
      Value[I]:=temp;
      Inc(I);
      Dec(J);
    end;
  until I > J;
  if L<J then QuickSort(L,J);
  if I<R then QuickSort(I,R);
end;}

{ THArrayPointer }

constructor THArrayPointer.Create;
begin
  inherited Create;
  FItemSize := sizeof(Pointer);
end;

function THArrayPointer.AddValue(Value: Pointer): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayPointer.IndexOf(Value: Pointer): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayPointer.IndexOfFrom(Value: Pointer; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  if FValues <> nil then begin
    Result := memfindgeneral(GetAddr(Start), @Value, sizeof(Value), FCount - Start); //memfinddword(GetAddr(Start), v, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

function THArrayPointer.GetValue(Index: Cardinal): Pointer;
begin
  Result := PPointer(GetAddr(Index))^;
end;

procedure THArrayPointer.SetValue(Index: Cardinal; Value: Pointer);
begin
  Update(Index, @Value);
end;

 { THArrayBoolean }

constructor THArrayBoolean.Create;
begin
  inherited Create;
  FItemSize := sizeof(Boolean);
end;

function THArrayBoolean.AddValue(Value: Boolean): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayBoolean.InsertValue(Index: Cardinal; Value: Boolean): Cardinal;
begin
  Result := inherited Insert(Index, @Value);
end;

function THArrayBoolean.GetValue(Index: Cardinal): Boolean;
begin
  Result := PBoolean(GetAddr(Index))^;
end;

procedure THArrayBoolean.SetValue(Index: Cardinal; Value: Boolean);
begin
  Update(Index, @Value);
end;

function THArrayBoolean.IndexOf(Value: Boolean): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayBoolean.IndexOfFrom(Value: Boolean; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  if Assigned(FValues) then begin
    Result := memfindbyte(GetAddr(Start), Byte(Value), FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayDouble }

constructor THArrayDouble.Create;
begin
  inherited Create;
  FItemSize := sizeof(Double);
end;

function THArrayDouble.AddValue(Value: Double): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayDouble.GetValue(Index: Cardinal): Double;
begin
  Result := PDouble(GetAddr(Index))^;
end;

procedure THArrayDouble.SetValue(Index: Cardinal; Value: Double);
begin
  Update(Index, @Value);
end;

function THArrayDouble.IndexOf(Value: Double): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayDouble.IndexOfFrom(Value: Double; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  if Assigned(FValues) then begin
    Result := memfindgeneral(FValues, @Value, ItemSize, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayCurrency }

constructor THArrayCurrency.Create;
begin
  inherited Create;
  FItemSize := sizeof(Currency);
end;

function THArrayCurrency.AddValue(Value: Currency): Cardinal;
begin
  Result := inherited Add(@Value);
end;

function THArrayCurrency.GetValue(Index: Cardinal): Currency;
begin
  Result := PCurrency(GetAddr(Index))^;
end;

procedure THArrayCurrency.SetValue(Index: Cardinal; Value: Currency);
begin
  Update(Index, @Value);
end;

function THArrayCurrency.IndexOf(Value: Currency): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayCurrency.IndexOfFrom(Value: Currency; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  if Assigned(FValues) then begin
    Result := memfindgeneral(FValues, @Value, ItemSize, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArrayExtended }

constructor THArrayExtended.Create;
begin
  inherited Create;
  FItemSize := sizeof(Extended);
end;

function THArrayExtended.GetValue(Index: Cardinal): Extended;
begin
  Result := PExtended(GetAddr(Index))^;
end;

function THArrayExtended.AddValue(Value: Extended): Cardinal;
begin
  Result := inherited Add(@Value);
end;

procedure THArrayExtended.SetValue(Index: Cardinal; Value: Extended);
begin
  Update(Index, @Value);
end;

function THArrayExtended.IndexOf(Value: Extended): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayExtended.IndexOfFrom(Value: Extended; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  if Assigned(FValues) then begin
    Result := memfindgeneral(FValues, @Value, ItemSize, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;

{ THArraySingle }

constructor THArraySingle.Create;
begin
  inherited Create;
  FItemSize := sizeof(Single);
end;

function THArraySingle.GetValue(Index: Cardinal): Single;
begin
  Result := PSingle(GetAddr(Index))^;
end;

function THArraySingle.AddValue(Value: Single): Cardinal;
begin
  Result := inherited Add(@Value);
end;

procedure THArraySingle.SetValue(Index: Cardinal; Value: Single);
begin
  Update(Index, @Value);
end;

function THArraySingle.IndexOf(Value: Single): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArraySingle.IndexOfFrom(Value: Single; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then exit;
  if Assigned(FValues) then begin
    Result := memfindgeneral(FValues, @Value, ItemSize, FCount - Start);
    if Result <> -1 then Result := Result + Integer(Start);
  end;
end;


{ TWideString }

constructor TWideString.Create(Value: WideString);
begin
  FStr := Value;
end;

{ THArrayWideStrings }

function THArrayWideStrings.AddValue(Value: WideString): Cardinal;
begin
  Result := inherited AddValue(TWideString.Create(Value));
end;

function THArrayWideStrings.GetValue(Index: Cardinal): WideString;
begin
  Result := TWideString(inherited GetValue(Index)).FStr;
end;

function THArrayWideStrings.IndexOf(Value: WideString): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayWideStrings.IndexOfFrom(Value: WideString; Start: Cardinal): Integer;
var
  index: Cardinal;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if Assigned(FValues) then
    for index := Start to FCount - 1 do
      if GetValue(index) = Value then begin Result := Integer(index); exit; end;
  //Result := -1;
end;

procedure THArrayWideStrings.SetValue(Index: Cardinal; Value: WideString);
begin
  TWideString(inherited GetValue(Index)).FStr := Value;
end;

{ THArrayString }  {
constructor THArrayString.Create;
begin
  str_ptr := THArrayPointer.Create;
  FCount := 0;
  FCapacity := 0;
  FItemSize := sizeof(Pointer); // because we store strings here as pointers to memory pieces allocated separately for each string
  FValues := nil;
end;

destructor THArrayString.Destroy;
var
  i    : Cardinal;
  pStr : PChar;
begin
  for i := 1 to str_ptr.Count do
  begin
    pStr := PChar(str_ptr.Value[i - 1]);
    StrDispose(pStr);
  end;
  str_ptr.Free;
end;

function THArrayString.CalcAddr(num: Cardinal): Pointer;
begin
  Result := Pointer(ConvertInt(str_ptr.FValues) + ConvertInt(num * FItemSize));
end;

function THArrayString.AddValue(Value: String): Cardinal;
begin
  Result := self.Add(PChar(Value));
end;

function THArrayString.Add(pValue: Pointer): Cardinal;
begin
  Result := Insert(FCount, pValue);
end;

function THArrayString.Insert(num: Cardinal; pValue: Pointer): Cardinal;
var
  pStr: PChar;
  l   : Cardinal;
begin
  l := StrLen(PChar(pValue)) * sizeof(Char); // size in bytes
  pStr := StrAlloc(l + 1);
  memcpy(pValue, pStr, l + 1);
  Result := str_ptr.Insert(num, @pStr);
  FCount := str_ptr.Count;
  FCapacity := str_ptr.Capacity;
 // Result := FCount;
end;

procedure THArrayString.Update(num: Cardinal; pValue: Pointer);
var
  pStr : PChar;
  l    : Cardinal;
begin
  pStr := PChar(str_ptr.Value[num]);
  if pStr <> nil then StrDispose(pStr);
  if pValue <> nil then begin
    l := StrLen(PChar(pValue)) * sizeof(Char);
    pStr := StrAlloc(l + 1);
    memcpy(pValue, pStr, l + 1);
    str_ptr.Value[num] := pStr;
  end else
    str_ptr.Value[num] := nil;
end;

procedure THArrayString.MoveData(FromPos, Cnt: Cardinal; Offset: Integer);
begin
  str_ptr.MoveData(FromPos, Cnt, Offset);
end;

procedure THArrayString.Delete(num: Cardinal);
var pStr: PChar;
begin
  pStr := PChar(str_ptr.Value[num]);
  StrDispose(pStr);
  str_ptr.Delete(num);
  FCount := str_ptr.Count;
end;

procedure THArrayString.Get(num: Cardinal; pValue: Pointer);
var
  pStr: PChar;
  l   : Cardinal;
begin
  pStr := PChar(str_ptr[num]);
  l := StrLen(pStr) * sizeof(Char);
  memcpy(Pointer(pStr), pValue, l + 1);
end;

function THArrayString.GetValue(Index: Cardinal): string;
var
  pStr : PChar;
begin
  pStr := PChar(str_ptr[Index]);
  Result := pStr;
end;

procedure THArrayString.SetValue(Index: Cardinal; Value: string);
begin
  Self.Update(Index, PChar(Value));
end;

procedure THArrayString.Clear;
var
  i: Cardinal;
  pStr: PChar;
begin
  for i := 1 to str_ptr.Count do begin
    pStr := PChar(str_ptr[i - 1]);
    StrDispose(pStr);
  end;
  str_ptr.Clear;
  inherited Clear;
//  FCount := str_ptr.Count;
//  FCapacity := str_ptr.Capacity;
end;

procedure THArrayString.ClearMem;
var
  i   : Cardinal;
  pStr: PChar;
begin
  for i := 1 to str_ptr.Count do begin
    pStr := PChar(str_ptr[i - 1]);
    StrDispose(pStr);
  end;
  str_ptr.ClearMem;
  inherited ClearMem;
end;

function THArrayString.IndexOf(Value: string): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayString.IndexOfFrom(Value: string; Start: Cardinal): Integer;
var Index: Cardinal;
begin
  Result := -1;
  if Start >= FCount then exit;
  //Error(Start, Integer(FCount) - 1);
  if Assigned(FValues) then
    for Index := Start to FCount - 1 do
      if self.Value[Index] = Value then begin Result := Integer(Index); exit; end;
  //Result := -1;
end;

procedure THArrayString.Swap(Index1, Index2: Cardinal);
begin
  str_ptr.Swap(Index1, Index2);
end;                }


{ THArrayAnsiStringFix }

function THArrayAnsiStringFix.AddValue(Value: AnsiString): Cardinal;
begin
  memclr(FHelperBuf, FHelperBufSize); //TODO: for performance reasons we may delete this memclr, leaving termination zero only, this will not take effect to functionality.
//  SysUtils.StrPLCopy(FHelperBuf, Value, FItemSize div sizeof(AnsiChar));
  memcpy(PAnsiChar(Value), FHelperBuf, min(FItemSize, Cardinal(Length(Value)*sizeof(AnsiChar))));

  Result := inherited Add(FHelperBuf);  // copies FItemSize bytes from buf to its internal storage
end;

destructor THArrayAnsiStringFix.Destroy;
begin
  FreeMem(FHelperBuf);
  FHelperBuf := nil;
  FHelperBufSize := 0;
  inherited Destroy;
end;

constructor THArrayAnsiStringFix.Create;
begin
  raise ENotSupportedException.Create(Format(SUseCreateSizeConsructor, ['THArrayAnsiStringFix']));
end;

// SizeOfItem - in characters, however for AnsiString it equivalent bytes
// It is possible to create THArrayAnsiStringFix with size 0. needed for Oracle fields
constructor THArrayAnsiStringFix.CreateSize(SizeOfItem: Cardinal);
begin
  inherited Create;
  FItemSize := SizeOfItem * sizeof(AnsiChar);
  FHelperBufSize := FItemSize + sizeof(AnsiChar);
  FHelperBuf := AllocMem(FHelperBufSize);
end;

function THArrayAnsiStringFix.GetValue(Index: Cardinal): AnsiString;
var
  addr: Pointer;
  ind: integer;
begin
  // because we call memclr, byte with index FItemSize + 1 sets to zero. Further when we copied FItemSize bytes by memcpy then this zero byte terminates the string
  //memclr(FHelperBuf, FHelperBufSize);
  //memcpy(GetAddr(Index), FHelperBuf, FItemSize);
  //Result := AnsiString(FHelperBuf);
  //SetString(Result, buf, FItemSize);
  //SetLength(Result, FItemSize);

  SetLength(Result, FItemSize div sizeof(AnsiChar));
  addr := GetAddr(Index);
  ind := memfindbyte(addr, $00, FItemSize);
    if ind = -1 then begin
      memcpy(addr, PAnsiChar(Result), FItemSize) //FItemSize is in BYTES!
    end else begin
      Assert(ind >= 0);
      Assert(ind < FItemSize);
      memcpy(addr, @Result[1], ind*sizeof(AnsiChar));
      SetLength(Result, ind);
    end;
end;

procedure THArrayAnsiStringFix.SetValue(Index: Cardinal; Value: AnsiString);
begin
  memclr(FHelperBuf, FHelperBufSize); //TODO: for performance reasons we may delete this memclr, this will not take effect to functionality.
  memcpy(PAnsiChar(Value), FHelperBuf, Min(FItemSize, Cardinal(Length(Value)*sizeof(AnsiChar))));
  //SysUtils.StrPLCopy(FHelperBuf, Value, FItemSize div sizeof(AnsiChar));
  inherited Update(Index, FHelperBuf);
end;

function THArrayAnsiStringFix.IndexOf(Value: AnsiString): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayAnsiStringFix.IndexOfFrom(Value: AnsiString; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then Exit;
    for Result := Start to FCount - 1 do
      if self.Value[Result] = Value then Exit;
  Result := -1;
end;

procedure THArrayAnsiStringFix.SetItemSize(Size: Cardinal);
begin
  raise ENotSupportedException.Create(SWrongCallSetItemSize);
end;

{ THArrayStringFix }

//TODO: there is an optimization in THArrayAnsiStringFix, apply it to THArrayStringFix?
function THArrayStringFix.AddValue(Value: string): Cardinal;
var
  buf: Pointer;
  len: Cardinal;
begin
  buf := AllocMem(FItemSize {+ sizeof(Char)});
  memclr(buf, FItemSize {+ sizeof(Char)});
  try
    len := Min(FItemSize, Cardinal(Length(Value)*sizeof(Char)));
    //if len > 0 then
    memcpy(PChar(Value), buf, len);
    //StrPLCopy(buf, Value, FItemSize div sizeof(Char));
    Result := inherited Add(buf);
  finally
    FreeMem(buf);
  end;
end;

constructor THArrayStringFix.Create;
begin
  raise ENotSupportedException.Create(Format(SUseCreateSizeConsructor, ['THArrayStringFix']));
end;

// SizeOfItem - in characters, not bytes !!!!
// It is possible to create THArrayStringFix with size 0. needed for Oracle fields
constructor THArrayStringFix.CreateSize(SizeOfItem: Cardinal);
begin
  inherited Create;
  FItemSize := SizeOfItem * sizeof(Char);  // remember string is UNICODE and sizeof(Char) may be equal 2
end;

function THArrayStringFix.GetValue(Index: Cardinal): string;
var
  addr: Pointer;
  ind: integer;
begin
  //buf := AllocMem(FItemSize + sizeof(Char));
  //memclr(buf, FItemSize + sizeof(Char)); //TODO: we can avoid memclr, just set to zero two last bytes of buf
  try
    SetLength(Result, FItemSize div sizeof(Char));
    addr := GetAddr(Index);
    ind := memfindword(addr, $00, FItemSize div 2);
    if ind = -1 then begin
      memcpy(addr, PChar(Result), FItemSize) //FItemSize is in BYTES!
    end else begin
      Assert(ind >= 0);
      Assert(ind < FItemSize);
      memcpy(addr, @Result[1], ind*sizeof(Char));
      SetLength(Result, ind);
    end;
    //Result := PChar(buf);
  finally
    //FreeMem(buf);
  end;
end;

procedure THArrayStringFix.SetValue(Index: Cardinal; Value: string);
var
  buf: Pointer;
  len: Cardinal;
begin
  buf := AllocMem(FItemSize {+ sizeof(Char)});  // extra char is needed for StrPLCopy (for zero terminator)
  memclr(buf, FItemSize {+ sizeof(Char)}); // alt: memclr(buf + len, FItemSize - len);
  try
    len := Min(FItemSize, Length(Value)*sizeof(Char));
    //if len > 0 then
    memcpy(PChar(Value), buf, len);
    //StrPLCopy(buf, Value, FItemSize div sizeof(Char));
    inherited Update(Index, buf);
  finally
    FreeMem(buf);
  end;
end;

function THArrayStringFix.IndexOf(Value: string): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayStringFix.IndexOfFrom(Value: string; Start: Cardinal): Integer;
begin
  Result := -1;
  if Start >= FCount then Exit;
    for Result := Start to FCount - 1 do
      if self.Value[Result] = Value then Exit;
  Result := -1;
end;

procedure THArrayStringFix.SetItemSize(Size: Cardinal);
begin
  raise ENotSupportedException.Create(SWrongCallSetItemSize);
end;


{ THash }

constructor THash.Create;
begin
  FReadOnly := False;
  FAIndex := THArrayInteger.Create;
end;

destructor THash.Destroy;
begin
  if not FReadOnly then FAIndex.Free;
  inherited Destroy;
end;

procedure THash.Clear;
begin
  FAIndex.Clear;
end;

procedure THash.ClearMem;
begin
  FAIndex.ClearMem;
end;

function THash.GetCount: Cardinal;
begin
  Result := FAIndex.Count;
end;

function THash.GetKey(Index: Cardinal): Integer;
begin
  Result := FAIndex[Index];
end;

function THash.IfExist(Key: Integer): Boolean;
begin
  Result := FAIndex.IndexOf(Key) <> -1;
end;

 { THashExists }
constructor THashExists.Create;
begin
  inherited Create;
end;

destructor THashExists.Destroy;
begin
  inherited Destroy;
end;

procedure THashExists.SetValue(Key: Integer; Value: Boolean);
var r: Integer;
begin
  r := FAIndex.IndexOf(Key);
  if (r = -1) and Value then FAIndex.AddValue(Key);
  if (r <> -1) and (not Value) then FAIndex.Delete(Cardinal(r));
end;

procedure THashExists.Delete(Key: Integer);
var r: Integer;
begin
  r := FAIndex.IndexOf(Key);
  if r <> -1 then FAIndex.Delete(Cardinal(r));
end;

function THashExists.GetValue(Key: Integer): Boolean;
var r: Integer;
begin
  r := FAIndex.IndexOf(Key);
  Result := (r<>-1);
end;

 { THashBoolean }
constructor THashBoolean.Create;
begin
  inherited Create;
  FAValues := THArrayBoolean.Create;
end;

constructor THashBoolean.CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayBoolean);
begin
  FAIndex   := IndexHArray;
  FAValues  := ValueHArray;
  FReadOnly := True;
end;

destructor THashBoolean.Destroy;
begin
  if not FReadOnly then  FAValues.Free;
  inherited Destroy;
end;

procedure THashBoolean.SetValue(Key: Integer; Value: Boolean);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := Value;
    exit;
  end;

  if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound, [Key]));
  FAIndex.AddValue(Key);
  FAValues.AddValue(Value);
end;

function THashBoolean.GetValue(Key: Integer): Boolean;
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    Result := FAValues[Cardinal(n)];
  end else begin
    Result := False;
  end;
end;

procedure THashBoolean.Clear;
begin
  inherited Clear;
  FAValues.Clear;
end;

procedure THashBoolean.ClearMem;
begin
  inherited ClearMem;
  FAValues.ClearMem;
end;

procedure THashBoolean.Delete(Key: Integer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAIndex.Delete(Cardinal(n));
    FAValues.Delete(Cardinal(n));
  end;
end;

 { THashInteger }
constructor THashInteger.Create;
begin
  inherited Create;
  FAValues := THArrayInteger.Create;
end;

constructor THashInteger.CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayInteger);
begin
  FAIndex  := IndexHArray;
  FAValues := ValueHArray;
  FReadOnly:= True;
end;

destructor THashInteger.Destroy;
begin
  if not FReadOnly then  FAValues.Free;
  inherited Destroy;
end;

procedure THashInteger.SetValue(Key: Integer; Value: Integer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := Value;
    exit;
  end;

  if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound,[Key]));
  FAIndex.AddValue(Key);
  FAValues.AddValue(Value);
end;

function THashInteger.GetValue(Key: Integer): Integer;
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    Result := FAValues[Cardinal(n)];
  end else begin
    Result := 0;
  end;
end;

procedure THashInteger.Clear;
begin
  inherited Clear;
  FAValues.Clear;
end;

procedure THashInteger.ClearMem;
begin
  inherited ClearMem;
  FAValues.ClearMem;
end;

procedure THashInteger.Delete(Key: Integer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAIndex.Delete(Cardinal(n));
    FAValues.Delete(Cardinal(n));
  end;
end;

 { THashPointer }
constructor THashPointer.Create;
begin
  inherited Create;
  FAValues := THArrayPointer.Create;
end;

constructor THashPointer.CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayPointer);
begin
  FAIndex := IndexHArray;
  FAValues := ValueHArray;
  FReadOnly := True;
end;

destructor THashPointer.Destroy;
begin
  if not FReadOnly then  FAValues.Free;
  inherited Destroy;
end;

procedure THashPointer.SetValue(Key: Integer; Value: Pointer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := Value;
    exit;
  end;

  if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound, [Key]));
  FAIndex.AddValue(Key);
  FAValues.AddValue(Value);
end;

function THashPointer.GetValue(Key: Integer): Pointer;
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    Result := FAValues[Cardinal(n)];
  end else begin
    Result := nil;
  end;
end;

procedure THashPointer.Clear;
begin
  inherited Clear;
  FAValues.Clear;
end;

procedure THashPointer.ClearMem;
begin
  inherited ClearMem;
  FAValues.ClearMem;
end;

procedure THashPointer.Delete(Key: Integer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAIndex.Delete(Cardinal(n));
    FAValues.Delete(Cardinal(n));
  end;
end;

 { THashCurrency }
constructor THashCurrency.Create;
begin
  inherited Create;
  FAValues := THArrayCurrency.Create;
end;

constructor THashCurrency.CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayCurrency);
begin
  FAIndex := IndexHArray;
  FAValues := ValueHArray;
  FReadOnly := True;
end;

destructor THashCurrency.Destroy;
begin
  if not FReadOnly then FAValues.Free;
  inherited Destroy;
end;

procedure THashCurrency.SetValue(Key: Integer; Value: Currency);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := Value;
    exit;
  end;

  if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound, [Key]));
  FAIndex.AddValue(Key);
  FAValues.AddValue(Value);
end;

procedure THashCurrency.Inc(Key: Integer; Value: Currency);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := FAValues[Cardinal(n)] + Value;
  end else begin
    if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound, [Key]));
    SetValue(Key, Value);
  end;
end;

function THashCurrency.GetValue(Key: Integer): Currency;
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    Result := FAValues[Cardinal(n)];
  end else begin
    Result := 0;
  end;
end;

procedure THashCurrency.Clear;
begin
  inherited Clear;
  FAValues.Clear;
end;

procedure THashCurrency.ClearMem;
begin
  inherited ClearMem;
  FAValues.ClearMem;
end;

procedure THashCurrency.Delete(Key: Integer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAIndex.Delete(Cardinal(n));
    FAValues.Delete(Cardinal(n));
  end;
end;

 { THashDouble }
constructor THashDouble.Create;
begin
  inherited Create;
  FAValues := THArrayDouble.Create;
end;

constructor THashDouble.CreateFromHArrays(IndexHArray: THArrayInteger; ValueHArray: THArrayDouble);
begin
  FAIndex := IndexHArray;
  FAValues := ValueHArray;
  FReadOnly := True;
end;

destructor THashDouble.Destroy;
begin
  if not FReadOnly then FAValues.Free;
  inherited Destroy;
end;

procedure THashDouble.SetValue(Key: Integer; Value: Double);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := Value;
    exit;
  end;
  if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound, [Key]));
  FAIndex.AddValue(Key);
  FAValues.AddValue(Value);
end;

procedure THashDouble.Inc(Key: Integer; Value: Double);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAValues[Cardinal(n)] := FAValues[Cardinal(n)] + Value;
  end else begin
    if FReadOnly then raise ERangeError.Create(Format(SKeyNotFound, [Key]));
    SetValue(Key, Value);
  end;
end;

function THashDouble.GetValue(Key: Integer): Double;
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    Result := FAValues[Cardinal(n)];
  end else begin
    Result := 0;
  end;
end;

procedure THashDouble.Clear;
begin
  inherited Clear;
  FAValues.Clear;
end;

procedure THashDouble.ClearMem;
begin
  inherited ClearMem;
  FAValues.ClearMem;
end;

procedure THashDouble.Delete(Key: Integer);
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAIndex.Delete(Cardinal(n));
    FAValues.Delete(Cardinal(n));
  end;
end;

 { THashString }
constructor THashString.Create;
begin
  inherited Create;
  FAValues := TStringList.Create;
  FAllowEmptyStr := True;
end;

destructor THashString.Destroy;
begin
  FAValues.Free;
  inherited Destroy;
end;

procedure THashString.SetValue(Key: Integer; Value: string);
var
  n: Integer;
  n2: Cardinal;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    n2 := Cardinal(n);
    if not FAllowEmptyStr and (Value = '')
      then begin FAValues.Delete(n); FAIndex.Delete(n2); end
      else FAValues[n] := Value;
  end else
    if FAllowEmptyStr or (Value<>'') then begin
      FAIndex.AddValue(Key);
      FAValues.Add(Value);
    end;
end;

function THashString.GetValue(Key: Integer): string;
var n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    Result := FAValues[n];
  end else begin
    Result := '';
  end;
end;

procedure THashString.Clear;
begin
  inherited Clear;
  FAValues.Clear;
end;

procedure THashString.ClearMem;
begin
  inherited ClearMem;
  FAValues.Clear;
end;

procedure THashString.Delete(Key: Integer);
var
  n: Integer;
begin
  n := FAIndex.IndexOf(Key);
  if n >= 0 then begin
    FAIndex.Delete(Cardinal(n));
    FAValues.Delete(n);
  end;
end;

 { THash2 }
constructor THash2.Create;
begin
  MainListIndex := THArrayInteger.Create;
  MainListValue := THArrayPointer.Create;
end;

destructor THash2.Destroy;
begin
  Clear;
  MainListValue.Free;
  MainListIndex.Free;
  inherited Destroy;
end;

{function THash2.GetKey(Index:Integer):Integer;
begin
 Result:=MainListIndex[Index];
end;}

procedure THash2.ClearMem;
begin
  Clear;
  MainListValue.ClearMem;
  MainListIndex.ClearMem;
end;

function THash2.GetChildHash(Key: Integer): THash;
var n: Integer;
begin
  n := MainListIndex.IndexOf(Key);
  if n = -1
    then Result := nil
    else Result := MainListValue[Cardinal(n)];
end;

procedure THash2.Delete(MainIndex, Index: Integer);
var
  n: Integer;
  n2: Cardinal;
  arr: THashBoolean;
begin
  n := MainListIndex.IndexOf(MainIndex);
  if n = -1 then Exit;

  n2 := Cardinal(n);
  arr := MainListValue[n2];
  (arr as THash).Delete(Index);
  if arr.Count = 0 then begin
    arr.Free;
    MainListValue.Delete(n2);
    MainListIndex.Delete(n2);
  end;
end;

{function THash2.ExistMainHash(MainIndex:Integer):boolean;
var n:Integer;
begin
 n:=MainListIndex.IndexOf(MainIndex);
 Result:=n<>-1;
end;}

 { THash2Exists }
 procedure THash2Exists.Clear;
var i:  Cardinal;
begin
  for i := 1 to MainListValue.Count do begin
    THashExists(MainListValue[i - 1]).Free;
  end;
  MainListValue.Clear;
  MainListIndex.Clear;
end;

procedure THash2Exists.SetValue(MainIndex, Index: Integer; Value: Boolean);
var arr: THashExists;
begin
  arr := THashExists(GetChildHash(MainIndex));
  if arr = nil then begin
    arr := THashExists.Create;
    MainListIndex.AddValue(MainIndex);
    MainListValue.AddValue(arr);
  end;
  arr[Index] := Value;
end;

function THash2Exists.GetValue(MainIndex, Index: Integer): Boolean;
var arr: THashExists;
begin
  Result := False;
  arr := THashExists(GetChildHash(MainIndex));
  if arr = nil then exit;
  Result := arr[Index];
end;

function THash2Exists.CreateMainHash(MainIndex: Integer): THashExists;
var Co: Cardinal;
    n: Integer;
    arr: THashExists;
begin
  Result := nil;
  n := MainListIndex.IndexOf(MainIndex);
  if n = -1 then Exit;

  Result := THashExists.Create;
  arr := MainListValue[Cardinal(n)];
  Co := arr.Count;
  if Co > 0 then begin
    Result.FAIndex.SetCapacity(Co);
    Result.FAIndex.FCount := Co;
    memcpy(arr.FAIndex.FValues, Result.FAIndex.FValues, Co*Result.FAIndex.FItemSize);
  end else begin
    Result.Free;
    Result := nil;
  end;
end;

function THash2Exists.CreateHash(Index: Integer): THashExists;
var i: Cardinal;
begin
  Result := THashExists.Create;
  for i := 1 to MainListIndex.Count do begin
    if THashExists(MainListValue[i - 1])[Index] then Result.FAIndex.AddValue(MainListIndex[i - 1]);
  end;

  if Result.Count = 0 then begin
    Result.Free;
    Result := nil;
  end;
end;

 { THash2Currency }
procedure THash2Currency.Clear;
var i: Cardinal;
begin
  for i := 1 to MainListValue.Count do begin
    THashCurrency(MainListValue[i - 1]).Free;
  end;
  MainListValue.Clear;
  MainListIndex.Clear;
end;

procedure THash2Currency.SetValue(MainIndex, Index: Integer; Value: Currency);
var arr: THashCurrency;
begin
  arr := THashCurrency(GetChildHash(MainIndex));
  if arr = nil then begin
    arr := THashCurrency.Create;
    MainListIndex.AddValue(MainIndex);
    MainListValue.AddValue(arr);
  end;
  arr[Index] := Value;
end;

procedure THash2Currency.Inc(MainIndex, Index: Integer; Value: Currency);
var c: Currency;
begin
  c := GetValue(MainIndex, Index);
  SetValue(MainIndex, Index, Value + c);
end;

function THash2Currency.GetValue(MainIndex, Index: Integer): Currency;
var arr: THashCurrency;
begin
  Result := 0;
  arr := THashCurrency(GetChildHash(MainIndex));
  if arr = nil then exit;
  Result := arr[Index];
end;

function THash2Currency.CreateMainHash(MainIndex: Integer): THashCurrency;
var arr: THashCurrency;
    Co: Cardinal;
    n: Integer;
begin
  Result := nil;
  n := MainListIndex.IndexOf(MainIndex);
  if n = -1 then Exit;

  Result := THashCurrency.Create;
  arr := MainListValue[Cardinal(n)];
  Co := arr.Count;
  if Co > 0 then begin
    Result.FAIndex.SetCapacity(Co);
    Result.FAIndex.FCount := Co;
    Result.FAValues.SetCapacity(Co);
    Result.FAValues.FCount := Co;
    memcpy(arr.FAIndex.FValues,Result.FAIndex.FValues, Co*Result.FAIndex.FItemSize);
    memcpy(arr.FAValues.FValues,Result.FAValues.FValues, Co*Result.FAValues.FItemSize);
  end else begin
    Result.Free;
    Result := nil;
  end;
end;

function THash2Currency.CreateHash(Index: Integer): THashCurrency;
var i: Cardinal;
begin
  Result := THashCurrency.Create;
  for i := 1 to MainListIndex.Count do begin
    if THashCurrency(MainListValue[i - 1]).FAIndex.IndexOf(Index) <> -1 then begin
      Result.FAIndex.AddValue(i - 1);
      Result.FAValues.AddValue(THashCurrency(MainListValue[i - 1])[Index]);
    end;
  end;

  if Result.Count = 0 then begin
    Result.Free;
    Result := nil;
  end;
end;

 { THash2Integer }
procedure THash2Integer.Clear;
var i: Cardinal;
begin
  for i := 1 to MainListValue.Count do begin
    THashInteger(MainListValue[i - 1]).Free;
  end;
  MainListValue.Clear;
  MainListIndex.Clear;
end;

procedure THash2Integer.SetValue(MainIndex, Index: Integer; Value: Integer);
var arr: THashInteger;
begin
  arr := THashInteger(GetChildHash(MainIndex));
  if arr = nil then begin
    arr := THashInteger.Create;
    MainListIndex.AddValue(MainIndex);
    MainListValue.AddValue(arr);
  end;
  arr[Index] := Value;
end;

function THash2Integer.GetValue(MainIndex, Index: Integer): Integer;
var arr: THashInteger;
begin
  Result := 0;
  arr := THashInteger(GetChildHash(MainIndex));
  if arr = nil then exit;
  Result := arr[Index];
end;

function THash2Integer.CreateMainHash(MainIndex: Integer): THashInteger;
var arr: THashInteger;
    Co: Cardinal;
    n: Integer;
begin
  Result := nil;
  n := MainListIndex.IndexOf(MainIndex);
  if n = -1 then exit;
  Result := THashInteger.Create;
  arr := MainListValue[Cardinal(n)];
  Co := arr.Count;
  if Co > 0 then begin
    Result.FAIndex.SetCapacity(Co);
    Result.FAIndex.FCount := Co;
    Result.FAValues.SetCapacity(Co);
    Result.FAValues.FCount := Co;
    memcpy(arr.FAIndex.FValues,  Result.FAIndex.FValues,  Co*Result.FAIndex.FItemSize);
    memcpy(arr.FAValues.FValues, Result.FAValues.FValues, Co*Result.FAValues.FItemSize);
  end else begin
    Result.Free;
    Result := nil;
 end;
end;

function THash2Integer.CreateHash(Index: Integer): THashInteger;
var i: Cardinal;
begin
  Result := THashInteger.Create;
  for i := 1 to MainListIndex.Count do begin
    if THashInteger(MainListValue[i - 1]).FAIndex.IndexOf(Index) <> -1 then begin
      Result.FAIndex.AddValue(i - 1);
      Result.FAValues.AddValue(THashInteger(MainListValue[i - 1])[Index]);
    end;
  end;

  if Result.Count = 0 then begin
    Result.Free;
    Result := nil;
  end;
end;

 { THash2String }
procedure THash2String.Clear;
var i: Cardinal;
begin
  for i := 1 to MainListValue.Count do begin
    THashString(MainListValue[i - 1]).Free;
  end;
  MainListValue.Clear;
  MainListIndex.Clear;
end;

procedure THash2String.SetValue(MainIndex, Index: Integer; Value: string);
var arr: THashString;
begin
  arr := THashString(GetChildHash(MainIndex));
  if arr = nil then begin
    arr := THashString.Create;
    MainListIndex.AddValue(MainIndex);
    MainListValue.AddValue(arr);
  end;
  arr[Index] := Value;
end;

function THash2String.GetValue(MainIndex, Index: Integer): string;
var arr: THashString;
begin
  Result := '';
  arr := THashString(GetChildHash(MainIndex));
  if arr = nil then exit;
  Result := arr[Index];
end;

function THash2String.CreateMainHash(MainIndex: Integer): THashString;
var arr: THashString;
    Co, i: Cardinal;
    n: Integer;
begin
  Result := nil;
  n := MainListIndex.IndexOf(MainIndex);
  if n = -1 then exit;
  Result := THashString.Create;
  arr := MainListValue[Cardinal(n)];
  Co := arr.Count;
  if Co > 0 then begin
    Result.FAIndex.SetCapacity(Co);
    for i := 1 to arr.Count do begin
      Result[arr.Keys[i - 1]] := arr[arr.Keys[i - 1]];
    end;
  end else begin
    Result.Free;
    Result := nil;
  end;
end;

function THash2String.CreateHash(Index: Integer): THashString;
var i: Cardinal;
begin
  Result := THashString.Create;
  for i := 1 to MainListIndex.Count do begin
    if THashString(MainListValue[i - 1]).FAIndex.IndexOf(Index) <> -1 then begin
      Result.FAIndex.AddValue(i - 1);
      Result.FAValues.Add(THashString(MainListValue[i - 1])[Index]);
    end;
  end;

  if Result.Count = 0 then begin
    Result.Free;
    Result := nil;
  end;
end;

{ THArrayString - stores pointers to zero terminated strings}

function THArrayString.Add(pValue: Pointer): Cardinal;
//var pStr: PChar;
begin
// pStr := DublicateStr(pValue);
  Result := inherited Add(pValue{pStr}); // Add calls Update which in turn calls DuplicateStr.
end;

function THArrayString.AddValue(Value: string): Cardinal;
var pStr: PChar;
begin
  pStr := DublicateStr(PChar(Value));
  Result := inherited Add(@pStr);
end;

procedure THArrayString.Clear;
begin
  ClearStrings;
  inherited Clear;
end;

procedure THArrayString.ClearMem;
begin
  ClearStrings;
  inherited ClearMem;
end;

procedure THArrayString.ClearStrings;
var
  i: Cardinal;
  pStr: PChar;
begin
  for i := 1 to Count do begin
   Get(i - 1, @pStr);
   StrDispose(pStr);
  end;
end;

procedure THArrayString.Delete(num: Cardinal);
var pStr: PChar;
begin
  Get(num, @pStr);
  StrDispose(pStr);
  inherited Delete(num);
end;

destructor THArrayString.Destroy;
begin
  ClearStrings;
  inherited Destroy;
end;

function THArrayString.DublicateStr(pValue: Pointer): PChar;
var len: Cardinal;
begin
  if pValue <> nil then begin
    len := StrLen(PChar(pValue)) + 1; // extra symbol for null-terminate
    Result := StrAlloc(len*sizeof(Char));
    memcpy(pValue, Result, len*sizeof(Char)); // terminating zero also copied here
  end else
    Result := nil;
end;

function THArrayString.GetValue(Index: Cardinal): string;
begin
  Result := PChar(PPointer(GetAddr(Index))^);
end;

function THArrayString.IndexOf(Value: string): Integer;
begin
  Result := IndexOfFrom(Value, 0);
end;

function THArrayString.IndexOfFrom(Value: string; Start: Integer): Integer;
begin
  Result := -1; //TODO: implement this method
end;

function THArrayString.Insert(num: Cardinal; Value: string): Cardinal;
begin
  Result := Insert(num, Pointer(PChar(Value)));
end;

procedure THArrayString.Update(num: Cardinal; pValue: Pointer);
var pStr : PChar;
begin
  Get(num, @pStr);
  StrDispose(pStr);
  pStr := DublicateStr(pValue);
  inherited Update(num, @pStr);
end;

{
function THArrayString.Insert(num: Cardinal; pValue: Pointer): Cardinal;
var pStr: PChar;
begin
  pStr := DublicateStr(pValue);
  Result := inherited Insert(num, pStr);
end;
 }
procedure THArrayString.LoadFromStream(s: TStream);

  function LoadString(Stream: TStream): PChar;
  var len: Cardinal;
  begin
    Stream.Read(len, sizeof(len));
    Result := StrAlloc(len div sizeof(Char)); // size in characters here
    Stream.Read(Result^, len);
  end;

var
  c, i: Integer;
  PStr: PChar;
begin
  s.Read(c, sizeof(Integer));
  for i := 1 to c do begin
    PStr := LoadString(s);
    inherited Add(@PStr);
  end;
end;

procedure THArrayString.SaveToStream(s: TStream);

  procedure SaveString(Stream: TStream; pValue: PChar);
  var len: Cardinal;
  begin
    len := (StrLen(pValue) + 1) * sizeof(Char); // len in bytes + one extra symbol (2 bytes) for terminating zero
    Stream.Write(len, sizeof(len));
    Stream.Write(pValue^, len);
  end;

var
  i: Cardinal;
  pStr: PChar;
begin
  i := Count;
  s.Write(i, sizeof(i)); // number of elements
  for i := 1 to Count do begin
    Get(i - 1, @pStr);
    SaveString(s, pStr);
  end;
end;

procedure THArrayString.SetValue(Index: Cardinal; Value: string);
begin
  Update(Index, PChar(Value));
end;


end.