Skip to content

Commit

Permalink
Array unique fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
@ollydev
ollydev committed Feb 18, 2024
1 parent 8bbcadc commit ba3d2db
Show file tree
Hide file tree
Showing 7 changed files with 217 additions and 115 deletions.
239 changes: 132 additions & 107 deletions Source/algorithms/simba.algo_unique.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,179 +10,204 @@
interface

uses
Classes, SysUtils, Math, TypInfo,
simba.base;
Classes, SysUtils, TypInfo,
simba.base, simba.math;

type
generic THashFunc<_T> = function(const Value: _T): UInt32;
generic TEqualsFunc<_T> = function(const L,R: _T): Boolean;

generic procedure _Unique_HashFunc<_T>(var P: Pointer; HashFunc: specialize THashFunc<_T>);
generic procedure _Unique_EqualsFunc<_T>(var P: Pointer; EqualsFunc: specialize TEqualsFunc<_T>);
generic procedure _Unique<_T>(var Arr: specialize TArray<_T>); // Just uses = operator

generic function Unique<_T>(const Arr: specialize TArray<_T>): specialize TArray<_T>;

function Algo_Unique_Points(const Arr: TPointArray): TPointArray;
function Algo_Unique_Integer(const Arr: TIntegerArray): TIntegerArray;
function Algo_Unique_String(const Arr: TStringArray): TStringArray;
// Sadly need to on global symtable for generics
function _HashAStr(const Value: String): UInt32;
function _HashInt(const Value: Integer): UInt32;
function _HashInt64(const Value: Int64): UInt32;

function _SameSingle(const A,B: Single): Boolean;
function _SameDouble(const A,B: Double): Boolean;

implementation

uses
simba.array_point, simba.arraybuffer, simba.math, simba.matrix_bool;
const
EZeroResolution = 1E-16;
DZeroResolution = 1E-12;
SZeroResolution = 1E-4;

generic function Unique<_T>(const Arr: specialize TArray<_T>): specialize TArray<_T>;
// FNV
function _HashAStr(const Value: String): UInt32;
var
VarType: (OTHER, SINGLE, DOUBLE);

function IsEquals(constref A, B: _T): Boolean;
I: Int32;
begin
Result := 2166136261;
for I := 1 to Length(Value) do
begin
case VarType of
SINGLE: Result := SameValue(PSingle(@A)^, PSingle(@B)^);
DOUBLE: Result := SameValue(PDouble(@A)^, PDouble(@B)^);
OTHER: Result := (A = B);
end;
Result := Result xor Byte(Value[I]);
Result := Result * 16777619;
end;
end;

var
I, J, Last: Integer;
function _HashInt(const Value: Integer): UInt32;
begin
case GetTypeData(TypeInfo(_T))^.FloatType of
ftSingle: VarType := SINGLE;
ftDouble: VarType := DOUBLE;
else
VarType := OTHER;
end;

Result := Copy(Arr);

Last := Length(Result);
I := 0;
while (I < Last) do
begin
J := I + 1;
while (J < Last) do
begin
if IsEquals(Result[I], Result[J]) then
begin
Result[J] := Result[Last - 1];
Result := Value;
end;

Dec(Last);
Dec(J);
end;
function _HashInt64(const Value: Int64): UInt32;
begin
Result := Value;
end;

Inc(J);
end;
Inc(I);
end;
function _SameSingle(const A, B: Single): Boolean;
begin
if (A > B) then
Result:=((A-B) <= SZeroResolution)
else
Result:=((B-A) <= SZeroResolution);
end;

SetLength(Result, Last);
function _SameDouble(const A, B: Double): Boolean;
begin
if (A > B) then
Result:=((A-B) <= DZeroResolution)
else
Result:=((B-A) <= DZeroResolution);
end;

function Algo_Unique_Points(const Arr: TPointArray): TPointArray;
generic procedure _Unique_EqualsFunc<_T>(var P: Pointer; EqualsFunc: specialize TEqualsFunc<_T>);
type
TArr = specialize TArray<_T>;
var
Matrix: TBooleanMatrix;
I, Count: Integer;
Arr: TArr absolute P;
I, J, Len, NewLen: Integer;
begin
Result := Default(TPointArray);

if (Length(Arr) > 0) then
Len := Length(Arr);
NewLen := 0;
for I := 0 to Len - 1 do
begin
SetLength(Result, Length(Arr));

Count := 0;
with Arr.Bounds() do
J := 0;
while (J < NewLen) do
begin
Matrix.SetSize(Width, Height);

for I := 0 to High(Arr) do
if not Matrix[Arr[I].Y - Y1, Arr[I].X - X1] then
begin
Matrix[Arr[I].Y - Y1, Arr[I].X - X1] := True;
Result[Count] := Arr[I];
Inc(Count);
end;
if EqualsFunc(Arr[I], Arr[J]) then
Break;
Inc(J);
end;

SetLength(Result, Count);
if (J = NewLen) then
begin
Arr[NewLen] := Arr[I];
Inc(NewLen);
end;
end;

SetLength(Arr, NewLen);
end;

function Algo_Unique_Integer(const Arr: TIntegerArray): TIntegerArray;
generic procedure _Unique_HashFunc<_T>(var P: Pointer; HashFunc: specialize THashFunc<_T>);
type
TArr = specialize TArray<_T>;
var
I, J, Size: Integer;
Value: Integer;
Arr: TArr absolute P;
I, J, Total: Integer;
Value: _T;
Table: array of record
Bucket: TIntegerArray;
Bucket: array of _T;
Count: Integer;
end;
Buffer: TSimbaIntegerBuffer;
label
Next;
begin
Buffer.Init();

Total := 0;
SetLength(Table, NextPower2(Length(Arr)));
Size := High(Table);

for i := 0 to High(Arr) do
for I := 0 to High(Arr) do
begin
Value := Arr[i];
Value := Arr[I];

with Table[Value and Size] do
with Table[HashFunc(Value) and High(Table)] do
begin
// check if seen before
for J := 0 to Count - 1 do
if (Value = Bucket[J]) then
goto Next;

// not seen before: Add to bucket and result.
if (Count >= Length(Bucket)) then
SetLength(Bucket, 4 + (Length(Bucket) * 2));

Bucket[Count] := Value;
Inc(Count);

Buffer.Add(Value);
Arr[Total] := Value;
Inc(Total);
end;

Next:
end;

Result := Buffer.ToArray(False);
SetLength(Arr, Total);
end;

function Algo_Unique_String(const Arr: TStringArray): TStringArray;
generic procedure _Unique<_T>(var Arr: specialize TArray<_T>);
var
I, J, Size: Integer;
Value: String;
Table: array of record
Bucket: TStringArray;
Count: Integer;
end;
Buffer: TSimbaStringBuffer;
label
Next;
I, J, NewLen: Integer;
begin
Buffer.Init();

SetLength(Table, NextPower2(Length(Arr)));
Size := High(Table);
NewLen := 0;

for i := 0 to High(Arr) do
for I := 0 to High(Arr) do
begin
Value := Arr[i];
J := 0;
while (J < NewLen) do
begin
if (Arr[I] = Arr[J]) then
Break;
Inc(J);
end;

with Table[Value.Hash() and Size] do
if (J = NewLen) then
begin
for J := 0 to Count - 1 do
if (Value = Bucket[J]) then
goto Next;
Arr[NewLen] := Arr[I];
Inc(NewLen);
end;
end;

if (Count >= Length(Bucket)) then
SetLength(Bucket, 4 + (Length(Bucket) * 2));
SetLength(Arr, NewLen);
end;

Bucket[Count] := Value;
Inc(Count);
generic function Unique<_T>(const Arr: specialize TArray<_T>): specialize TArray<_T>;
type
{$scopedenums on}
EVarType = (OTHER, SINGLE, DOUBLE, INT, INT64, ASTRING);
{$scopedenums off}

Buffer.Add(Value);
function GetVarType: EVarType;
begin
Result := EVarType.OTHER;
case GetTypeKind(_T) of
tkFloat:
case GetTypeData(TypeInfo(_T))^.FloatType of
ftSingle: Result := EVarType.SINGLE;
ftDouble: Result := EVarType.DOUBLE;
end;
tkInteger: Result := EVarType.INT;
tkInt64: Result := EVarType.INT64;
tkAString: Result := EVarType.ASTRING;
end;

Next:
end;

Result := Buffer.ToArray(False);
begin
Result := Copy(Arr);

case GetVarType() of
EVarType.SINGLE: specialize _Unique_EqualsFunc<Single>(Pointer(Result), @_SameSingle);
EVarType.DOUBLE: specialize _Unique_EqualsFunc<Double>(Pointer(Result), @_SameDouble);
EVarType.INT: specialize _Unique_HashFunc<Integer>(Pointer(Result), @_HashInt);
EVarType.INT64: specialize _Unique_HashFunc<Int64>(Pointer(Result), @_HashInt64);
EVarType.ASTRING: specialize _Unique_HashFunc<String>(Pointer(Result), @_HashAStr);
else specialize _Unique<_T>(Result);
end;
end;

end.
Expand Down
13 changes: 11 additions & 2 deletions Source/array/simba.array_ord.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ interface

uses
Classes, SysUtils,
simba.base;
simba.base, simba.colormath;

type
TIntegerArrayHelper = type helper for TIntegerArray
Expand All @@ -25,6 +25,10 @@ interface
procedure Sort;
end;

TColorArrayHelper = type helper for TColorArray
function Unique: TColorArray;
end;

TSingleArrayHelper = type helper for TSingleArray
function Equals(Other: TSingleArray): Boolean;
function IndexOf(Value: Single): Integer;
Expand Down Expand Up @@ -85,14 +89,19 @@ function TIntegerArrayHelper.Sum: Int64;

function TIntegerArrayHelper.Unique: TIntegerArray;
begin
Result := Algo_Unique_Integer(Self);
Result := specialize Unique<Integer>(Self);
end;

procedure TIntegerArrayHelper.Sort;
begin
specialize QuickSort<Integer>(Self, Low(Self), High(Self));
end;

function TColorArrayHelper.Unique: TColorArray;
begin
Result := specialize Unique<TColor>(Self);
end;

function TSingleArrayHelper.Equals(Other: TSingleArray): Boolean;
begin
Result := specialize Equals<Single>(Self, Other);
Expand Down
25 changes: 24 additions & 1 deletion Source/array/simba.array_point.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1219,8 +1219,31 @@ function TPointArrayHelper.Grow(Iterations: Integer): TPointArray;
end;

function TPointArrayHelper.Unique: TPointArray;
var
Matrix: TBooleanMatrix;
I, Count: Integer;
begin
Result := Algo_Unique_Points(Self);
if (Length(Self) > 0) then
begin
SetLength(Result, Length(Self));

Count := 0;
with Self.Bounds() do
begin
Matrix.SetSize(Width, Height);

for I := 0 to High(Self) do
if not Matrix[Self[I].Y - Y1, Self[I].X - X1] then
begin
Matrix[Self[I].Y - Y1, Self[I].X - X1] := True;
Result[Count] := Self[I];
Inc(Count);
end;
end;

SetLength(Result, Count);
end else
Result := [];
end;

function TPointArrayHelper.ReduceByDistance(Dist: Integer): TPointArray;
Expand Down
Loading

0 comments on commit ba3d2db

Please sign in to comment.