{
pascalx.lang.table — таблицы контрольных сумм с ключами типа RefCountInterface,
AnsiString и UnicodeString.
Copyright © 2021, 2026 Малик Разработчик
Это свободная программа: вы можете перераспространять её и/или изменять
её на условиях Меньшей Стандартной общественной лицензии GNU в том виде,
в каком она была опубликована Фондом свободного программного обеспечения;
либо версии 3 лицензии, либо (по вашему выбору) любой более поздней версии.
Эта программа распространяется в надежде, что она будет полезной,
но БЕЗО ВСЯКИХ ГАРАНТИЙ; даже без неявной гарантии ТОВАРНОГО ВИДА
или ПРИГОДНОСТИ ДЛЯ ОПРЕДЕЛЁННЫХ ЦЕЛЕЙ. Подробнее см. в Меньшей Стандартной
общественной лицензии GNU.
Вы должны были получить копию Меньшей Стандартной общественной лицензии GNU
вместе с этой программой. Если это не так, см.
<https://www.gnu.org/licenses/>.
}
unit pascalx.lang.table;
{$MODE OBJFPC}
interface
{%region} uses
pascalx.lang;
{%endregion}
{$TYPEINFO ON}
{$CALLING REGISTER}
const UNIT_NAME = 'pascalx.lang.table';
{%region} type
generic KeyValueEntry<KeyType: RefCountInterface; ValueType> = class sealed(&Object) { KeyType обязательно должен быть протоколом (interface)! }
private
fldIndex: int;
fldHash: long;
fldKey: KeyType;
fldValue: ValueType;
fldNext: KeyValueEntry;
public
constructor create(index: int; hash: long; key: KeyType; const value: ValueType; next: KeyValueEntry);
property index: int read fldIndex;
property hash: long read fldHash;
property key: KeyType read fldKey;
property value: ValueType read fldValue write fldValue;
property next: KeyValueEntry read fldNext write fldNext;
end;
generic KeyValueTable<KeyType: RefCountInterface; ValueType> = class abstract(&Object) { KeyType обязательно должен быть протоколом (interface)! }
private type
TableEntry = specialize KeyValueEntry<KeyType, ValueType>;
TableEntry_Array1d = specialize DynamicArray<TableEntry>;
KeyType_Array1d = specialize DynamicArray<KeyType>;
private
fldLength: int;
fldTable: TableEntry_Array1d;
fldKeys: KeyType_Array1d;
procedure rehash();
procedure put(key: KeyType; const value: ValueType);
procedure remove(key: KeyType);
protected
procedure setValue(key: KeyType; const value: ValueType);
function getLength(): int; virtual;
function contains(key: KeyType): boolean;
function getValue(key: KeyType): ValueType;
function getKey(index: int): KeyType;
public
constructor create();
destructor destroy; override;
procedure clear(); virtual;
property length: int read getLength;
end;
generic Hashtable<KeyType: RefCountInterface; ValueType> = class(specialize KeyValueTable<KeyType, ValueType>) { KeyType обязательно должен быть протоколом (interface)! }
protected
procedure setValue(key: KeyType; const value: ValueType); virtual;
function getValue(key: KeyType): ValueType; virtual;
public
function contains(key: KeyType): boolean; virtual;
function keyAt(index: int): KeyType; virtual;
property value[key: KeyType]: ValueType read getValue write setValue; default;
end;
generic HashtableOfAnsiString<ValueType> = class(specialize KeyValueTable<Value, ValueType>)
protected
procedure setValue(const key: AnsiString; const value: ValueType); virtual;
function getValue(const key: AnsiString): ValueType; virtual;
public
function contains(const key: AnsiString): boolean; virtual;
function keyAt(index: int): AnsiString; virtual;
property value[const key: AnsiString]: ValueType read getValue write setValue; default;
end;
generic HashtableOfUnicodeString<ValueType> = class(specialize KeyValueTable<Value, ValueType>)
protected
procedure setValue(const key: UnicodeString; const value: ValueType); virtual;
function getValue(const key: UnicodeString): ValueType; virtual;
public
function contains(const key: UnicodeString): boolean; virtual;
function keyAt(index: int): UnicodeString; virtual;
property value[const key: UnicodeString]: ValueType read getValue write setValue; default;
end;
{%endregion}
implementation
{$CALLING REGISTER}
{%region KeyValueEntry }
constructor KeyValueEntry.create(index: int; hash: long; key: KeyType; const value: ValueType; next: KeyValueEntry);
begin
inherited create();
fldIndex := index;
fldHash := hash;
fldKey := key;
fldValue := value;
fldNext := next;
end;
{%endregion}
{%region KeyValueTable }
procedure KeyValueTable.rehash();
var
oldCap: int;
oldIdx: int;
newCap: int;
newIdx: int;
oldEntry: TableEntry;
newEntry: TableEntry;
oldTable: TableEntry_Array1d;
newTable: TableEntry_Array1d;
newArray: KeyType_Array1d;
begin
oldTable := fldTable;
oldCap := system.length(oldTable);
newCap := (oldCap shl 1) or 1;
if newCap < 0 then begin
raise BufferTooLargeError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.buffer-too-large'));
end;
newTable := TableEntry_Array1d(&Array.newTObject1d(newCap));
for oldIdx := oldCap - 1 downto 0 do begin
oldEntry := oldTable[oldIdx];
while oldEntry <> nil do begin
newIdx := int((oldEntry.hash and CoLong.MAX_VALUE) mod newCap);
newEntry := oldEntry;
oldEntry := oldEntry.next;
newEntry.next := newTable[newIdx];
newTable[newIdx] := newEntry;
end;
end;
newArray := KeyType_Array1d(&Array.newIUnknown1d(newCap));
&Array.copyUnknowns(fldKeys, 0, newArray, 0, oldCap);
fldTable := newTable;
fldKeys := newArray;
end;
procedure KeyValueTable.put(key: KeyType; const value: ValueType);
var
idx: int;
len: int;
cap: int;
hash: long;
kobj: TObject;
entry: TableEntry;
table: TableEntry_Array1d;
begin
table := fldTable;
kobj := key as TObject;
hash := key.getHashCode();
cap := system.length(table);
idx := int((hash and CoLong.MAX_VALUE) mod cap);
entry := table[idx];
while entry <> nil do begin
if (entry.hash = hash) and entry.key.equals(kobj) then begin
entry.value := value;
exit;
end;
entry := entry.next;
end;
len := fldLength;
if len >= cap then begin
rehash();
table := fldTable;
idx := int((hash and CoLong.MAX_VALUE) mod system.length(table));
end;
fldKeys[len] := key;
table[idx] := TableEntry.create(len, hash, key, value, table[idx]);
fldLength := len + 1;
end;
procedure KeyValueTable.remove(key: KeyType);
var
idx: int;
len: int;
hash: long;
kobj: TObject;
prev: TableEntry;
entry: TableEntry;
table: TableEntry_Array1d;
keys: KeyType_Array1d;
begin
table := fldTable;
kobj := key as TObject;
hash := key.getHashCode();
idx := int((hash and CoLong.MAX_VALUE) mod system.length(table));
prev := nil;
entry := table[idx];
while entry <> nil do begin
if (entry.hash = hash) and entry.key.equals(kobj) then begin
if prev <> nil then begin
prev.next := entry.next;
end else begin
table[idx] := entry.next;
end;
idx := entry.index;
keys := fldKeys;
len := fldLength - 1;
&Array.copyUnknowns(keys, idx + 1, keys, idx, len - idx);
keys[len] := nil;
fldLength := len;
entry.free();
exit;
end;
prev := entry;
entry := entry.next;
end;
end;
procedure KeyValueTable.setValue(key: KeyType; const value: ValueType);
begin
if key = nil then begin
raise NullPointerException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer.argument'), [ CoAnsiString.create('key') ]));
end;
if value = default(ValueType) then begin
remove(key);
exit;
end;
put(key, value);
end;
function KeyValueTable.getLength(): int;
begin
result := fldLength;
end;
function KeyValueTable.contains(key: KeyType): boolean;
var
hash: long;
kobj: TObject;
entry: TableEntry;
table: TableEntry_Array1d;
begin
if key = nil then begin
result := false;
exit;
end;
table := fldTable;
kobj := key as TObject;
hash := key.getHashCode();
entry := table[int((hash and CoLong.MAX_VALUE) mod system.length(table))];
while entry <> nil do begin
if (entry.hash = hash) and entry.key.equals(kobj) then begin
result := true;
exit;
end;
entry := entry.next;
end;
result := false;
end;
function KeyValueTable.getValue(key: KeyType): ValueType;
var
hash: long;
kobj: TObject;
entry: TableEntry;
table: TableEntry_Array1d;
begin
if key = nil then begin
raise NullPointerException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer.argument'), [ CoAnsiString.create('key') ]));
end;
table := fldTable;
kobj := key as TObject;
hash := key.getHashCode();
entry := table[int((hash and CoLong.MAX_VALUE) mod system.length(table))];
while entry <> nil do begin
if (entry.hash = hash) and entry.key.equals(kobj) then begin
result := entry.value;
exit;
end;
entry := entry.next;
end;
result := default(ValueType);
end;
function KeyValueTable.getKey(index: int): KeyType;
begin
if (index < 0) or (index >= fldLength) then begin
raise IndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.index'));
end;
result := fldKeys[index];
end;
constructor KeyValueTable.create();
begin
inherited create();
fldTable := TableEntry_Array1d(&Array.newTObject1d($0f));
fldKeys := KeyType_Array1d(&Array.newIUnknown1d($0f));
end;
destructor KeyValueTable.destroy;
var
idx: int;
next: TableEntry;
entry: TableEntry;
table: TableEntry_Array1d;
begin
table := fldTable;
for idx := system.length(table) - 1 downto 0 do begin
entry := table[idx];
while entry <> nil do begin
next := entry.next;
entry.free();
entry := next;
end;
end;
inherited destroy;
end;
procedure KeyValueTable.clear();
var
idx: int;
next: TableEntry;
entry: TableEntry;
table: TableEntry_Array1d;
begin
table := fldTable;
for idx := system.length(table) - 1 downto 0 do begin
entry := table[idx];
while entry <> nil do begin
next := entry.next;
entry.free();
entry := next;
end;
table[idx] := nil;
end;
&Array.fillUnknowns(fldKeys, 0, fldLength, nil);
fldLength := 0;
end;
{%endregion}
{%region Hashtable }
procedure Hashtable.setValue(key: KeyType; const value: ValueType);
begin
inherited setValue(key, value);
end;
function Hashtable.getValue(key: KeyType): ValueType;
begin
result := inherited getValue(key);
end;
function Hashtable.contains(key: KeyType): boolean;
begin
result := inherited contains(key);
end;
function Hashtable.keyAt(index: int): KeyType;
begin
result := inherited getKey(index);
end;
{%endregion}
{%region HashtableOfAnsiString }
procedure HashtableOfAnsiString.setValue(const key: AnsiString; const value: ValueType);
begin
inherited setValue(CoAnsiString.create(key), value);
end;
function HashtableOfAnsiString.getValue(const key: AnsiString): ValueType;
begin
result := inherited getValue(CoAnsiString.create(key));
end;
function HashtableOfAnsiString.contains(const key: AnsiString): boolean;
begin
result := inherited contains(CoAnsiString.create(key));
end;
function HashtableOfAnsiString.keyAt(index: int): AnsiString;
begin
result := inherited getKey(index).asAnsiString();
end;
{%endregion}
{%region HashtableOfUnicodeString }
procedure HashtableOfUnicodeString.setValue(const key: UnicodeString; const value: ValueType);
begin
inherited setValue(CoUnicodeString.create(key), value);
end;
function HashtableOfUnicodeString.getValue(const key: UnicodeString): ValueType;
begin
result := inherited getValue(CoUnicodeString.create(key));
end;
function HashtableOfUnicodeString.contains(const key: UnicodeString): boolean;
begin
result := inherited contains(CoUnicodeString.create(key));
end;
function HashtableOfUnicodeString.keyAt(index: int): UnicodeString;
begin
result := inherited getKey(index).asUnicodeString();
end;
{%endregion}
end.
