mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-07 08:48:08 +02:00
Fix for Mantis #27206. *Finally* add Maciej Izak's contribution of the Delphi compatible generic collections.
Two small changes were done: * Generics.Defaults.pas does not require the Contnrs unit (it wasn't used anyway and thus the units can be added as rtl-generics instead of fcl-generics) * the example files were changed to lowercase filenames git-svn-id: trunk@34229 -
This commit is contained in:
svenbarth
parent
7dadd44ba7
commit
3596809ab4
29
.gitattributes
vendored
29
.gitattributes
vendored
@ -7091,6 +7091,35 @@ packages/rtl-extra/src/win/winsock.pp svneol=native#text/plain
|
||||
packages/rtl-extra/src/win/winsock2.pp svneol=native#text/plain
|
||||
packages/rtl-extra/src/wince/winsock.pp svneol=native#text/plain
|
||||
packages/rtl-extra/src/wince/winsock2.pp svneol=native#text/plain
|
||||
packages/rtl-generics/Makefile svneol=native#text/plain
|
||||
packages/rtl-generics/Makefile.fpc svneol=native#text/plain
|
||||
packages/rtl-generics/examples/tarraydouble/tarrayprojectdouble.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/tarraydouble/tarrayprojectdouble.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/tarraysingle/tarrayprojectsingle.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/tarraysingle/tarrayprojectsingle.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/tcomparer/tcomparerproject.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/tcomparer/tcomparerproject.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/thashmap/thashmapproject.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/thashmap/thashmapproject.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/thashmapcaseinsensitive/thashmapcaseinsensitive.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/thashmapcaseinsensitive/thashmapcaseinsensitive.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/thashmapextendedequalitycomparer/thashmapextendedequalitycomparer.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/thashmapextendedequalitycomparer/thashmapextendedequalitycomparer.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/tobjectlist/tobjectlistproject.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/tobjectlist/tobjectlistproject.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/tqueue/tqueueproject.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/tqueue/tqueueproject.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/examples/tstack/tstackproject.lpi svneol=native#text/xml
|
||||
packages/rtl-generics/examples/tstack/tstackproject.lpr svneol=native#text/pascal
|
||||
packages/rtl-generics/fpmake.pp svneol=native#text/pascal
|
||||
packages/rtl-generics/src/generics.collections.pas svneol=native#text/pascal
|
||||
packages/rtl-generics/src/generics.defaults.pas svneol=native#text/pascal
|
||||
packages/rtl-generics/src/generics.hashes.pas svneol=native#text/pascal
|
||||
packages/rtl-generics/src/generics.helpers.pas svneol=native#text/pascal
|
||||
packages/rtl-generics/src/generics.memoryexpanders.pas svneol=native#text/pascal
|
||||
packages/rtl-generics/src/generics.strings.pas svneol=native#text/pascal
|
||||
packages/rtl-generics/src/inc/generics.dictionaries.inc svneol=native#text/pascal
|
||||
packages/rtl-generics/src/inc/generics.dictionariesh.inc svneol=native#text/pascal
|
||||
packages/rtl-objpas/Makefile svneol=native#text/plain
|
||||
packages/rtl-objpas/Makefile.fpc svneol=native#text/plain
|
||||
packages/rtl-objpas/Makefile.fpc.fpcmake svneol=native#text/plain
|
||||
|
||||
@ -104,6 +104,7 @@
|
||||
add_rexx(ADirectory+IncludeTrailingPathDelimiter('rexx'));
|
||||
add_rtl_console(ADirectory+IncludeTrailingPathDelimiter('rtl-console'));
|
||||
add_rtl_extra(ADirectory+IncludeTrailingPathDelimiter('rtl-extra'));
|
||||
add_rtl_generics(ADirectory+IncludeTrailingPathDelimiter('rtl-generics'));
|
||||
add_rtl_objpas(ADirectory+IncludeTrailingPathDelimiter('rtl-objpas'));
|
||||
add_rtl_unicode(ADirectory+IncludeTrailingPathDelimiter('rtl-unicode'));
|
||||
add_sdl(ADirectory+IncludeTrailingPathDelimiter('sdl'));
|
||||
|
||||
@ -605,6 +605,8 @@ end;
|
||||
|
||||
{$include rtl-extra/fpmake.pp}
|
||||
|
||||
{$include rtl-generics/fpmake.pp}
|
||||
|
||||
{$include rtl-objpas/fpmake.pp}
|
||||
|
||||
{$include rtl-unicode/fpmake.pp}
|
||||
|
||||
2486
packages/rtl-generics/Makefile
Normal file
2486
packages/rtl-generics/Makefile
Normal file
File diff suppressed because it is too large
Load Diff
102
packages/rtl-generics/Makefile.fpc
Normal file
102
packages/rtl-generics/Makefile.fpc
Normal file
@ -0,0 +1,102 @@
|
||||
#
|
||||
# Makefile.fpc for running fpmake
|
||||
#
|
||||
|
||||
[package]
|
||||
name=googleapi
|
||||
version=3.1.1
|
||||
|
||||
[require]
|
||||
packages=rtl fpmkunit
|
||||
|
||||
[install]
|
||||
fpcpackage=y
|
||||
|
||||
[default]
|
||||
fpcdir=../..
|
||||
|
||||
[prerules]
|
||||
FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
|
||||
ifdef OS_TARGET
|
||||
FPC_TARGETOPT+=--os=$(OS_TARGET)
|
||||
endif
|
||||
ifdef CPU_TARGET
|
||||
FPC_TARGETOPT+=--cpu=$(CPU_TARGET)
|
||||
endif
|
||||
LOCALFPMAKE=./fpmake$(SRCEXEEXT)
|
||||
|
||||
[rules]
|
||||
# Do not pass the Makefile's unit and binary target locations. Fpmake uses it's own.
|
||||
override FPCOPT:=$(filter-out -FU%,$(FPCOPT))
|
||||
override FPCOPT:=$(filter-out -FE%,$(FPCOPT))
|
||||
# Do not pass the package-unitdirectories. Fpmake adds those and this way they don't apear in the .fpm
|
||||
override FPCOPT:=$(filter-out $(addprefix -Fu,$(COMPILER_UNITDIR)),$(FPCOPT))# Compose general fpmake-parameters
|
||||
# Compose general fpmake-parameters
|
||||
ifdef FPMAKEOPT
|
||||
FPMAKE_OPT+=$(FPMAKEOPT)
|
||||
endif
|
||||
FPMAKE_OPT+=--localunitdir=../..
|
||||
FPMAKE_OPT+=--globalunitdir=..
|
||||
FPMAKE_OPT+=$(FPC_TARGETOPT)
|
||||
FPMAKE_OPT+=$(addprefix -o ,$(FPCOPT))
|
||||
FPMAKE_OPT+=--compiler=$(FPC)
|
||||
FPMAKE_OPT+=-bu
|
||||
.NOTPARALLEL:
|
||||
|
||||
fpmake$(SRCEXEEXT): fpmake.pp
|
||||
$(FPCFPMAKE) fpmake.pp $(FPMAKE_SKIP_CONFIG) $(addprefix -Fu,$(COMPILER_FPMAKE_UNITDIR)) $(FPCMAKEOPT) $(OPT)
|
||||
all: fpmake$(SRCEXEEXT)
|
||||
$(LOCALFPMAKE) compile $(FPMAKE_OPT)
|
||||
smart: fpmake$(SRCEXEEXT)
|
||||
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -XX -o -CX
|
||||
release: fpmake$(SRCEXEEXT)
|
||||
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dRELEASE
|
||||
debug: fpmake$(SRCEXEEXT)
|
||||
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dDEBUG
|
||||
# If no fpmake exists and (dist)clean is called, do not try to build fpmake, it will
|
||||
# most often fail because the dependencies are cleared.
|
||||
# In case of a clean, simply do nothing
|
||||
ifeq ($(FPMAKE_BIN_CLEAN),)
|
||||
clean:
|
||||
else
|
||||
clean:
|
||||
$(FPMAKE_BIN_CLEAN) clean $(FPMAKE_OPT)
|
||||
endif
|
||||
# In case of a distclean, perform an 'old'-style distclean. This to avoid problems
|
||||
# when the package is compiled using fpcmake prior to running this clean using fpmake
|
||||
ifeq ($(FPMAKE_BIN_CLEAN),)
|
||||
distclean: $(addsuffix _distclean,$(TARGET_DIRS)) fpc_cleanall
|
||||
else
|
||||
distclean:
|
||||
ifdef inUnix
|
||||
{ $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT); if [ $$? != "0" ]; then { echo Something wrong with fpmake exectable. Remove the executable and call make recursively to recover.; $(DEL) $(FPMAKE_BIN_CLEAN); $(MAKE) fpc_cleanall; }; fi; }
|
||||
else
|
||||
$(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT)
|
||||
endif
|
||||
-$(DEL) $(LOCALFPMAKE)
|
||||
endif
|
||||
cleanall: distclean
|
||||
install: fpmake$(SRCEXEEXT)
|
||||
ifdef UNIXHier
|
||||
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR)
|
||||
else
|
||||
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR)
|
||||
endif
|
||||
# distinstall also installs the example-sources and omits the location of the source-
|
||||
# files from the fpunits.cfg files.
|
||||
distinstall: fpmake$(SRCEXEEXT)
|
||||
ifdef UNIXHier
|
||||
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
|
||||
else
|
||||
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
|
||||
endif
|
||||
zipinstall: fpmake$(SRCEXEEXT)
|
||||
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX)
|
||||
zipdistinstall: fpmake$(SRCEXEEXT)
|
||||
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) -ie -fsp 0
|
||||
zipsourceinstall: fpmake$(SRCEXEEXT)
|
||||
ifdef UNIXHier
|
||||
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=share/src/fpc-\$$\(PACKAGEVERSION\)/$(INSTALL_FPCSUBDIR)/\$$\(PACKAGEDIRECTORY\)
|
||||
else
|
||||
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=source\\$(INSTALL_FPCSUBDIR)\\\$$\(PACKAGEDIRECTORY\)
|
||||
endif
|
||||
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="TArrayProjectDouble"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="tarrayprojectdouble.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="tarrayprojectdouble"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,91 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// Original version by keeper89.blogspot.com, 2011
|
||||
// FPC version by Maciej Izak (hnb), 2014
|
||||
|
||||
program TArrayProjectDouble;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Math, Types, Generics.Collections, Generics.Defaults;
|
||||
|
||||
type
|
||||
TDoubleIntegerArray = array of TIntegerDynArray;
|
||||
|
||||
procedure PrintMatrix(A: TDoubleIntegerArray);
|
||||
var
|
||||
i, j: Integer;
|
||||
begin
|
||||
for i := Low(A) to High(A) do
|
||||
begin
|
||||
for j := Low(A[0]) to High(A[0]) do
|
||||
Write(A[i, j]: 3, ' ');
|
||||
Writeln;
|
||||
end;
|
||||
Writeln; Writeln;
|
||||
end;
|
||||
|
||||
function CustomCompare_1(constref Left, Right: TIntegerDynArray): Integer;
|
||||
begin
|
||||
Result := TCompare.Integer(Right[0], Left[0]);
|
||||
end;
|
||||
|
||||
function CustomCompare_2(constref Left, Right: TIntegerDynArray): Integer;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
i := 0;
|
||||
repeat
|
||||
Result := TCompare.Integer(Right[i], Left[i]);
|
||||
Inc(i);
|
||||
until ((Result <> 0) or (i = Length(Left)));
|
||||
end;
|
||||
|
||||
var
|
||||
A: TDoubleIntegerArray;
|
||||
FoundIndex: Integer;
|
||||
i, j: Integer;
|
||||
|
||||
begin
|
||||
WriteLn('Working with TArray - a two-dimensional integer array');
|
||||
WriteLn;
|
||||
|
||||
// Fill integer array with random numbers [1 .. 50]
|
||||
SetLength(A, 4, 7);
|
||||
Randomize;
|
||||
for i := Low(A) to High(A) do
|
||||
for j := Low(A[0]) to High(A[0]) do
|
||||
A[i, j] := Math.RandomRange(1, 50);
|
||||
|
||||
// Equate some of the elements for further "cascade" sorting
|
||||
A[1, 0] := A[0, 0];
|
||||
A[2, 0] := A[0, 0];
|
||||
A[1, 1] := A[0, 1];
|
||||
|
||||
// Print out what happened
|
||||
Writeln('The original array:');
|
||||
PrintMatrix(A);
|
||||
|
||||
// ! FPC don't support anonymous methods yet
|
||||
//TArray.Sort<TIntegerDynArray>(A, TComparer<TIntegerDynArray>.Construct(
|
||||
// function (const Left, Right: TIntegerDynArray): Integer
|
||||
// begin
|
||||
// Result := Right[0] - Left[0];
|
||||
// end));
|
||||
// Sort descending 1st column, with cutom comparer_1
|
||||
TArrayHelper<TIntegerDynArray>.Sort(A, TComparer<TIntegerDynArray>.Construct(
|
||||
CustomCompare_1));
|
||||
Writeln('Descending in column 1:');
|
||||
PrintMatrix(A);
|
||||
|
||||
// Sort descending 1st column "cascade" -
|
||||
// If the line items are equal, compare neighboring
|
||||
TArrayHelper<TIntegerDynArray>.Sort(A, TComparer<TIntegerDynArray>.Construct(
|
||||
CustomCompare_2));
|
||||
Writeln('Cascade sorting, starting from the 1st column:');
|
||||
PrintMatrix(A);
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
@ -0,0 +1,71 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="TArrayProjectSingle"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="tarrayprojectsingle.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="tarrayprojectsingle"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,111 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// Original version by keeper89.blogspot.com, 2011
|
||||
// FPC version by Maciej Izak (hnb), 2014
|
||||
|
||||
program TArrayProjectSingle;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Math, Types, Generics.Collections, Generics.Defaults;
|
||||
|
||||
function CompareIntReverse(constref Left, Right: Integer): Integer;
|
||||
begin
|
||||
Result := TCompare.Integer(Right, Left);
|
||||
end;
|
||||
|
||||
type
|
||||
TForCompare = class
|
||||
public
|
||||
function CompareIntReverseMethod(constref Left, Right: Integer): Integer;
|
||||
end;
|
||||
|
||||
function TForCompare.CompareIntReverseMethod(constref Left, Right: Integer): Integer;
|
||||
begin
|
||||
Result := TCompare.Integer(Right, Left);
|
||||
end;
|
||||
|
||||
procedure PrintMatrix(A: TIntegerDynArray);
|
||||
var
|
||||
item: Integer;
|
||||
begin
|
||||
for item in A do
|
||||
Write(item, ' ');
|
||||
Writeln; Writeln;
|
||||
end;
|
||||
|
||||
var
|
||||
A: TIntegerDynArray;
|
||||
FoundIndex: PtrInt;
|
||||
ForCompareObj: TForCompare;
|
||||
begin
|
||||
WriteLn('Working with TArray - one-dimensional integer array');
|
||||
WriteLn;
|
||||
|
||||
// Fill a one-dimensional array of integers by random numbers [1 .. 10]
|
||||
A := TIntegerDynArray.Create(1, 6, 3, 2, 9);
|
||||
|
||||
// Print out what happened
|
||||
Writeln('The original array:');
|
||||
PrintMatrix(A);
|
||||
|
||||
// Sort ascending without comparator
|
||||
TArrayHelper<Integer>.Sort(A);
|
||||
Writeln('Ascending Sort without parameters:');
|
||||
PrintMatrix(A);
|
||||
|
||||
// ! FPC don't support anonymous methods yet
|
||||
// Sort descending, the comparator is constructed
|
||||
// using an anonymous method
|
||||
//TArray.Sort<Integer>(A, TComparer<Integer>.Construct(
|
||||
// function (const Left, Right: Integer): Integer
|
||||
// begin
|
||||
// Result := Math.CompareValue(Right, Left)
|
||||
// end));
|
||||
|
||||
// Sort descending, the comparator is constructed
|
||||
// using an method
|
||||
TArrayHelper<Integer>.Sort(A, TComparer<Integer>.Construct(
|
||||
ForCompareObj.CompareIntReverseMethod));
|
||||
Writeln('Descending by TComparer<Integer>.Construct(ForCompareObj.Method):');
|
||||
PrintMatrix(A);
|
||||
|
||||
// Again sort ascending by using defaul
|
||||
TArrayHelper<Integer>.Sort(A, TComparer<Integer>.Default);
|
||||
Writeln('Ascending by TComparer<Integer>.Default:');
|
||||
PrintMatrix(A);
|
||||
|
||||
// Again descending using own comparator function
|
||||
TArrayHelper<Integer>.Sort(A, TComparer<Integer>.Construct(CompareIntReverse));
|
||||
Writeln('Descending by TComparer<Integer>.Construct(CompareIntReverse):');
|
||||
PrintMatrix(A);
|
||||
|
||||
// Searches for a nonexistent element
|
||||
Writeln('BinarySearch nonexistent element');
|
||||
if TArrayHelper<Integer>.BinarySearch(A, 5, FoundIndex) then
|
||||
Writeln('5 is found, its index ', FoundIndex)
|
||||
else
|
||||
Writeln('5 not found!');
|
||||
Writeln;
|
||||
|
||||
// Search for an existing item with default comparer
|
||||
Writeln('BinarySearch for an existing item ');
|
||||
if TArrayHelper<Integer>.BinarySearch(A, 6, FoundIndex) then
|
||||
Writeln('6 is found, its index ', FoundIndex)
|
||||
else
|
||||
Writeln('6 not found!');
|
||||
Writeln;
|
||||
|
||||
// Search for an existing item with custom comparer
|
||||
Writeln('BinarySearch for an existing item with custom comparer');
|
||||
if TArrayHelper<Integer>.BinarySearch(A, 6, FoundIndex,
|
||||
TComparer<Integer>.Construct(CompareIntReverse)) then
|
||||
Writeln('6 is found, its index ', FoundIndex)
|
||||
else
|
||||
Writeln('6 not found!');
|
||||
Writeln;
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="TComparerProject"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="tcomparerproject.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="tcomparerproject"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
124
packages/rtl-generics/examples/tcomparer/tcomparerproject.lpr
Normal file
124
packages/rtl-generics/examples/tcomparer/tcomparerproject.lpr
Normal file
@ -0,0 +1,124 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// by Maciej Izak (hnb), 2014
|
||||
|
||||
program TComparerProject;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Generics.Collections, Generics.Defaults;
|
||||
|
||||
type
|
||||
|
||||
{ TCustomer }
|
||||
|
||||
TCustomer = record
|
||||
private
|
||||
FName: string;
|
||||
FMoney: Currency;
|
||||
public
|
||||
constructor Create(const Name: string; Money: Currency);
|
||||
property Name: string read FName write FName;
|
||||
property Money: Currency read FMoney write FMoney;
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
TCustomerComparer = class(TComparer<TCustomer>)
|
||||
function Compare(constref Left, Right: TCustomer): Integer; override;
|
||||
end;
|
||||
|
||||
{ TCustomer }
|
||||
|
||||
constructor TCustomer.Create(const Name: string; Money: Currency);
|
||||
begin
|
||||
FName := Name;
|
||||
FMoney := Money;
|
||||
end;
|
||||
|
||||
function TCustomer.ToString: string;
|
||||
begin
|
||||
Result := Format('Name: %s >>> Money: %m', [Name, Money]);
|
||||
end;
|
||||
|
||||
// Ascending
|
||||
function TCustomerComparer.Compare(constref Left, Right: TCustomer): Integer;
|
||||
begin
|
||||
Result := TCompare.&String(Left.Name, Right.Name);
|
||||
if Result = 0 then
|
||||
Result := TCompare.Currency(Left.Money, Right.Money);
|
||||
end;
|
||||
|
||||
// Descending
|
||||
function CustomerCompare(constref Left, Right: TCustomer): Integer;
|
||||
begin
|
||||
Result := TCompare.&String(Right.Name, Left.Name);
|
||||
if Result = 0 then
|
||||
Result := TCompare.Currency(Right.Money, Left.Money);
|
||||
end;
|
||||
|
||||
var
|
||||
CustomersArray: TArray<TCustomer>;
|
||||
CustomersList: TList<TCustomer>;
|
||||
Comparer: TCustomerComparer;
|
||||
Customer: TCustomer;
|
||||
begin
|
||||
CustomersArray := TArray<TCustomer>.Create(
|
||||
TCustomer.Create('Derp', 2000),
|
||||
TCustomer.Create('Sheikh', 2000000000),
|
||||
TCustomer.Create('Derp', 1000),
|
||||
TCustomer.Create('Bill Gates', 1000000000));
|
||||
|
||||
Comparer := TCustomerComparer.Create;
|
||||
Comparer._AddRef;
|
||||
|
||||
// create TList with custom comparer
|
||||
CustomersList := TList<TCustomer>.Create(Comparer);
|
||||
CustomersList.AddRange(CustomersArray);
|
||||
|
||||
WriteLn('CustomersList before sort:');
|
||||
for Customer in CustomersList do
|
||||
WriteLn(Customer.ToString);
|
||||
WriteLn;
|
||||
|
||||
// default sort
|
||||
CustomersList.Sort; // will use TCustomerComparer (passed in the constructor)
|
||||
WriteLn('CustomersList after ascending sort (default with interface from constructor):');
|
||||
for Customer in CustomersList do
|
||||
WriteLn(Customer.ToString);
|
||||
WriteLn;
|
||||
|
||||
// construct with simple function
|
||||
CustomersList.Sort(TComparer<TCustomer>.Construct(CustomerCompare));
|
||||
WriteLn('CustomersList after descending sort (by using construct with function)');
|
||||
WriteLn('CustomersList.Sort(TComparer<TCustomer>.Construct(CustomerCompare)):');
|
||||
for Customer in CustomersList do
|
||||
WriteLn(Customer.ToString);
|
||||
WriteLn;
|
||||
|
||||
// construct with method
|
||||
CustomersList.Sort(TComparer<TCustomer>.Construct(Comparer.Compare));
|
||||
WriteLn('CustomersList after ascending sort (by using construct with method)');
|
||||
WriteLn('CustomersList.Sort(TComparer<TCustomer>.Construct(Comparer.Compare)):');
|
||||
for Customer in CustomersList do
|
||||
WriteLn(Customer.ToString);
|
||||
WriteLn;
|
||||
|
||||
WriteLn('CustomersArray before sort:');
|
||||
for Customer in CustomersArray do
|
||||
WriteLn(Customer.ToString);
|
||||
WriteLn;
|
||||
|
||||
// sort with interface
|
||||
TArrayHelper<TCustomer>.Sort(CustomersArray, TCustomerComparer.Create);
|
||||
WriteLn('CustomersArray after ascending sort (by using interfese - no construct)');
|
||||
WriteLn('TArrayHelper<TCustomer>.Sort(CustomersArray, TCustomerComparer.Create):');
|
||||
for Customer in CustomersArray do
|
||||
WriteLn(Customer.ToString);
|
||||
WriteLn;
|
||||
|
||||
CustomersList.Free;
|
||||
Comparer._Release;
|
||||
ReadLn;
|
||||
end.
|
||||
|
||||
71
packages/rtl-generics/examples/thashmap/thashmapproject.lpi
Normal file
71
packages/rtl-generics/examples/thashmap/thashmapproject.lpi
Normal file
@ -0,0 +1,71 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="THashMapProject"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="thashmapproject.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="thashmapproject"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
218
packages/rtl-generics/examples/thashmap/thashmapproject.lpr
Normal file
218
packages/rtl-generics/examples/thashmap/thashmapproject.lpr
Normal file
@ -0,0 +1,218 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// Original version by keeper89.blogspot.com, 2011
|
||||
// FPC version by Maciej Izak (hnb), 2014
|
||||
|
||||
program THashMapProject;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Generics.Collections, Generics.Defaults;
|
||||
|
||||
type
|
||||
TSubscriberInfo = record
|
||||
Name, SName: string;
|
||||
class function Create(const Name, SName: string): TSubscriberInfo; static;
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
// Class containing handlers add / remove items in the dictionary
|
||||
THashMapEventsHandler = class
|
||||
public
|
||||
class procedure OnKeyNotify(Sender: TObject; constref Item: string;
|
||||
Action: TCollectionNotification);
|
||||
class procedure OnValueNotify(Sender: TObject; constref Item: TSubscriberInfo;
|
||||
Action: TCollectionNotification);
|
||||
end;
|
||||
|
||||
class function TSubscriberInfo.Create(const Name,
|
||||
SName: string): TSubscriberInfo;
|
||||
begin
|
||||
Result.Name := Name;
|
||||
Result.SName := SName;
|
||||
end;
|
||||
|
||||
function TSubscriberInfo.ToString: string;
|
||||
begin
|
||||
Result := Format('%s %s', [Name, SName]);
|
||||
end;
|
||||
|
||||
// Function to generate the dictionary contents into a string
|
||||
function PrintTelephoneDirectory(
|
||||
TelephoneDirectory: THashMap<string, TSubscriberInfo>): string;
|
||||
var
|
||||
PhoneNumber: string;
|
||||
begin
|
||||
Result := Format('Content directory (%d):', [TelephoneDirectory.Count]);
|
||||
|
||||
for PhoneNumber in TelephoneDirectory.Keys do
|
||||
Result := Result + Format(LineEnding + '%s: %s',
|
||||
[PhoneNumber, TelephoneDirectory[PhoneNumber].ToString]);
|
||||
end;
|
||||
|
||||
// Handlers add / remove items dictionary
|
||||
class procedure THashMapEventsHandler.OnKeyNotify(Sender: TObject;
|
||||
constref Item: string; Action: TCollectionNotification);
|
||||
begin
|
||||
case Action of
|
||||
cnAdded:
|
||||
Writeln(Format('OnKeyNotify! Phone %s added!', [Item]));
|
||||
cnRemoved:
|
||||
Writeln(Format('OnKeyNotify! Number %s deleted!', [Item]));
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure THashMapEventsHandler.OnValueNotify(Sender: TObject;
|
||||
constref Item: TSubscriberInfo; Action: TCollectionNotification);
|
||||
begin
|
||||
case Action of
|
||||
cnAdded:
|
||||
Writeln(Format('OnValueNotify! Subscriber %s added!', [Item.ToString]));
|
||||
cnRemoved:
|
||||
Writeln(Format('OnValueNotify! Subscriber %s deleted!', [Item.ToString]));
|
||||
end;
|
||||
end;
|
||||
|
||||
function CustomCompare(constref Left, Right: TPair<string, TSubscriberInfo>): Integer;
|
||||
begin
|
||||
// Comparable full first names, and then phones if necessary
|
||||
Result := TCompare.&String(Left.Value.ToString, Right.Value.ToString);
|
||||
if Result = 0 then
|
||||
Result := TCompare.&String(Left.Key, Right.Key);
|
||||
end;
|
||||
|
||||
var
|
||||
// Declare the "dictionary"
|
||||
// key is the telephone number which will be possible
|
||||
// to determine information about the owner
|
||||
TelephoneDirectory: THashMap<string, TSubscriberInfo>;
|
||||
TTelephoneArray: array of TPair<string, TSubscriberInfo>;
|
||||
TTelephoneArrayItem: TPair<string, TSubscriberInfo>;
|
||||
PhoneNumber: string;
|
||||
Subscriber: TSubscriberInfo;
|
||||
begin
|
||||
WriteLn('Working with THashMap - phonebook');
|
||||
WriteLn;
|
||||
|
||||
// create a directory
|
||||
// Constructor has several overloaded options which will
|
||||
// enable the capacity of the container, a comparator for values
|
||||
// or the initial data - we use the easiest option
|
||||
TelephoneDirectory := THashMap<string, TSubscriberInfo>.Create;
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 1) Adding items to dictionary
|
||||
|
||||
// Add new users to the phonebook
|
||||
TelephoneDirectory.Add('9201111111', TSubscriberInfo.Create('Arnold', 'Schwarzenegger'));
|
||||
TelephoneDirectory.Add('9202222222', TSubscriberInfo.Create('Jessica', 'Alba'));
|
||||
TelephoneDirectory.Add('9203333333', TSubscriberInfo.Create('Brad', 'Pitt'));
|
||||
TelephoneDirectory.Add('9204444444', TSubscriberInfo.Create('Brad', 'Pitt'));
|
||||
TelephoneDirectory.Add('9205555555', TSubscriberInfo.Create('Sandra', 'Bullock'));
|
||||
// Adding a new subscriber if number already exist
|
||||
TelephoneDirectory.AddOrSetValue('9204444444',
|
||||
TSubscriberInfo.Create('Angelina', 'Jolie'));
|
||||
// Print list
|
||||
Writeln(PrintTelephoneDirectory(TelephoneDirectory));
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 2) Working with the elements
|
||||
|
||||
// Set the "capacity" of the dictionary according to the current number of elements
|
||||
TelephoneDirectory.TrimExcess;
|
||||
// Is there a key? - ContainsKey
|
||||
if TelephoneDirectory.ContainsKey('9205555555') then
|
||||
Writeln('Phone 9205555555 registered!');
|
||||
// Is there a subscriber? - ContainsValue
|
||||
Subscriber := TSubscriberInfo.Create('Sandra', 'Bullock');
|
||||
if TelephoneDirectory.ContainsValue(Subscriber) then
|
||||
Writeln(Format('%s is in the directory!', [Subscriber.ToString]));
|
||||
// Try to get information via telephone. TryGetValue
|
||||
if TelephoneDirectory.TryGetValue('9204444444', Subscriber) then
|
||||
Writeln(Format('Number 9204444444 belongs to %s', [Subscriber.ToString]));
|
||||
// Directly access by phone number
|
||||
Writeln(Format('Phone 9201111111 subscribers: %s', [TelephoneDirectory['9201111111'].ToString]));
|
||||
// Number of people in the directory
|
||||
Writeln(Format('Total subscribers in the directory: %d', [TelephoneDirectory.Count]));
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 3) Delete items
|
||||
|
||||
// Schwarzenegger now will not be listed
|
||||
TelephoneDirectory.Remove('9201111111');
|
||||
// Completely clear the list
|
||||
TelephoneDirectory.Clear;
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 4) Events add / remove values
|
||||
//
|
||||
// Events OnKeyNotify OnValueNotify are designed for "tracking"
|
||||
// for adding / removing keys and values respectively
|
||||
TelephoneDirectory.OnKeyNotify := THashMapEventsHandler.OnKeyNotify;
|
||||
TelephoneDirectory.OnValueNotify := THashMapEventsHandler.OnValueNotify;
|
||||
|
||||
Writeln;
|
||||
// Try events
|
||||
TelephoneDirectory.Add('9201111111', TSubscriberInfo.Create('Arnold', 'Schwarzenegger'));
|
||||
TelephoneDirectory.Add('9202222222', TSubscriberInfo.Create('Jessica', 'Alba'));
|
||||
TelephoneDirectory['9202222222'] := TSubscriberInfo.Create('Monica', 'Bellucci');
|
||||
TelephoneDirectory.Clear;
|
||||
WriteLn;
|
||||
|
||||
TelephoneDirectory.Add('9201111111', TSubscriberInfo.Create('Monica', 'Bellucci'));
|
||||
TelephoneDirectory.Add('9202222222', TSubscriberInfo.Create('Sylvester', 'Stallone'));
|
||||
TelephoneDirectory.Add('9203333333', TSubscriberInfo.Create('Bruce', 'Willis'));
|
||||
WriteLn;
|
||||
|
||||
// Show keys (phones)
|
||||
Writeln('Keys (phones):');
|
||||
for PhoneNumber in TelephoneDirectory.Keys do
|
||||
Writeln(PhoneNumber);
|
||||
Writeln;
|
||||
|
||||
// Show values (subscribers)
|
||||
Writeln('Values (subscribers):');
|
||||
for Subscriber in TelephoneDirectory.Values do
|
||||
Writeln(Subscriber.ToString);
|
||||
Writeln;
|
||||
|
||||
// All together now
|
||||
Writeln('Subscribers list with phones:');
|
||||
for PhoneNumber in TelephoneDirectory.Keys do
|
||||
Writeln(Format('%s: %s',
|
||||
[PhoneNumber, TelephoneDirectory[PhoneNumber].ToString]));
|
||||
Writeln;
|
||||
|
||||
// In addition, we can "export" from the dictionary
|
||||
// to TArray
|
||||
// Sort the resulting array and display
|
||||
TTelephoneArray := TelephoneDirectory.ToArray;
|
||||
|
||||
// partial specializations not allowed
|
||||
// same for anonymous methods
|
||||
//TArray.Sort<TPair<string, TSubscriberInfo>>(
|
||||
// TTelephoneArray, TComparer<TPair<string, TSubscriberInfo>>.Construct(
|
||||
// function (const Left, Right: TPair<string, TSubscriberInfo>): Integer
|
||||
// begin
|
||||
// // Comparable full first names, and then phones if necessary
|
||||
// Result := CompareStr(Left.Value.ToString, Right.Value.ToString);
|
||||
// if Result = 0 then
|
||||
// Result := CompareStr(Left.Key, Right.Key);
|
||||
// end));
|
||||
|
||||
TArrayHelper<TelephoneDirectory.TDictionaryPair>.Sort(
|
||||
TTelephoneArray, TComparer<TelephoneDirectory.TDictionaryPair>.Construct(
|
||||
CustomCompare));
|
||||
// Print
|
||||
Writeln('Sorted list of subscribers into TArray (by name, and eventually by phone):');
|
||||
for TTelephoneArrayItem in TTelephoneArray do
|
||||
Writeln(Format('%s: %s',
|
||||
[TTelephoneArrayItem.Value.ToString, TTelephoneArrayItem.Key]));
|
||||
|
||||
Writeln;
|
||||
FreeAndNil(TelephoneDirectory);
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="THashMapCaseInsensitive"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="thashmapcaseinsensitive.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="thashmapcaseinsensitive"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,55 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// by Maciej Izak (hnb), 2014
|
||||
|
||||
program THashMapCaseInsensitive;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
Generics.Collections, Generics.Defaults;
|
||||
|
||||
var
|
||||
StringMap: THashMap<String, TEmptyRecord>;
|
||||
AnsiStringMap: THashMap<AnsiString, TEmptyRecord>;
|
||||
UnicodeStringMap: THashMap<UnicodeString, TEmptyRecord>;
|
||||
AdvancedHashMapWithBigLoadFactor: TCuckooD6<RawByteString, TEmptyRecord>;
|
||||
k: String;
|
||||
begin
|
||||
WriteLn('Working with case insensitive THashMap');
|
||||
WriteLn;
|
||||
// example constructors for different string types
|
||||
StringMap := THashMap<String, TEmptyRecord>.Create(TIStringComparer.Ordinal);
|
||||
StringMap.Free;
|
||||
AnsiStringMap := THashMap<AnsiString, TEmptyRecord>.Create(TIAnsiStringComparer.Ordinal);
|
||||
AnsiStringMap.Free;
|
||||
UnicodeStringMap := THashMap<UnicodeString, TEmptyRecord>.Create(TIUnicodeStringComparer.Ordinal);
|
||||
UnicodeStringMap.Free;
|
||||
|
||||
// standard TI*Comparer is dedicated for MAX_HASHLIST_COUNT = 4 and lower. For example DArrayCuckoo where D = 6
|
||||
// we need to create extra specialized TGIStringComparer type
|
||||
AdvancedHashMapWithBigLoadFactor := TCuckooD6<RawByteString, TEmptyRecord>.Create(
|
||||
TGIStringComparer<RawByteString, TDelphiSixfoldHashFactory>.Ordinal);
|
||||
AdvancedHashMapWithBigLoadFactor.Free;
|
||||
|
||||
// ok lets start
|
||||
// another way to create case insensitive hash map
|
||||
StringMap := THashMap<String, TEmptyRecord>.Create(TGIStringComparer<String>.Ordinal);
|
||||
|
||||
WriteLn('Add Cat and Dog');
|
||||
StringMap.Add('Cat', EmptyRecord);
|
||||
StringMap.Add('Dog', EmptyRecord);
|
||||
|
||||
//
|
||||
WriteLn('Contains CAT = ', StringMap.ContainsKey('CAT'));
|
||||
WriteLn('Contains dOG = ', StringMap.ContainsKey('dOG'));
|
||||
WriteLn('Contains Fox = ', StringMap.ContainsKey('Fox'));
|
||||
|
||||
WriteLn('Enumerate all keys :');
|
||||
for k in StringMap.Keys do
|
||||
WriteLn(' > ', k);
|
||||
|
||||
ReadLn;
|
||||
StringMap.Free;
|
||||
end.
|
||||
|
||||
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="THashMapExtendedEqualityComparer"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="thashmapextendedequalitycomparer.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="thashmapextendedequalitycomparer"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,108 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// by Maciej Izak (hnb), 2014
|
||||
|
||||
program THashMapExtendedEqualityComparer;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Generics.Collections, Generics.Defaults;
|
||||
|
||||
type
|
||||
|
||||
{ TTaxPayer }
|
||||
|
||||
TTaxPayer = record
|
||||
TaxID: Integer;
|
||||
Name: string;
|
||||
|
||||
constructor Create(ATaxID: Integer; const AName: string);
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
constructor TTaxPayer.Create(ATaxID: Integer; const AName: string);
|
||||
begin
|
||||
TaxID := ATaxID;
|
||||
Name := AName;
|
||||
end;
|
||||
|
||||
function TTaxPayer.ToString: string;
|
||||
begin
|
||||
Result := Format('TaxID = %-10d Name = %-17s', [TaxID, Name]);
|
||||
end;
|
||||
|
||||
function EqualityComparison(constref ALeft, ARight: TTaxPayer): Boolean;
|
||||
begin
|
||||
Result := ALeft.TaxID = ARight.TaxID;
|
||||
end;
|
||||
|
||||
procedure ExtendedHasher(constref AValue: TTaxPayer; AHashList: PUInt32);
|
||||
begin
|
||||
// don't work with TCuckooD6 map because default TCuckooD6 needs TDelphiSixfoldHashFactory
|
||||
// and TDefaultHashFactory = TDelphiQuadrupleHashFactory
|
||||
// (TDelphiQuadrupleHashFactory is compatible with TDelphiDoubleHashFactory and TDelphiHashFactory)
|
||||
TDefaultHashFactory.GetHashList(@AValue.TaxID, SizeOf(Integer), AHashList);
|
||||
end;
|
||||
|
||||
var
|
||||
map: THashMap<TTaxPayer, string>; // THashMap = TCuckooD4
|
||||
LTaxPayer: TTaxPayer;
|
||||
LSansa: TTaxPayer;
|
||||
LPair: TPair<TTaxPayer, string>;
|
||||
begin
|
||||
WriteLn('program of tax office - ExtendedEqualityComparer for THashMap');
|
||||
WriteLn;
|
||||
|
||||
// to identify the taxpayer need only nip
|
||||
map := THashMap<TTaxPayer, string>.Create(
|
||||
TExtendedEqualityComparer<TTaxPayer>.Construct(EqualityComparison, ExtendedHasher));
|
||||
|
||||
map.Add(TTaxPayer.Create(1234567890, 'Joffrey Baratheon'), 'guilty');
|
||||
map.Add(TTaxPayer.Create(90, 'Little Finger'), 'swindler');
|
||||
map.Add(TTaxPayer.Create(667, 'John Snow'), 'delinquent tax');
|
||||
|
||||
// useless in this place but we can convert Keys to TArray<TKey> :)
|
||||
WriteLn(Format('All taxpayers (count = %d)', [Length(map.Keys.ToArray)]));
|
||||
for LTaxPayer in map.Keys do
|
||||
WriteLn(' > ', LTaxPayer.ToString);
|
||||
|
||||
LSansa := TTaxPayer.Create(667, 'Sansa Stark');
|
||||
|
||||
// exist because custom EqualityComparison and ExtendedHasher
|
||||
WriteLn;
|
||||
WriteLn(LSansa.Name, ' exist in map = ', map.ContainsKey(LSansa));
|
||||
WriteLn;
|
||||
|
||||
//
|
||||
WriteLn('All taxpayers');
|
||||
for LPair in map do
|
||||
WriteLn(' > ', LPair.Key.ToString, ' is ', LPair.Value);
|
||||
|
||||
// Add or set sansa? :)
|
||||
WriteLn;
|
||||
WriteLn(Format('AddOrSet(%s, ''innocent'')', [LSansa.ToString]));
|
||||
map.AddOrSetValue(LSansa, 'innocent');
|
||||
WriteLn;
|
||||
|
||||
//
|
||||
WriteLn('All taxpayers');
|
||||
for LPair in map do
|
||||
WriteLn(' > ', LPair.Key.ToString, ' is ', LPair.Value);
|
||||
|
||||
// Add or set sansa? :)
|
||||
WriteLn;
|
||||
LSansa.TaxID := 668;
|
||||
WriteLn(Format('AddOrSet(%s, ''innocent'')', [LSansa.ToString]));
|
||||
map.AddOrSetValue(LSansa, 'innocent');
|
||||
WriteLn;
|
||||
|
||||
//
|
||||
WriteLn('All taxpayers');
|
||||
for LPair in map do
|
||||
WriteLn(' > ', LPair.Key.ToString, ' is ', LPair.Value);
|
||||
|
||||
ReadLn;
|
||||
map.Free;
|
||||
end.
|
||||
|
||||
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="TObjectListProject"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="tobjectlistproject.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="tobjectlistproject"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,194 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// Original version by keeper89.blogspot.com, 2011
|
||||
// FPC version by Maciej Izak (hnb), 2014
|
||||
|
||||
program TObjectListProject;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Generics.Collections, Generics.Defaults, DateUtils;
|
||||
|
||||
type
|
||||
TPlayer = class
|
||||
public
|
||||
Name, Team: string;
|
||||
BirthDay: TDateTime;
|
||||
NTeamGoals: Byte; // Number of goals for the national team
|
||||
constructor Create(const Name: string; BirthDay: TDateTime;
|
||||
const Team: string; NTeamGoals: Byte = 0);
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
// Class containing handlers add / remove list items
|
||||
TListEventsHandler = class
|
||||
public
|
||||
class procedure OnListChanged(Sender: TObject; constref Item: TPlayer;
|
||||
Action: TCollectionNotification);
|
||||
end;
|
||||
|
||||
|
||||
constructor TPlayer.Create(const Name: string; BirthDay: TDateTime;
|
||||
const Team: string; NTeamGoals: Byte);
|
||||
begin
|
||||
Self.Name := Name;
|
||||
Self.BirthDay := BirthDay;
|
||||
Self.Team := Team;
|
||||
Self.NTeamGoals := NTeamGoals;
|
||||
end;
|
||||
|
||||
function TPlayer.ToString: string;
|
||||
begin
|
||||
Result := Format('%s - Age: %d Team: %s Goals: %d',
|
||||
[Name,
|
||||
DateUtils.YearsBetween(Date, BirthDay),
|
||||
Team, NTeamGoals])
|
||||
end;
|
||||
|
||||
// Function sort descending goals for the national team
|
||||
function ComparePlayersByGoalsDecs(constref Player1, Player2: TPlayer): Integer;
|
||||
begin
|
||||
Result := TCompare.UInt8(Player2.NTeamGoals, Player1.NTeamGoals);
|
||||
end;
|
||||
|
||||
class procedure TListEventsHandler.OnListChanged(Sender: TObject; constref Item: TPlayer;
|
||||
Action: TCollectionNotification);
|
||||
var
|
||||
Mes: string;
|
||||
begin
|
||||
// Unlike TDictionary we added Action = cnExtracted
|
||||
case Action of
|
||||
cnAdded:
|
||||
Mes := 'added to the list!';
|
||||
cnRemoved:
|
||||
Mes := 'removed from the list!';
|
||||
cnExtracted:
|
||||
Mes := 'extracted from the list!';
|
||||
end;
|
||||
Writeln(Format('Football player %s %s ', [Item.ToString, Mes]));
|
||||
end;
|
||||
|
||||
var
|
||||
// Declare TObjectList as storage for TPlayer
|
||||
PlayersList: TObjectList<TPlayer>;
|
||||
Player: TPlayer;
|
||||
FoundIndex: PtrInt;
|
||||
begin
|
||||
WriteLn('Working with TObjectList - football manager');
|
||||
WriteLn;
|
||||
|
||||
PlayersList := TObjectList<TPlayer>.Create;
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 1) Adding items
|
||||
|
||||
PlayersList.Add(
|
||||
TPlayer.Create('Zinedine Zidane', EncodeDate(1972, 06, 23), 'France', 31));
|
||||
PlayersList.Add(
|
||||
TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44));
|
||||
PlayersList.Add(
|
||||
TPlayer.Create('Ronaldo', EncodeDate(1976, 09, 22), 'Brazil', 62));
|
||||
// Adding the specified position
|
||||
PlayersList.Insert(0,
|
||||
TPlayer.Create('Luis Figo', EncodeDate(1972, 11, 4), 'Portugal', 33));
|
||||
// Add a few players through InsertRange (AddRange works similarly)
|
||||
PlayersList.InsertRange(0,
|
||||
[TPlayer.Create('David Beckham', EncodeDate(1975, 05, 2), 'England', 17),
|
||||
TPlayer.Create('Alessandro Del Piero', EncodeDate(1974, 11, 9), 'Italy ', 27),
|
||||
TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44)]);
|
||||
Player := TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44);
|
||||
PlayersList.Add(Player);
|
||||
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 2) Access and check the items
|
||||
|
||||
// Is there a player in the list - Contains
|
||||
if PlayersList.Contains(Player) then
|
||||
Writeln('Raul is in the list!');
|
||||
// Player index and count of items in the list
|
||||
Writeln(Format('Raul is %d-th on the list of %d players.',
|
||||
[PlayersList.IndexOf(Player) + 1, PlayersList.Count]));
|
||||
// Index access
|
||||
Writeln(Format('1st in the list: %s', [PlayersList[0].ToString]));
|
||||
// The first player
|
||||
Writeln(Format('1st in the list: %s', [PlayersList.First.ToString]));
|
||||
// The last player
|
||||
Writeln(Format('Last in the list: %s', [PlayersList.Last.ToString]));
|
||||
// "Reverse" elements
|
||||
PlayersList.Reverse;
|
||||
Writeln('List items have been "reversed"');
|
||||
Writeln;
|
||||
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 3) Moving and removing items
|
||||
|
||||
// Changing places players in the list
|
||||
PlayersList.Exchange(0, 1);
|
||||
// Move back 1 player
|
||||
PlayersList.Move(1, 0);
|
||||
|
||||
// Removes the element at index
|
||||
PlayersList.Delete(5);
|
||||
// Or a number of elements starting at index
|
||||
PlayersList.DeleteRange(5, 2);
|
||||
// Remove the item from the list, if the item
|
||||
// exists returns its index in the list
|
||||
Writeln(Format('Removed %d-st player', [PlayersList.Remove(Player) + 1]));
|
||||
|
||||
// Extract and return the item, if there is no Player in the list then
|
||||
// Extract will return = nil, (anyway Raul is already removed via Remove)
|
||||
Player := PlayersList.Extract(Player);
|
||||
if Assigned(Player) then
|
||||
Writeln(Format('Extracted: %s', [Player.ToString]));
|
||||
|
||||
// Clear the list completely
|
||||
PlayersList.Clear;
|
||||
Writeln;
|
||||
|
||||
// ---------------------------------------------------
|
||||
// 4) Event OnNotify, sorting and searching
|
||||
|
||||
PlayersList.OnNotify := TListEventsHandler.OnListChanged;
|
||||
|
||||
PlayersList.Add(
|
||||
TPlayer.Create('Zinedine Zidane', EncodeDate(1972, 06, 23), 'France', 31));
|
||||
PlayersList.Add(
|
||||
TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44));
|
||||
PlayersList.Add(
|
||||
TPlayer.Create('Ronaldo', EncodeDate(1976, 09, 22), 'Brazil', 62));
|
||||
PlayersList.AddRange(
|
||||
[TPlayer.Create('David Beckham', EncodeDate(1975, 05, 2), 'England', 17),
|
||||
TPlayer.Create('Alessandro Del Piero', EncodeDate(1974, 11, 9), 'Italy ', 27),
|
||||
TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44)]);
|
||||
|
||||
PlayersList.Remove(PlayersList.Last);
|
||||
Player := PlayersList.Extract(PlayersList[0]);
|
||||
|
||||
PlayersList.Sort(TComparer<TPlayer>.Construct(ComparePlayersByGoalsDecs));
|
||||
Writeln;
|
||||
Writeln('Sorted list of players:');
|
||||
for Player in PlayersList do
|
||||
Writeln(Player.ToString);
|
||||
Writeln;
|
||||
|
||||
// Find Ronaldo!
|
||||
// TArray BinarySearch requires sorted list
|
||||
// IndexOf does not require sorted list
|
||||
// but BinarySearch is usually faster
|
||||
Player := PlayersList[0];
|
||||
if PlayersList.BinarySearch(Player, FoundIndex,
|
||||
TComparer<TPlayer>.Construct(ComparePlayersByGoalsDecs)) then
|
||||
Writeln(Format('Ronaldo is in the sorted list at position %d', [FoundIndex + 1]));
|
||||
|
||||
Writeln;
|
||||
|
||||
// With the destruction of the list remove all elements
|
||||
// OnNotify show it
|
||||
FreeAndNil(PlayersList);
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
66
packages/rtl-generics/examples/tqueue/tqueueproject.lpi
Normal file
66
packages/rtl-generics/examples/tqueue/tqueueproject.lpi
Normal file
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="TQueueProject"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="tqueueproject.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="tqueueproject"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
89
packages/rtl-generics/examples/tqueue/tqueueproject.lpr
Normal file
89
packages/rtl-generics/examples/tqueue/tqueueproject.lpr
Normal file
@ -0,0 +1,89 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// Original version by keeper89.blogspot.com, 2011
|
||||
// FPC version by Maciej Izak (hnb), 2014
|
||||
|
||||
program TQueueProject;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils, Generics.Collections;
|
||||
|
||||
type
|
||||
// This is FreeSpaaarta! versions =)
|
||||
TSpartaVersion = (svFreeSparta, svBasic, svStarter, svProfessional);
|
||||
|
||||
TCustomer = record
|
||||
strict private
|
||||
const
|
||||
SV_NAMES: array [TSpartaVersion] of string =
|
||||
('FreeSparta', 'Basic', 'Starter', 'Professional');
|
||||
public
|
||||
var
|
||||
SpartaVersion: TSpartaVersion;
|
||||
class function Create(SpartaVersion: TSpartaVersion): TCustomer; static;
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
class function TCustomer.Create(SpartaVersion: TSpartaVersion): TCustomer;
|
||||
begin
|
||||
Result.SpartaVersion := SpartaVersion;
|
||||
end;
|
||||
|
||||
function TCustomer.ToString: string;
|
||||
begin
|
||||
Result := Format('Sparta %s', [SV_NAMES[SpartaVersion]])
|
||||
end;
|
||||
|
||||
var
|
||||
CustomerQueue: TQueue<TCustomer>;
|
||||
Customer: TCustomer;
|
||||
begin
|
||||
WriteLn('Working with TQueue - buy FreeSparta.com');
|
||||
WriteLn;
|
||||
|
||||
// "Create" turn in sales
|
||||
CustomerQueue := TQueue<TCustomer>.Create;
|
||||
|
||||
// Add a few people in the queue
|
||||
// Enqueue - puts the item in the queue
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svFreeSparta));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svBasic));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svBasic));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svBasic));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svStarter));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svStarter));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svProfessional));
|
||||
CustomerQueue.Enqueue(TCustomer.Create(svProfessional));
|
||||
|
||||
// Part of customers served
|
||||
// Dequeue - remove an element from the queue
|
||||
// btw if TQueue is TObjectQueue also call Free for object
|
||||
Customer := CustomerQueue.Dequeue;
|
||||
Writeln(Format('Sold (Dequeue): %s', [Customer.ToString]));
|
||||
// Extract - similar to Dequeue, but causes in OnNotify
|
||||
// Action = cnExtracted instead cnRemoved
|
||||
Customer := CustomerQueue.Extract;
|
||||
Writeln(Format('Sold (Extract): %s', [Customer.ToString]));
|
||||
|
||||
// For what came next buyer?
|
||||
// Peek - returns the first element, but does not remove it from the queue
|
||||
Writeln(Format('Serves customers come for %s',
|
||||
[CustomerQueue.Peek.ToString]));
|
||||
|
||||
// The remaining buyers
|
||||
Writeln;
|
||||
Writeln(Format('Buyers left: %d', [CustomerQueue.Count]));
|
||||
for Customer in CustomerQueue do
|
||||
Writeln(Customer.ToString);
|
||||
|
||||
// We serve all
|
||||
// Clear - clears the queue
|
||||
CustomerQueue.Clear;
|
||||
|
||||
FreeAndNil(CustomerQueue);
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
66
packages/rtl-generics/examples/tstack/tstackproject.lpi
Normal file
66
packages/rtl-generics/examples/tstack/tstackproject.lpi
Normal file
@ -0,0 +1,66 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="TStackProject"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="tstackproject.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="tstackproject"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="..\..\src"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
86
packages/rtl-generics/examples/tstack/tstackproject.lpr
Normal file
86
packages/rtl-generics/examples/tstack/tstackproject.lpr
Normal file
@ -0,0 +1,86 @@
|
||||
// Generic types for FreeSparta.com and FreePascal!
|
||||
// Original version by keeper89.blogspot.com, 2011
|
||||
// FPC version by Maciej Izak (hnb), 2014
|
||||
program TStackProject;
|
||||
|
||||
{$MODE DELPHI}
|
||||
{$APPTYPE CONSOLE}
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
Windows,
|
||||
Generics.Collections;
|
||||
|
||||
type
|
||||
// We will cook pancakes, put them on a plate and take the last
|
||||
TPancakeType = (ptMeat, ptCherry, ptCurds);
|
||||
|
||||
TPancake = record
|
||||
strict private
|
||||
const
|
||||
PANCAKE_TYPE_NAMES: array [TPancakeType] of string =
|
||||
('meat', 'cherry', 'curds');
|
||||
public
|
||||
var
|
||||
PancakeType: TPancakeType;
|
||||
class function Create(PancakeType: TPancakeType): TPancake; static;
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
class function TPancake.Create(PancakeType: TPancakeType): TPancake;
|
||||
begin
|
||||
Result.PancakeType := PancakeType;
|
||||
end;
|
||||
|
||||
function TPancake.ToString: string;
|
||||
begin
|
||||
Result := Format('Pancake with %s', [PANCAKE_TYPE_NAMES[PancakeType]])
|
||||
end;
|
||||
|
||||
var
|
||||
PancakesPlate: TStack<TPancake>;
|
||||
Pancake: TPancake;
|
||||
|
||||
begin
|
||||
WriteLn('Working with TStack - pancakes');
|
||||
WriteLn;
|
||||
|
||||
// "Create" a plate of pancakes
|
||||
PancakesPlate := TStack<TPancake>.Create;
|
||||
|
||||
// Bake some pancakes
|
||||
// Push - puts items on the stack
|
||||
PancakesPlate.Push(TPancake.Create(ptMeat));
|
||||
PancakesPlate.Push(TPancake.Create(ptCherry));
|
||||
PancakesPlate.Push(TPancake.Create(ptCherry));
|
||||
PancakesPlate.Push(TPancake.Create(ptCurds));
|
||||
PancakesPlate.Push(TPancake.Create(ptMeat));
|
||||
|
||||
// Eating some pancakes
|
||||
// Pop - removes an item from the stack
|
||||
Pancake := PancakesPlate.Pop;
|
||||
Writeln(Format('Ate a pancake (Pop): %s', [Pancake.ToString]));
|
||||
// Extract - similar to Pop, but causes in OnNotify
|
||||
// Action = cnExtracted instead of cnRemoved
|
||||
Pancake := PancakesPlate.Extract;
|
||||
Writeln(Format('Ate a pancake (Extract): %s', [Pancake.ToString]));
|
||||
|
||||
// What is the last pancake?
|
||||
// Peek - returns the last item, but does not remove it from the stack
|
||||
Writeln(Format('Last pancake: %s', [PancakesPlate.Peek.ToString]));
|
||||
|
||||
// Show the remaining pancakes
|
||||
Writeln;
|
||||
Writeln(Format('Total pancakes: %d', [PancakesPlate.Count]));
|
||||
for Pancake in PancakesPlate do
|
||||
Writeln(Pancake.ToString);
|
||||
|
||||
// Eat up all
|
||||
// Clear - clears the stack
|
||||
PancakesPlate.Clear;
|
||||
|
||||
FreeAndNil(PancakesPlate);
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
78
packages/rtl-generics/fpmake.pp
Normal file
78
packages/rtl-generics/fpmake.pp
Normal file
@ -0,0 +1,78 @@
|
||||
{$ifndef ALLPACKAGES}
|
||||
program fpmake;
|
||||
|
||||
{$mode objfpc}{$h+}
|
||||
|
||||
uses fpmkunit;
|
||||
{$endif}
|
||||
|
||||
Procedure add_rtl_generics(ADirectory : string);
|
||||
|
||||
Var
|
||||
P : TPackage;
|
||||
T : TTarget;
|
||||
|
||||
begin
|
||||
With Installer do
|
||||
begin
|
||||
P:=AddPackage('rtl-generics');
|
||||
P.ShortName:='rtlgen';
|
||||
P.Author := 'Maciej Izak';
|
||||
P.License := 'LGPL with modification, ';
|
||||
P.HomepageURL := 'www.freepascal.org';
|
||||
P.Email := '';
|
||||
P.Description := 'Generic collection library.';
|
||||
P.NeedLibC:= false;
|
||||
P.OSes := AllOSes;
|
||||
P.Directory:=ADirectory;
|
||||
P.Version:='3.1.1';
|
||||
P.Dependencies.Add('rtl-objpas');
|
||||
P.SourcePath.Add('src');
|
||||
P.IncludePath.Add('src/inc');
|
||||
T:=P.Targets.AddUnit('generics.collections.pas');
|
||||
with T.Dependencies do
|
||||
begin
|
||||
AddUnit('generics.memoryexpanders');
|
||||
AddUnit('generics.defaults');
|
||||
AddUnit('generics.helpers');
|
||||
AddUnit('generics.strings');
|
||||
end;
|
||||
T:=P.Targets.AddUnit('generics.defaults.pas');
|
||||
with T.Dependencies do
|
||||
begin
|
||||
AddUnit('generics.hashes');
|
||||
AddUnit('generics.strings');
|
||||
AddUnit('generics.helpers');
|
||||
end;
|
||||
T:=P.Targets.AddUnit('generics.hashes.pas');
|
||||
T:=P.Targets.AddUnit('generics.helpers.pas');
|
||||
T:=P.Targets.AddUnit('generics.memoryexpanders.pas');
|
||||
T:=P.Targets.AddUnit('generics.strings.pas');
|
||||
// Examples
|
||||
P.ExamplePath.Add('examples/tarraydouble');
|
||||
T:=P.Targets.AddExampleProgram('tarrayprojectdouble.lpr');
|
||||
P.ExamplePath.Add('examples/tarraysingle');
|
||||
T:=P.Targets.AddExampleProgram('tarrayprojectsingle.lpr');
|
||||
P.ExamplePath.Add('examples/tcomparer');
|
||||
T:=P.Targets.AddExampleProgram('tcomparerproject.lpr');
|
||||
P.ExamplePath.Add('examples/thashmap');
|
||||
T:=P.Targets.AddExampleProgram('thashmapproject.lpr');
|
||||
P.ExamplePath.Add('examples/thashmapcaseinsensitive');
|
||||
T:=P.Targets.AddExampleProgram('thashmapcaseinsensitive.lpr');
|
||||
P.ExamplePath.Add('examples/thashmapextendedequalitycomparer');
|
||||
T:=P.Targets.AddExampleProgram('thashmapextendedequalitycomparer.lpr');
|
||||
P.ExamplePath.Add('examples/tobjectlist');
|
||||
T:=P.Targets.AddExampleProgram('tobjectlistproject.lpr');
|
||||
P.ExamplePath.Add('examples/tqueue');
|
||||
T:=P.Targets.AddExampleProgram('tqueueproject.lpr');
|
||||
P.ExamplePath.Add('examples/tstack');
|
||||
T:=P.Targets.AddExampleProgram('tstackproject.lpr');
|
||||
end;
|
||||
end;
|
||||
|
||||
{$ifndef ALLPACKAGES}
|
||||
begin
|
||||
add_rtl_generics('');
|
||||
Installer.Run;
|
||||
end.
|
||||
{$endif ALLPACKAGES}
|
||||
1265
packages/rtl-generics/src/generics.collections.pas
Normal file
1265
packages/rtl-generics/src/generics.collections.pas
Normal file
File diff suppressed because it is too large
Load Diff
3270
packages/rtl-generics/src/generics.defaults.pas
Normal file
3270
packages/rtl-generics/src/generics.defaults.pas
Normal file
File diff suppressed because it is too large
Load Diff
915
packages/rtl-generics/src/generics.hashes.pas
Normal file
915
packages/rtl-generics/src/generics.hashes.pas
Normal file
@ -0,0 +1,915 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.Hashes;
|
||||
|
||||
{$MODE DELPHI}{$H+}
|
||||
{$POINTERMATH ON}
|
||||
{$MACRO ON}
|
||||
{$COPERATORS ON}
|
||||
{$OVERFLOWCHECKS OFF}
|
||||
{$RANGECHECKS OFF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
// Original version of Bob Jenkins Hash
|
||||
// http://burtleburtle.net/bob/c/lookup3.c
|
||||
function HashWord(
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
|
||||
procedure HashWord2 (
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
|
||||
|
||||
function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
|
||||
procedure HashLittle2(
|
||||
AKey: Pointer; //* the key to hash */
|
||||
ALength: SizeInt; //* length of the key */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
|
||||
|
||||
function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
|
||||
procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
|
||||
|
||||
// hash function from fstl
|
||||
function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
|
||||
// some other hashes
|
||||
// http://stackoverflow.com/questions/14409466/simple-hash-functions
|
||||
// http://www.partow.net/programming/hashfunctions/
|
||||
// http://en.wikipedia.org/wiki/List_of_hash_functions
|
||||
// http://www.cse.yorku.ca/~oz/hash.html
|
||||
|
||||
// https://code.google.com/p/hedgewars/source/browse/hedgewars/adler32.pas
|
||||
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
|
||||
implementation
|
||||
|
||||
function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
var
|
||||
i: Integer;
|
||||
ABuffer: PUInt8 absolute AKey;
|
||||
begin
|
||||
Result := 0;
|
||||
for i := 0 to ALength - 1 do
|
||||
Inc(Result,ABuffer[i]);
|
||||
end;
|
||||
|
||||
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
const
|
||||
MOD_ADLER = 65521;
|
||||
var
|
||||
ABuffer: PUInt8 absolute AKey;
|
||||
a: UInt32 = 1;
|
||||
b: UInt32 = 0;
|
||||
n: Integer;
|
||||
begin
|
||||
for n := 0 to ALength -1 do
|
||||
begin
|
||||
a := (a + ABuffer[n]) mod MOD_ADLER;
|
||||
b := (b + a) mod MOD_ADLER;
|
||||
end;
|
||||
Result := (b shl 16) or a;
|
||||
end;
|
||||
|
||||
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
var
|
||||
c: PUInt8 absolute AKey;
|
||||
i: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
c := AKey;
|
||||
for i := 0 to ALength - 1 do
|
||||
begin
|
||||
Result := c^ + (Result shl 6) + (Result shl 16) {%H-}- Result;
|
||||
Inc(c);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ BobJenkinsHash }
|
||||
|
||||
{$define mix_abc :=
|
||||
a -= c; a := a xor (((c)shl(4)) or ((c)shr(32-(4)))); c += b;
|
||||
b -= a; b := b xor (((a)shl(6)) or ((a)shr(32-(6)))); a += c;
|
||||
c -= b; c := c xor (((b)shl(8)) or ((b)shr(32-(8)))); b += a;
|
||||
a -= c; a := a xor (((c)shl(16)) or ((c)shr(32-(16)))); c += b;
|
||||
b -= a; b := b xor (((a)shl(19)) or ((a)shr(32-(19)))); a += c;
|
||||
c -= b; c := c xor (((b)shl(4)) or ((b)shr(32-(4)))); b += a
|
||||
}
|
||||
|
||||
{$define final_abc :=
|
||||
c := c xor b; c -= (((b)shl(14)) or ((b)shr(32-(14))));
|
||||
a := a xor c; a -= (((c)shl(11)) or ((c)shr(32-(11))));
|
||||
b := b xor a; b -= (((a)shl(25)) or ((a)shr(32-(25))));
|
||||
c := c xor b; c -= (((b)shl(16)) or ((b)shr(32-(16))));
|
||||
a := a xor c; a -= (((c)shl(4)) or ((c)shr(32-(4))));
|
||||
b := b xor a; b -= (((a)shl(14)) or ((a)shr(32-(14))));
|
||||
c := c xor b; c -= (((b)shl(24)) or ((b)shr(32-(24))))
|
||||
}
|
||||
|
||||
function HashWord(
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
label
|
||||
Case0, Case1, Case2, Case3;
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $DEADBEEF + (UInt32(ALength) shl 2) + AInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
|
||||
//*------------------------------------------------- handle most of the key */
|
||||
while ALength > 3 do
|
||||
begin
|
||||
a += AKey[0];
|
||||
b += AKey[1];
|
||||
c += AKey[2];
|
||||
mix_abc;
|
||||
ALength -= 3;
|
||||
AKey += 3;
|
||||
end;
|
||||
|
||||
//*------------------------------------------- handle the last 3 uint32_t's */
|
||||
case ALength of //* all the case statements fall through */
|
||||
3: goto Case3;
|
||||
2: goto Case2;
|
||||
1: goto Case1;
|
||||
0: goto Case0;
|
||||
end;
|
||||
Case3: c+=AKey[2];
|
||||
Case2: b+=AKey[1];
|
||||
Case1: a+=AKey[0];
|
||||
final_abc;
|
||||
Case0: //* case 0: nothing left to add */
|
||||
//*------------------------------------------------------ report the result */
|
||||
Result := c;
|
||||
end;
|
||||
|
||||
procedure HashWord2 (
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
label
|
||||
Case0, Case1, Case2, Case3;
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $deadbeef + (UInt32(ALength shl 2)) + APrimaryHashAndInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
c += ASecondaryHashAndInitVal;
|
||||
|
||||
//*------------------------------------------------- handle most of the key */
|
||||
while ALength > 3 do
|
||||
begin
|
||||
a += AKey[0];
|
||||
b += AKey[1];
|
||||
c += AKey[2];
|
||||
mix_abc;
|
||||
ALength -= 3;
|
||||
AKey += 3;
|
||||
end;
|
||||
|
||||
//*------------------------------------------- handle the last 3 uint32_t's */
|
||||
case ALength of //* all the case statements fall through */
|
||||
3: goto Case3;
|
||||
2: goto Case2;
|
||||
1: goto Case1;
|
||||
0: goto Case0;
|
||||
end;
|
||||
Case3: c+=AKey[2];
|
||||
Case2: b+=AKey[1];
|
||||
Case1: a+=AKey[0];
|
||||
final_abc;
|
||||
Case0: //* case 0: nothing left to add */
|
||||
//*------------------------------------------------------ report the result */
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
end;
|
||||
|
||||
function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
|
||||
var
|
||||
a, b, c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label _10, _8, _6, _4, _2;
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
a := $DEADBEEF + UInt32(ALength) + AInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
|
||||
{$IFDEF ENDIAN_LITTLE}
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 : Exit(c); // zero length strings require no mixing
|
||||
end
|
||||
end
|
||||
else
|
||||
if (u.i and $1) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k16[0] + (UInt32(k16[1]) shl 16);
|
||||
b += k16[2] + (UInt32(k16[3]) shl 16);
|
||||
c += k16[4] + (UInt32(k16[5]) shl 16);
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k16 += 6;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12:
|
||||
begin
|
||||
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
11:
|
||||
begin
|
||||
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
||||
goto _10;
|
||||
end;
|
||||
10:
|
||||
begin _10:
|
||||
c+=k16[4];
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
9 :
|
||||
begin
|
||||
c+=k8[8]; //* fall through */
|
||||
goto _8;
|
||||
end;
|
||||
8 :
|
||||
begin _8:
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
7 :
|
||||
begin
|
||||
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
||||
goto _6;
|
||||
end;
|
||||
6 :
|
||||
begin _6:
|
||||
b+=k16[2];
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
5 :
|
||||
begin
|
||||
b+=k8[4]; //* fall through */
|
||||
goto _4;
|
||||
end;
|
||||
4 :
|
||||
begin _4:
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
3 :
|
||||
begin
|
||||
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
||||
goto _2;
|
||||
end;
|
||||
2 :
|
||||
begin _2:
|
||||
a+=k16[0];
|
||||
end;
|
||||
1 :
|
||||
begin
|
||||
a+=k8[0];
|
||||
end;
|
||||
0 : Exit(c); //* zero length requires no mixing */
|
||||
end;
|
||||
end
|
||||
else
|
||||
{$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 : Exit(c);
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
Result := c;
|
||||
end;
|
||||
|
||||
(*
|
||||
* hashlittle2: return 2 32-bit hash values
|
||||
*
|
||||
* This is identical to hashlittle(), except it returns two 32-bit hash
|
||||
* values instead of just one. This is good enough for hash table
|
||||
* lookup with 2^^64 buckets, or if you want a second hash if you're not
|
||||
* happy with the first, or if you want a probably-unique 64-bit ID for
|
||||
* the key. *pc is better mixed than *pb, so use *pc first. If you want
|
||||
* a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)".
|
||||
*)
|
||||
procedure HashLittle2(
|
||||
AKey: Pointer; //* the key to hash */
|
||||
ALength: SizeInt; //* length of the key */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label _10, _8, _6, _4, _2;
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $DEADBEEF + UInt32(ALength) + APrimaryHashAndInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
c += ASecondaryHashAndInitVal;
|
||||
|
||||
{$IFDEF ENDIAN_LITTLE}
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end
|
||||
end
|
||||
else
|
||||
if (u.i and $1) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k16[0] + (UInt32(k16[1]) shl 16);
|
||||
b += k16[2] + (UInt32(k16[3]) shl 16);
|
||||
c += k16[4] + (UInt32(k16[5]) shl 16);
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k16 += 6;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12:
|
||||
begin
|
||||
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
11:
|
||||
begin
|
||||
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
||||
goto _10;
|
||||
end;
|
||||
10:
|
||||
begin _10:
|
||||
c+=k16[4];
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
9 :
|
||||
begin
|
||||
c+=k8[8]; //* fall through */
|
||||
goto _8;
|
||||
end;
|
||||
8 :
|
||||
begin _8:
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
7 :
|
||||
begin
|
||||
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
||||
goto _6;
|
||||
end;
|
||||
6 :
|
||||
begin _6:
|
||||
b+=k16[2];
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
5 :
|
||||
begin
|
||||
b+=k8[4]; //* fall through */
|
||||
goto _4;
|
||||
end;
|
||||
4 :
|
||||
begin _4:
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
3 :
|
||||
begin
|
||||
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
||||
goto _2;
|
||||
end;
|
||||
2 :
|
||||
begin _2:
|
||||
a+=k16[0];
|
||||
end;
|
||||
1 :
|
||||
begin
|
||||
a+=k8[0];
|
||||
end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
{$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
end;
|
||||
|
||||
procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label _10, _8, _6, _4, _2;
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $DEADBEEF + UInt32(ALength shl 2) + APrimaryHashAndInitVal; // delphi version bug? original version don't have "shl 2"
|
||||
b := a;
|
||||
c := b;
|
||||
c += ASecondaryHashAndInitVal;
|
||||
|
||||
{$IFDEF ENDIAN_LITTLE}
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end
|
||||
end
|
||||
else
|
||||
if (u.i and $1) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k16[0] + (UInt32(k16[1]) shl 16);
|
||||
b += k16[2] + (UInt32(k16[3]) shl 16);
|
||||
c += k16[4] + (UInt32(k16[5]) shl 16);
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k16 += 6;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12:
|
||||
begin
|
||||
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
11:
|
||||
begin
|
||||
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
||||
goto _10;
|
||||
end;
|
||||
10:
|
||||
begin _10:
|
||||
c+=k16[4];
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
9 :
|
||||
begin
|
||||
c+=k8[8]; //* fall through */
|
||||
goto _8;
|
||||
end;
|
||||
8 :
|
||||
begin _8:
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
7 :
|
||||
begin
|
||||
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
||||
goto _6;
|
||||
end;
|
||||
6 :
|
||||
begin _6:
|
||||
b+=k16[2];
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
5 :
|
||||
begin
|
||||
b+=k8[4]; //* fall through */
|
||||
goto _4;
|
||||
end;
|
||||
4 :
|
||||
begin _4:
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
3 :
|
||||
begin
|
||||
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
||||
goto _2;
|
||||
end;
|
||||
2 :
|
||||
begin _2:
|
||||
a+=k16[0];
|
||||
end;
|
||||
1 :
|
||||
begin
|
||||
a+=k8[0];
|
||||
end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
{$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
end;
|
||||
|
||||
function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
|
||||
var
|
||||
a, b, c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
//k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
a := $DEADBEEF + UInt32(ALength shl 2) + AInitVal; // delphi version bug? original version don't have "shl 2"
|
||||
b := a;
|
||||
c := b;
|
||||
|
||||
{.$IFDEF ENDIAN_LITTLE} // Delphi version don't care
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 : Exit(c); // zero length strings require no mixing
|
||||
end
|
||||
end
|
||||
else
|
||||
{.$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 : Exit(c);
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
Result := Int32(c);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
144
packages/rtl-generics/src/generics.helpers.pas
Normal file
144
packages/rtl-generics/src/generics.helpers.pas
Normal file
@ -0,0 +1,144 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.Helpers;
|
||||
|
||||
{$MODE DELPHI}{$H+}
|
||||
{$MODESWITCH TYPEHELPERS}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
{ TValueAnsiStringHelper }
|
||||
|
||||
TValueAnsiStringHelper = record helper for AnsiString
|
||||
function ToLower: AnsiString; inline;
|
||||
end;
|
||||
|
||||
{ TValuewideStringHelper }
|
||||
|
||||
TValueWideStringHelper = record helper for WideString
|
||||
function ToLower: WideString; inline;
|
||||
end;
|
||||
|
||||
{ TValueUnicodeStringHelper }
|
||||
|
||||
TValueUnicodeStringHelper = record helper for UnicodeString
|
||||
function ToLower: UnicodeString; inline;
|
||||
end;
|
||||
|
||||
{ TValueShortStringHelper }
|
||||
|
||||
TValueShortStringHelper = record helper for ShortString
|
||||
function ToLower: ShortString; inline;
|
||||
end;
|
||||
|
||||
{ TValueUTF8StringHelper }
|
||||
|
||||
TValueUTF8StringHelper = record helper for UTF8String
|
||||
function ToLower: UTF8String; inline;
|
||||
end;
|
||||
|
||||
{ TValueRawByteStringHelper }
|
||||
|
||||
TValueRawByteStringHelper = record helper for RawByteString
|
||||
function ToLower: RawByteString; inline;
|
||||
end;
|
||||
|
||||
{ TValueUInt32Helper }
|
||||
|
||||
TValueUInt32Helper = record helper for UInt32
|
||||
class function GetSignMask: UInt32; static; inline;
|
||||
class function GetSizedSignMask(ABits: Byte): UInt32; static; inline;
|
||||
class function GetBitsLength: Byte; static; inline;
|
||||
|
||||
const
|
||||
SIZED_SIGN_MASK: array[1..32] of UInt32 = (
|
||||
$80000000, $C0000000, $E0000000, $F0000000, $F8000000, $FC000000, $FE000000, $FF000000,
|
||||
$FF800000, $FFC00000, $FFE00000, $FFF00000, $FFF80000, $FFFC0000, $FFFE0000, $FFFF0000,
|
||||
$FFFF8000, $FFFFC000, $FFFFE000, $FFFFF000, $FFFFF800, $FFFFFC00, $FFFFFE00, $FFFFFF00,
|
||||
$FFFFFF80, $FFFFFFC0, $FFFFFFE0, $FFFFFFF0, $FFFFFFF8, $FFFFFFFC, $FFFFFFFE, $FFFFFFFF);
|
||||
BITS_LENGTH = 32;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TRawDataStringHelper }
|
||||
|
||||
function TValueAnsiStringHelper.ToLower: AnsiString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueWideStringHelper }
|
||||
|
||||
function TValueWideStringHelper.ToLower: WideString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueUnicodeStringHelper }
|
||||
|
||||
function TValueUnicodeStringHelper.ToLower: UnicodeString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueShortStringHelper }
|
||||
|
||||
function TValueShortStringHelper.ToLower: ShortString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueUTF8StringHelper }
|
||||
|
||||
function TValueUTF8StringHelper.ToLower: UTF8String;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueRawByteStringHelper }
|
||||
|
||||
function TValueRawByteStringHelper.ToLower: RawByteString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueUInt32Helper }
|
||||
|
||||
class function TValueUInt32Helper.GetSignMask: UInt32;
|
||||
begin
|
||||
Result := $80000000;
|
||||
end;
|
||||
|
||||
class function TValueUInt32Helper.GetSizedSignMask(ABits: Byte): UInt32;
|
||||
begin
|
||||
Result := SIZED_SIGN_MASK[ABits];
|
||||
end;
|
||||
|
||||
class function TValueUInt32Helper.GetBitsLength: Byte;
|
||||
begin
|
||||
Result := BITS_LENGTH;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
236
packages/rtl-generics/src/generics.memoryexpanders.pas
Normal file
236
packages/rtl-generics/src/generics.memoryexpanders.pas
Normal file
@ -0,0 +1,236 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.MemoryExpanders;
|
||||
// Memory expanders
|
||||
|
||||
{$mode delphi}
|
||||
{$MACRO ON}
|
||||
{.$WARN 5024 OFF}
|
||||
{.$WARN 4079 OFF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
TProbeSequence = class
|
||||
public
|
||||
end;
|
||||
|
||||
{ TLinearProbing }
|
||||
|
||||
TLinearProbing = class(TProbeSequence)
|
||||
public
|
||||
class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline;
|
||||
|
||||
const MAX_LOAD_FACTOR = 1;
|
||||
const DEFAULT_LOAD_FACTOR = 0.75;
|
||||
end;
|
||||
|
||||
{ TQuadraticProbing }
|
||||
|
||||
TQuadraticProbing = class(TProbeSequence)
|
||||
private
|
||||
class constructor Create;
|
||||
public
|
||||
class var C1: UInt32;
|
||||
class var C2: UInt32;
|
||||
|
||||
class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline;
|
||||
|
||||
const MAX_LOAD_FACTOR = 0.5;
|
||||
const DEFAULT_LOAD_FACTOR = 0.5;
|
||||
end;
|
||||
|
||||
{ TDoubleHashing }
|
||||
|
||||
TDoubleHashing = class(TProbeSequence)
|
||||
public
|
||||
class function Probe(I, {%H-}M, Hash1: UInt32; Hash2: UInt32 = 1): UInt32; static; inline;
|
||||
|
||||
const MAX_LOAD_FACTOR = 1;
|
||||
const DEFAULT_LOAD_FACTOR = 0.85;
|
||||
end;
|
||||
|
||||
const
|
||||
// http://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
|
||||
// MultiplyDeBruijnBitPosition[uint32(((numberInt32 and -numberInt32) * $077CB531)) shr 27]
|
||||
MultiplyDeBruijnBitPosition: array[0..31] of Int32 =
|
||||
(
|
||||
0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
|
||||
31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
|
||||
);
|
||||
|
||||
// http://primes.utm.edu/lists/2small/0bit.html
|
||||
// http://www.math.niu.edu/~rusin/known-math/98/pi_x
|
||||
// http://oeis.org/A014234/
|
||||
PrimaryNumbersJustLessThanPowerOfTwo: array[0..31] of UInt32 =
|
||||
(
|
||||
0, 1, 3, 7, 13, 31, 61, 127, 251, 509, 1021, 2039, 4093, 8191, 16381, 32749, 65521, 131071,
|
||||
262139, 524287, 1048573, 2097143, 4194301, 8388593, 16777213, 33554393, 67108859,
|
||||
134217689, 268435399, 536870909, 1073741789, 2147483647
|
||||
);
|
||||
|
||||
// http://oeis.org/A014210
|
||||
// http://oeis.org/A203074
|
||||
PrimaryNumbersJustBiggerThanPowerOfTwo: array[0..31] of UInt32 = (
|
||||
2,3,5,11,17,37,67,131,257,521,1031,2053,4099,
|
||||
8209,16411,32771,65537,131101,262147,524309,
|
||||
1048583,2097169,4194319,8388617,16777259,33554467,
|
||||
67108879,134217757,268435459,536870923,1073741827,
|
||||
2147483659);
|
||||
|
||||
// Fibonacci numbers
|
||||
FibonacciNumbers: array[0..44] of UInt32 = (
|
||||
{0,1,1,2,3,}0,5,8,13,21,34,55,89,144,233,377,610,987,
|
||||
1597,2584,4181,6765,10946,17711,28657,46368,75025,
|
||||
121393,196418,317811,514229,832040,1346269,
|
||||
2178309,3524578,5702887,9227465,14930352,24157817,
|
||||
39088169, 63245986, 102334155, 165580141, 267914296,
|
||||
433494437, 701408733, 1134903170, 1836311903, 2971215073,
|
||||
{! not fib number - this is memory limit} 4294967295);
|
||||
|
||||
// Largest prime not exceeding Fibonacci(n)
|
||||
// http://oeis.org/A138184/list
|
||||
// http://www.numberempire.com/primenumbers.php
|
||||
PrimaryNumbersJustLessThanFibonacciNumbers: array[0..44] of UInt32 = (
|
||||
{! not correlated to fib number. For empty table} 0,
|
||||
5,7,13,19,31,53,89,139,233,373,607,983,1597,
|
||||
2579,4177,6763,10939,17707,28657,46351,75017,
|
||||
121379,196387,317797,514229,832003,1346249,
|
||||
2178283,3524569,5702867,9227443,14930341,24157811,
|
||||
39088157,63245971,102334123,165580123,267914279,
|
||||
433494437,701408717,1134903127,1836311879,2971215073,
|
||||
{! not correlated to fib number - this is prime memory limit} 4294967291);
|
||||
|
||||
// Smallest prime >= n-th Fibonacci number.
|
||||
// http://oeis.org/A138185
|
||||
PrimaryNumbersJustBiggerThanFibonacciNumbers: array[0..44] of UInt32 = (
|
||||
{! not correlated to fib number. For empty table} 0,
|
||||
5,11,13,23,37,59,89,149,233,379,613,
|
||||
991,1597,2591,4201,6779,10949,17713,28657,46381,
|
||||
75029,121403,196429,317827,514229,832063,1346273,
|
||||
2178313,3524603,5702897,9227479,14930387,24157823,
|
||||
39088193,63245989,102334157,165580147,267914303,
|
||||
433494437,701408753,1134903179,1836311951,2971215073,
|
||||
{! not correlated to fib number - this is prime memory limit} 4294967291);
|
||||
|
||||
type
|
||||
|
||||
{ TCuckooHashingCfg }
|
||||
|
||||
TCuckooHashingCfg = class
|
||||
public
|
||||
const D = 2;
|
||||
const MAX_LOAD_FACTOR = 0.5;
|
||||
|
||||
class function LoadFactor(M: Integer): Integer; virtual;
|
||||
end;
|
||||
|
||||
TStdCuckooHashingCfg = class(TCuckooHashingCfg)
|
||||
public
|
||||
const MAX_LOOP = 1000;
|
||||
end;
|
||||
|
||||
TDeamortizedCuckooHashingCfg = class(TCuckooHashingCfg)
|
||||
public
|
||||
const L = 5;
|
||||
end;
|
||||
|
||||
TDeamortizedCuckooHashingCfg_D2 = TDeamortizedCuckooHashingCfg;
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D4 }
|
||||
|
||||
TDeamortizedCuckooHashingCfg_D4 = class(TDeamortizedCuckooHashingCfg)
|
||||
public
|
||||
const D = 4;
|
||||
const L = 20;
|
||||
const MAX_LOAD_FACTOR = 0.9;
|
||||
|
||||
class function LoadFactor(M: Integer): Integer; override;
|
||||
end;
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D6 }
|
||||
|
||||
TDeamortizedCuckooHashingCfg_D6 = class(TDeamortizedCuckooHashingCfg)
|
||||
public
|
||||
const D = 6;
|
||||
const L = 170;
|
||||
const MAX_LOAD_FACTOR = 0.99;
|
||||
|
||||
class function LoadFactor(M: Integer): Integer; override;
|
||||
end;
|
||||
|
||||
TL5CuckooHashingCfg = class(TCuckooHashingCfg)
|
||||
public
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D6 }
|
||||
|
||||
class function TDeamortizedCuckooHashingCfg_D6.LoadFactor(M: Integer): Integer;
|
||||
begin
|
||||
Result:=Pred(Round(MAX_LOAD_FACTOR*M));
|
||||
end;
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D4 }
|
||||
|
||||
class function TDeamortizedCuckooHashingCfg_D4.LoadFactor(M: Integer): Integer;
|
||||
begin
|
||||
Result:=Pred(Round(MAX_LOAD_FACTOR*M));
|
||||
end;
|
||||
|
||||
{ TCuckooHashingCfg }
|
||||
|
||||
class function TCuckooHashingCfg.LoadFactor(M: Integer): Integer;
|
||||
begin
|
||||
Result := Pred(M shr 1);
|
||||
end;
|
||||
|
||||
{ TLinearProbing }
|
||||
|
||||
class function TLinearProbing.Probe(I, M, Hash: UInt32): UInt32;
|
||||
begin
|
||||
Result := (Hash + I)
|
||||
end;
|
||||
|
||||
{ TQuadraticProbing }
|
||||
|
||||
class constructor TQuadraticProbing.Create;
|
||||
begin
|
||||
C1 := 1;
|
||||
C2 := 1;
|
||||
end;
|
||||
|
||||
class function TQuadraticProbing.Probe(I, M, Hash: UInt32): UInt32;
|
||||
begin
|
||||
Result := (Hash + C1 * I {%H-}+ C2 * Sqr(I));
|
||||
end;
|
||||
|
||||
{ TDoubleHashingNoMod }
|
||||
|
||||
class function TDoubleHashing.Probe(I, M, Hash1: UInt32; Hash2: UInt32): UInt32;
|
||||
begin
|
||||
Result := Hash1 + I * Hash2;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
34
packages/rtl-generics/src/generics.strings.pas
Normal file
34
packages/rtl-generics/src/generics.strings.pas
Normal file
@ -0,0 +1,34 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.Strings;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
resourcestring
|
||||
SArgumentOutOfRange = 'Argument out of range';
|
||||
SDuplicatesNotAllowed = 'Duplicates not allowed in dictionary';
|
||||
SDictionaryKeyDoesNotExist = 'Dictionary key does not exist';
|
||||
SItemNotFound = 'Item not found';
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
|
||||
1859
packages/rtl-generics/src/inc/generics.dictionaries.inc
Normal file
1859
packages/rtl-generics/src/inc/generics.dictionaries.inc
Normal file
File diff suppressed because it is too large
Load Diff
533
packages/rtl-generics/src/inc/generics.dictionariesh.inc
Normal file
533
packages/rtl-generics/src/inc/generics.dictionariesh.inc
Normal file
@ -0,0 +1,533 @@
|
||||
{%MainUnit generics.collections.pas}
|
||||
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$WARNINGS OFF}
|
||||
type
|
||||
TEmptyRecord = record // special record for Dictionary TValue (Dictionary as Set)
|
||||
end;
|
||||
|
||||
{ TPair }
|
||||
|
||||
TPair<TKey, TValue> = record
|
||||
public
|
||||
Key: TKey;
|
||||
Value: TValue;
|
||||
class function Create(AKey: TKey; AValue: TValue): TPair<TKey, TValue>; static;
|
||||
end;
|
||||
|
||||
{ TCustomDictionary }
|
||||
|
||||
// bug #24283 and #24097 (forward declaration) - should be:
|
||||
// TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> = class(TEnumerable<TPair<TKey, TValue> >);
|
||||
TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract
|
||||
public type
|
||||
// workaround... no generics types in generics types
|
||||
TDictionaryPair = TPair<TKey, TValue>;
|
||||
PDictionaryPair = ^TDictionaryPair;
|
||||
PKey = ^TKey;
|
||||
PValue = ^TValue;
|
||||
THashFactoryClass = THashFactory;
|
||||
public
|
||||
FItemsLength: SizeInt;
|
||||
FEqualityComparer: IEqualityComparer<TKey>;
|
||||
FKeys: TEnumerable<TKey>;
|
||||
FValues: TEnumerable<TValue>;
|
||||
FMaxLoadFactor: single;
|
||||
protected
|
||||
procedure SetCapacity(ACapacity: SizeInt); virtual; abstract;
|
||||
// bug #24283. workaround for this class because can't inherit from TEnumerable
|
||||
function DoGetEnumerator: TEnumerator<TDictionaryPair>; virtual; abstract; {override;}
|
||||
|
||||
procedure SetMaxLoadFactor(AValue: single); virtual; abstract;
|
||||
function GetLoadFactor: single; virtual; abstract;
|
||||
function GetCapacity: SizeInt; virtual; abstract;
|
||||
public
|
||||
property MaxLoadFactor: single read FMaxLoadFactor write SetMaxLoadFactor;
|
||||
property LoadFactor: single read GetLoadFactor;
|
||||
property Capacity: SizeInt read GetCapacity write SetCapacity;
|
||||
|
||||
property Count: SizeInt read FItemsLength;
|
||||
|
||||
procedure Clear; virtual; abstract;
|
||||
procedure Add(constref APair: TPair<TKey, TValue>); virtual; abstract;
|
||||
strict private // bug #24283. workaround for this class because can't inherit from TEnumerable
|
||||
function ToArray(ACount: SizeInt): TArray<TDictionaryPair>; overload;
|
||||
public
|
||||
function ToArray: TArray<TDictionaryPair>; virtual; final; {override; final; // bug #24283} overload;
|
||||
|
||||
constructor Create; virtual; overload;
|
||||
constructor Create(ACapacity: SizeInt); virtual; overload;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); virtual; overload;
|
||||
constructor Create(const AComparer: IEqualityComparer<TKey>); overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>); virtual; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); virtual; overload;
|
||||
|
||||
destructor Destroy; override;
|
||||
private
|
||||
FOnKeyNotify: TCollectionNotifyEvent<TKey>;
|
||||
FOnValueNotify: TCollectionNotifyEvent<TValue>;
|
||||
protected
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); virtual; abstract;
|
||||
|
||||
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); virtual;
|
||||
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); virtual;
|
||||
procedure PairNotify(constref APair: TPair<TKey, TValue>; ACollectionNotification: TCollectionNotification); inline;
|
||||
procedure SetValue(var AValue: TValue; constref ANewValue: TValue);
|
||||
public
|
||||
property OnKeyNotify: TCollectionNotifyEvent<TKey> read FOnKeyNotify write FOnKeyNotify;
|
||||
property OnValueNotify: TCollectionNotifyEvent<TValue> read FOnValueNotify write FOnValueNotify;
|
||||
end;
|
||||
|
||||
{ TCustomDictionaryEnumerator }
|
||||
|
||||
TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerator< T >)
|
||||
private
|
||||
FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>;
|
||||
FIndex: SizeInt;
|
||||
protected
|
||||
function DoGetCurrent: T; override;
|
||||
function GetCurrent: T; virtual; abstract;
|
||||
public
|
||||
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
end;
|
||||
|
||||
{ TDictionaryEnumerable }
|
||||
|
||||
TDictionaryEnumerable<TDictionaryEnumerator: TObject; // ... inherits from TCustomDictionaryEnumerator. workaround...
|
||||
T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerable<T>)
|
||||
private
|
||||
FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>;
|
||||
function GetCount: SizeInt;
|
||||
public
|
||||
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
function DoGetEnumerator: TDictionaryEnumerator; override;
|
||||
function ToArray: TArray<T>; override; final;
|
||||
property Count: SizeInt read GetCount;
|
||||
end;
|
||||
|
||||
// more info : http://en.wikipedia.org/wiki/Open_addressing
|
||||
|
||||
{ TDictionaryEnumerable }
|
||||
|
||||
TOpenAddressingEnumerator<T, OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
protected
|
||||
function DoMoveNext: Boolean; override;
|
||||
end;
|
||||
|
||||
TOnGetMemoryLayoutKeyPosition = procedure(Sender: TObject; AKeyPos: UInt32) of object;
|
||||
|
||||
TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
private type
|
||||
PItem = ^TItem;
|
||||
TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
|
||||
TItemsArray = array of TItem;
|
||||
private var
|
||||
FItemsThreshold: SizeInt;
|
||||
FItems: TItemsArray;
|
||||
|
||||
procedure Resize(ANewSize: SizeInt);
|
||||
function PrepareAddingItem: SizeInt;
|
||||
protected
|
||||
function RealItemsLength: SizeInt; virtual;
|
||||
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; virtual;
|
||||
function FindBucketIndex(constref AKey: TKey): SizeInt; overload; inline;
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; out AHash: UInt32): SizeInt; virtual; abstract; overload;
|
||||
public
|
||||
type
|
||||
// Enumerators
|
||||
TPairEnumerator = class(TOpenAddressingEnumerator<TDictionaryPair, OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TPair<TKey,TValue>; override;
|
||||
end;
|
||||
|
||||
TValueEnumerator = class(TOpenAddressingEnumerator<TValue, OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TValue; override;
|
||||
end;
|
||||
|
||||
TKeyEnumerator = class(TOpenAddressingEnumerator<TKey, OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TKey; override;
|
||||
end;
|
||||
|
||||
// Collections
|
||||
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
// bug #24283 - workaround related to lack of DoGetEnumerator
|
||||
function GetEnumerator: TPairEnumerator; reintroduce;
|
||||
private
|
||||
function GetKeys: TKeyCollection;
|
||||
function GetValues: TValueCollection;
|
||||
private
|
||||
function GetItem(const AKey: TKey): TValue; inline;
|
||||
procedure SetItem(const AKey: TKey; const AValue: TValue); inline;
|
||||
procedure AddItem(var AItem: TItem; constref AKey: TKey; constref AValue: TValue; const AHash: UInt32); inline;
|
||||
protected
|
||||
// useful for using dictionary as array
|
||||
function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; virtual;
|
||||
function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; virtual;
|
||||
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); override;
|
||||
|
||||
procedure SetCapacity(ACapacity: SizeInt); override;
|
||||
// bug #24283 - can't descadent from TEnumerable
|
||||
function DoGetEnumerator: TEnumerator<TDictionaryPair>; override;
|
||||
procedure SetMaxLoadFactor(AValue: single); override;
|
||||
function GetLoadFactor: single; override;
|
||||
function GetCapacity: SizeInt; override;
|
||||
public
|
||||
// many constructors because bug #25607
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
|
||||
procedure Add(constref APair: TPair<TKey, TValue>); override; overload;
|
||||
procedure Add(constref AKey: TKey; constref AValue: TValue); overload; inline;
|
||||
procedure Remove(constref AKey: TKey);
|
||||
function ExtractPair(constref AKey: TKey): TPair<TKey, TValue>;
|
||||
procedure Clear; override;
|
||||
procedure TrimExcess;
|
||||
function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean;
|
||||
procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue);
|
||||
function ContainsKey(constref AKey: TKey): Boolean; inline;
|
||||
function ContainsValue(constref AValue: TValue): Boolean; overload;
|
||||
function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer<TValue>): Boolean; virtual; overload;
|
||||
|
||||
property Items[Index: TKey]: TValue read GetItem write SetItem; default;
|
||||
property Keys: TKeyCollection read GetKeys;
|
||||
property Values: TValueCollection read GetValues;
|
||||
|
||||
procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition);
|
||||
end;
|
||||
|
||||
TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
protected
|
||||
procedure NotifyIndexChange(AFrom, ATo: SizeInt); virtual;
|
||||
function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override;
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; out AHash: UInt32): SizeInt; override; overload;
|
||||
end;
|
||||
|
||||
// More info and TODO
|
||||
// https://github.com/OpenHFT/UntitledCollectionsProject/wiki/Tombstones-purge-from-hashtable:-theory-and-practice
|
||||
|
||||
TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private
|
||||
FTombstonesCount: SizeInt;
|
||||
protected
|
||||
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; override;
|
||||
function RealItemsLength: SizeInt; override;
|
||||
|
||||
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; virtual; abstract;
|
||||
|
||||
function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override;
|
||||
function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; override;
|
||||
public
|
||||
property TombstonesCount: SizeInt read FTombstonesCount;
|
||||
procedure ClearTombstones; virtual;
|
||||
procedure Clear; override;
|
||||
end;
|
||||
|
||||
TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
protected
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override; overload;
|
||||
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override;
|
||||
end;
|
||||
|
||||
TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
private
|
||||
R: UInt32;
|
||||
protected
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); override;
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override; overload;
|
||||
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override;
|
||||
strict protected
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
public // bug #26181 (redundancy of constructors)
|
||||
constructor Create(ACapacity: SizeInt); override; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
end;
|
||||
|
||||
TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
TItemsArray = array of TItem;
|
||||
private
|
||||
FMainIndex: SizeInt;
|
||||
protected
|
||||
function DoMoveNext: Boolean; override;
|
||||
public
|
||||
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
end;
|
||||
|
||||
// more info :
|
||||
// http://arxiv.org/abs/0903.0391
|
||||
|
||||
TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> = class(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
private const // Lookup Result
|
||||
LR_NIL = -1;
|
||||
LR_QUEUE = -2;
|
||||
private type
|
||||
PItem = ^TItem;
|
||||
TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
TValueForQueue = TItem;
|
||||
|
||||
TQueueDictionary = class(TOpenAddressingLP<TKey, TValueForQueue, TDelphiHashFactory, TLinearProbing>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValueForQueue>;
|
||||
end;
|
||||
private
|
||||
FIdx: TList<UInt32>; // list to keep order
|
||||
protected
|
||||
procedure NotifyIndexChange(AFrom, ATo: SizeInt); override;
|
||||
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): Boolean; override;
|
||||
public
|
||||
procedure InsertIntoBack(AItem: Pointer);
|
||||
procedure InsertIntoHead(AItem: Pointer);
|
||||
function IsEmpty: Boolean;
|
||||
function Pop: Pointer;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
// cycle-detection mechanism class
|
||||
TCDM = class(TOpenAddressingSH<TKey, TEmptyRecord, TDelphiHashFactory, TLinearProbing>);
|
||||
TItemsArray = array of TItem;
|
||||
TItemsDArray = array[0..Pred(TCuckooCfg.D)] of TItemsArray;
|
||||
private var
|
||||
FQueue: TQueueDictionary; // probably can be optimized - hash TItem give information from TItem.Hash for cuckoo ...
|
||||
// currently is kept in "TQueueDictionary = class(TOpenAddressingSH<TKey, TItem, ...>"
|
||||
|
||||
FCDM: TCDM; // cycle-detection mechanism
|
||||
FItemsThreshold: SizeInt;
|
||||
FItems: TItemsDArray;
|
||||
// sadly there is bug #24848 for class var ...
|
||||
{class} var
|
||||
CUCKOO_SIGN, CUCKOO_INDEX_SIZE, CUCKOO_HASH_SIGN: UInt32;
|
||||
// CUCKOO_MAX_ITEMS_LENGTH: <- to do : calc max length for items based on CUCKOO sign
|
||||
// maybe some CDM bloom filter?
|
||||
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); override;
|
||||
procedure Resize(ANewSize: SizeInt);
|
||||
procedure Rehash(ASizePow2: SizeInt);
|
||||
function PrepareAddingItem: SizeInt;
|
||||
protected
|
||||
function Lookup(constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; inline; overload;
|
||||
function Lookup(constref AItems: TItemsDArray; constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; virtual; overload;
|
||||
public
|
||||
type
|
||||
// Enumerators
|
||||
TPairEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TDictionaryPair, CUCKOO_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TPair<TKey,TValue>; override;
|
||||
end;
|
||||
|
||||
TValueEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TValue, CUCKOO_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TValue; override;
|
||||
end;
|
||||
|
||||
TKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TKey, CUCKOO_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TKey; override;
|
||||
end;
|
||||
|
||||
// Collections
|
||||
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
// bug #24283 - workaround related to lack of DoGetEnumerator
|
||||
function GetEnumerator: TPairEnumerator; reintroduce;
|
||||
private
|
||||
function GetKeys: TKeyCollection;
|
||||
function GetValues: TValueCollection;
|
||||
private
|
||||
function GetItem(const AKey: TKey): TValue; inline;
|
||||
procedure SetItem(const AKey: TKey; const AValue: TValue); overload; inline;
|
||||
procedure SetItem(constref AValue: TValue; const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); overload;
|
||||
|
||||
procedure AddItem(constref AItems: TItemsDArray; constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload;
|
||||
procedure DoAdd(constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload; inline;
|
||||
function DoRemove(const AHashListOrIndex: PUInt32; ALookupResult: SizeInt;
|
||||
ACollectionNotification: TCollectionNotification): TValue;
|
||||
|
||||
function GetQueueCount: SizeInt;
|
||||
protected
|
||||
procedure SetCapacity(ACapacity: SizeInt); override;
|
||||
// bug #24283 - can't descadent from TEnumerable
|
||||
function DoGetEnumerator: TEnumerator<TDictionaryPair>; override;
|
||||
procedure SetMaxLoadFactor(AValue: single); override;
|
||||
function GetLoadFactor: single; override;
|
||||
function GetCapacity: SizeInt; override;
|
||||
strict protected // bug #26181
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
public
|
||||
// TODO: function TryFlushQueue(ACount: SizeInt): SizeInt;
|
||||
|
||||
constructor Create; override; overload;
|
||||
constructor Create(ACapacity: SizeInt); override; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure Add(constref APair: TPair<TKey, TValue>); override; overload;
|
||||
procedure Add(constref AKey: TKey; constref AValue: TValue); overload;
|
||||
procedure Remove(constref AKey: TKey);
|
||||
function ExtractPair(constref AKey: TKey): TPair<TKey, TValue>;
|
||||
procedure Clear; override;
|
||||
procedure TrimExcess;
|
||||
function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean;
|
||||
procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue);
|
||||
function ContainsKey(constref AKey: TKey): Boolean; inline;
|
||||
function ContainsValue(constref AValue: TValue): Boolean; overload;
|
||||
function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer<TValue>): Boolean; virtual; overload;
|
||||
|
||||
property Items[Index: TKey]: TValue read GetItem write SetItem; default;
|
||||
property Keys: TKeyCollection read GetKeys;
|
||||
property Values: TValueCollection read GetValues;
|
||||
|
||||
property QueueCount: SizeInt read GetQueueCount;
|
||||
procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition);
|
||||
end;
|
||||
|
||||
TDictionaryOwnerships = set of (doOwnsKeys, doOwnsValues);
|
||||
|
||||
TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> = class(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>)
|
||||
private
|
||||
FOwnerships: TDictionaryOwnerships;
|
||||
protected
|
||||
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override;
|
||||
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override;
|
||||
public
|
||||
// can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)"
|
||||
// because bug #25607
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships;
|
||||
const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt;
|
||||
const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
end;
|
||||
|
||||
TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private
|
||||
FOwnerships: TDictionaryOwnerships;
|
||||
protected
|
||||
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override;
|
||||
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override;
|
||||
public
|
||||
// can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)"
|
||||
// because bug #25607
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships;
|
||||
const AComparer: IEqualityComparer<TKey>); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt;
|
||||
const AComparer: IEqualityComparer<TKey>); overload;
|
||||
end;
|
||||
|
||||
// useful generics overloads
|
||||
TOpenAddressingLP<TKey, TValue, THashFactory> = class(TOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>);
|
||||
TOpenAddressingLP<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
|
||||
|
||||
TObjectOpenAddressingLP<TKey, TValue, THashFactory> = class(TObjectOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>);
|
||||
TObjectOpenAddressingLP<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
|
||||
|
||||
// Linear Probing with Tombstones (LPT)
|
||||
TOpenAddressingLPT<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TLinearProbing>);
|
||||
TOpenAddressingLPT<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
|
||||
|
||||
TOpenAddressingQP<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TQuadraticProbing>);
|
||||
TOpenAddressingQP<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TQuadraticProbing>);
|
||||
|
||||
TOpenAddressingDH<TKey, TValue, THashFactory> = class(TOpenAddressingDH<TKey, TValue, THashFactory, TDoubleHashing>);
|
||||
TOpenAddressingDH<TKey, TValue> = class(TOpenAddressingDH<TKey, TValue, TDelphiDoubleHashFactory, TDoubleHashing>);
|
||||
|
||||
TCuckooD2<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
TCuckooD2<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiDoubleHashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
|
||||
TCuckooD4<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
TCuckooD4<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiQuadrupleHashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
|
||||
TCuckooD6<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
TCuckooD6<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiSixfoldHashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
|
||||
TObjectCuckooD2<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
TObjectCuckooD2<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiDoubleHashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
|
||||
TObjectCuckooD4<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
TObjectCuckooD4<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiQuadrupleHashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
|
||||
TObjectCuckooD6<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
TObjectCuckooD6<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiSixfoldHashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
|
||||
// for normal programmers to normal use =)
|
||||
TDictionary<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue>);
|
||||
TObjectDictionary<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue>);
|
||||
|
||||
TFastHashMap<TKey, TValue> = class(TCuckooD2<TKey, TValue>);
|
||||
TFastObjectHashMap<TKey, TValue> = class(TObjectCuckooD2<TKey, TValue>);
|
||||
|
||||
THashMap<TKey, TValue> = class(TCuckooD4<TKey, TValue>);
|
||||
TObjectHashMap<TKey, TValue> = class(TObjectCuckooD4<TKey, TValue>);
|
||||
|
||||
var
|
||||
EmptyRecord: TEmptyRecord;
|
||||
Loading…
Reference in New Issue
Block a user