Sordie.co.uk

libsassy/libSassy.Arrays.pas

Raw

{(
 )) libSassy.Arrays
((    Array (TList style) classes
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2017
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.Arrays;

interface

uses
  libSassy.Interfaces;

type
{$REGION 'TArray'}
  TArrayCompareProc = reference to function(const A, B): Integer;
  TArrayNotifyProc  = reference to procedure(const A);

  TArray<T> = class(TInterface)
  private
    fCount: Integer;

    fCompareProc: TArrayCompareProc;
    fAddProc:     TArrayNotifyProc;
    fDelProc:     TArrayNotifyProc;

    fAllowDuplicates: Boolean;

    procedure SetAllowDuplicates(Value: Boolean);

    function  GetItem(Index: Integer): T;
    procedure SetItem(Index: Integer; Value: T);

    procedure InternalDelete(Index: Integer; Count: Integer);
    procedure InternalSwap(A, B: Integer);
    procedure InternalSort(A, B: Integer; ACompareProc: TArrayCompareProc);

    type TArrayEnumerator = class
    private
      fIndex: Integer;
      fOwner: TArray<T>;
    public
      constructor Create(AOwner: TArray<T>);

      function GetCurrent: T;
      function MoveNext: Boolean;

      property Current: T read GetCurrent;
    end;

    type TArrayMethod = reference to procedure(i: T);
  public
    Items: array of T;

    constructor Create;
    destructor  Destroy; override;

    function GetEnumerator: TArrayEnumerator; inline;

    function  InternalCompareProc(const A, B): Integer; virtual;
    procedure InternalAddProc(const A); virtual;
    procedure InternalDelProc(const A); virtual;

    function  Exists(Item: T): Boolean; inline;
    function  Add(Item: T; const Index: Integer = -1; ACompareProc: TArrayCompareProc = nil): Integer;
    procedure Delete(const Index: Integer; Count: Integer = 1);
    procedure Clear;
    procedure Swap(A, B: Integer);
    procedure Shuffle;
    procedure Sort(A, B: Integer;   ACompareProc: TArrayCompareProc = nil); overload;
    procedure Sort(                 ACompareProc: TArrayCompareProc = nil); overload;
    function  Find     (const Item; ACompareProc: TArrayCompareProc = nil): Integer;
    function  FindAll  (const Item; ACompareProc: TArrayCompareProc = nil): TArray<T>;
    procedure Remove   (const Item; ACompareProc: TArrayCompareProc = nil);
    procedure RemoveAll(const Item; ACompareProc: TArrayCompareProc = nil);
    procedure RemoveDuplicates(     ACompareProc: TArrayCompareProc = nil);
    function  Copy(Start, Count: Integer): TArray<T>;
    procedure Trim;

    procedure ForEach(Method: TArrayMethod); inline;

    procedure Push(Item: T); inline;
    function  Pop: T; inline;

    procedure Queue(Item: T); inline;
    function  Dequeue: T; inline;

    function First: T; inline;
    function Last:  T; inline;

    function Empty: Boolean; inline;

    function SafeGet(const Index: Integer; Default: T): T;

    property CompareProc: TArrayCompareProc read fCompareProc write fCompareProc;
    property AddProc:     TArrayNotifyProc  read fAddProc     write fAddProc;
    property DelProc:     TArrayNotifyProc  read fDelProc     write fDelProc;

    property AllowDuplicates: Boolean read fAllowDuplicates write SetAllowDuplicates;

    property Count: Integer read fCount;
    property Item[Index: Integer]: T read GetItem write SetItem; default;
  end;
{$ENDREGION}

{$REGION 'TObjectArray'}
  TObjectArray<t: class> = class(TArray<t>)
  private
    fFreeOnDelete: Boolean;
  public
    constructor Create;

    function  InternalCompareProc(const A, B): Integer; override;
    procedure InternalDelProc(const A); override;

    property FreeOnDelete: Boolean read fFreeOnDelete write fFreeOnDelete;
  end;

  TObjects = TObjectArray<TObject>;
{$ENDREGION}

{$REGION 'TDictionary'}
  TDictionary<T> = class(TInterface)
  public
    type
      PItem = ^TItem;
      TItem = record
        Name:  String;
        Value: T;
      end;
  private
    fItems: TArray<PItem>;

    function GetCount: Integer; inline;

    function  GetName(Index: Integer): String;       inline;
    procedure SetName(Index: Integer; Name: String); inline;

    function  GetValue(Name: String): T;
    procedure SetValue(Name: String; Value: T);
  public
    constructor Create;
    destructor  Destroy; override;

    function  InternalCompareProc(const A, B): Integer; virtual;
    procedure InternalAddProc(const A); virtual;
    procedure InternalDelProc(const A); virtual;

    function  Add(const Name: String; Value: T; const Index: Integer = -1): Integer;
    procedure Delete(const Index: Integer; Count: Integer = 1);
    procedure Clear;

    function  Find    (const Name: String; const Start: Integer = 0): Integer;
    function  FindAll (const Name: String; const Start: Integer = 0): TDictionary<T>;
    function  MatchAll(const Mask: String; const Start: Integer = 0): TDictionary<T>;

    property Count: Integer read GetCount;

    property Items: TArray<PItem> read fItems;

    property Names[Index: Integer]: String read GetName  write SetName;
    property Values[Name: String]:  T      read GetValue write SetValue; default;
  end;
{$ENDREGION}

implementation

uses
  libSassy.Strings;

{$REGION 'TArray'}
procedure TArray<T>.SetAllowDuplicates;
begin
  fAllowDuplicates := Value;

  if not Value then
    RemoveDuplicates;
end;

function TArray<T>.GetItem;
begin
  Result := Items[Index];
end;

procedure TArray<T>.SetItem;
begin
  Items[Index] := Value;
end;

procedure TArray<T>.InternalDelete;
var
  i: Integer;
begin
  if (Index < 0) or (Index >= fCount) or (Count <= 0) then exit;

  if (Index + Count) > fCount then
    Count := fCount - Index;

  dec(fCount, Count);

  if Assigned(fDelProc) then
    for i := 0 to Count - 1 do
      fDelProc(Items[Index + i]);

  if Index < fCount then
    move(Items[Index + Count], Items[Index], (fCount - Index + Count) * sizeof(T));
end;

procedure TArray<T>.InternalSwap;
var
  ItemTemp: T;
begin
  if (A = B) then exit;

  ItemTemp  := Items[A];
  Items[A]  := Items[B];
  Items[B]  := ItemTemp;
end;

procedure TArray<T>.InternalSort;
var
  i, j: Integer;
  m:    Integer;
begin
  repeat
    i := A;
    j := B;

    m := (A + B) shr 1;

    repeat
      while ACompareProc(Items[i], Items[m]) < 0 do inc(i);
      while ACompareProc(Items[j], Items[m]) > 0 do dec(j);

      if i <= j then
      begin
        InternalSwap(i, j);

        if m = i then
          m := j
        else if m = j then
          m := i;

        inc(i);
        dec(j);
      end;
    until i > j;

    if A < j then InternalSort(A, j, ACompareProc);

    A := i;
  until i >= B;
end;

constructor TArray<T>.TArrayEnumerator.Create;
begin
  inherited Create;

  fOwner := AOwner;
  fIndex := -1;
end;

function TArray<T>.TArrayEnumerator.GetCurrent;
begin
  Result := fOwner.Items[fIndex];
end;

function TArray<T>.TArrayEnumerator.MoveNext;
begin
  Result := fIndex < fOwner.Count - 1;
  if Result then inc(fIndex);
end;

constructor TArray<T>.Create;
begin
  inherited;

  fCount := 0;

  fAllowDuplicates := True;

  fCompareProc := InternalCompareProc;
  fAddProc     := InternalAddProc;
  fDelProc     := InternalDelProc;
end;

destructor TArray<T>.Destroy;
begin
  Clear;

  inherited;
end;

function TArray<T>.GetEnumerator;
begin
  Result := TArrayEnumerator.Create(Self);
end;

function TArray<T>.InternalCompareProc;
var
  b1, b2: ^Byte;
  i:      Integer;
  s:      Integer;
begin
  b1 := @A;
  b2 := @B;

  // Place this "sizeof" direcly on the for loop rather than using "s"
  // for compiler fun! Bloody "internal error"

  s := sizeof(T);

  for i := 1 to s do
  begin
    Result :=  b1^ - b2^;
    if Result <> 0 then exit;

    inc(b1);
    inc(b2);
  end;

  Result := 0;
end;

procedure TArray<T>.InternalAddProc;
begin
  {}
end;

procedure TArray<T>.InternalDelProc;
begin
  {}
end;

function TArray<T>.Exists;
begin
  Result := Find(Item) > -1;
end;

function TArray<T>.Add;
begin
  if not fAllowDuplicates then
    if Find(Item, ACompareProc) > -1 then exit(0);

  //TMonitor.Enter(Self);

  //try
    if fCount = length(Items) then
      SetLength(Items, length(Items) + 32);

    if (Index > -1) and (Index < fCount) then
    begin
      Result := Index;

      move(Items[Index], Items[Result + 1], (fCount - Result) * sizeof(T));
    end

    else Result := fCount;

    Items[Result] := Item;
    inc(fCount);

    if Assigned(fAddProc) then fAddProc(Item);
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Delete;
var
  i: Integer;
begin
  //TMonitor.Enter(Self);

  //try
    InternalDelete(Index, Count);
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Clear;
var
  i: Integer;
begin
  //TMonitor.Enter(Self);

  //try
    if Assigned(fDelProc) then
      for i := fCount - 1 downto 0 do
        fDelProc(Items[i]);

    SetLength(Items, 0);
    fCount := 0;
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Swap;
begin
  //TMonitor.Enter(Self);

  //try
    if (A < 0) or (A >= fCount)
    or (B < 0) or (B >= fCount) then exit;

    InternalSwap(A, B);
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Shuffle;
var
  i: Integer;
begin
  //TMonitor.Enter(Self);

  //try
    for i := 0 to fCount - 1 do
      InternalSwap(i, Random(fCount));
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Sort(A, B: Integer; ACompareProc: TArrayCompareProc = nil);
begin
  if not Assigned(ACompareProc) then
    ACompareProc := fCompareProc;
  if not Assigned(ACompareProc) then
    ACompareProc := InternalCompareProc;

  //TMonitor.Enter(Self);
  //try
    InternalSort(A, B, ACompareProc);
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Sort(ACompareProc: TArrayCompareProc = nil);
begin
  Sort(0, fCount - 1, ACompareProc);
end;

function TArray<T>.Find;
var
  i: Integer;
begin
  if not Assigned(ACompareProc) then
    ACompareProc := fCompareProc;
  if not Assigned(ACompareProc) then
    ACompareProc := InternalCompareProc;

  //TMonitor.Enter(Self);
  //try
    for i := fCount - 1 downto 0 do
      if ACompareProc(Items[i], Item) = 0 then exit(i);

    Result := -1;
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

function TArray<T>.FindAll;
var
  i: Integer;
begin
  Result := TArray<T>.Create;

  if not Assigned(ACompareProc) then
    ACompareProc := fCompareProc;
  if not Assigned(ACompareProc) then
    ACompareProc := InternalCompareProc;

  //TMonitor.Enter(Self);
  //try
    for i := 0 to fCount - 1 do
      if ACompareProc(Items[i], Item) = 0 then
        Result.Add(Items[i]);
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Remove;
var
  i: Integer;
begin
  if not Assigned(ACompareProc) then
    ACompareProc := fCompareProc;
  if not Assigned(ACompareProc) then
    ACompareProc := InternalCompareProc;

  //TMonitor.Enter(Self);
  //try
    for i := fCount - 1 downto 0 do
      if ACompareProc(Items[i], Item) = 0 then
      begin
        InternalDelete(i, 1);
        exit;
      end;
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.RemoveAll;
var
  i: Integer;
begin
  if not Assigned(ACompareProc) then
    ACompareProc := fCompareProc;
  if not Assigned(ACompareProc) then
    ACompareProc := InternalCompareProc;

  //TMonitor.Enter(Self);
  //try
    for i := fCount - 1 downto 0 do
      if ACompareProc(Items[i], Item) = 0 then InternalDelete(i, 1);
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.RemoveDuplicates;
var
  i, j: Integer;
begin
  if not Assigned(ACompareProc) then
    ACompareProc := fCompareProc;
  if not Assigned(ACompareProc) then
    ACompareProc := InternalCompareProc;

  //TMonitor.Enter(Self);
  //try
    for i := fCount - 1 downto 0 do
      for j := i - 1 downto 0 do
        if ACompareProc(Items[i], Items[j]) = 0 then
        begin
          InternalDelete(i, 1);
          break;
        end;
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

function TArray<T>.Copy;
begin
  Result := TArray<T>.Create;

  if (Start < 0) or (Start >= fCount) or (Count <= 0) then exit;

  if (Start + Count) > fCount then
    Count := fCount - Start;

  //TMonitor.Enter(Self);
  //try
    SetLength(Result.Items, Count);
    Result.fCount := Count;
    move(Items[Start], Result.Items[0], Count * sizeof(T));
  //finally
    //TMonitor.Exit(Self);
  //end;
end;

procedure TArray<T>.Trim;
begin
  SetLength(Items, fCount);
end;

procedure TArray<T>.ForEach;
var
  i: T;
begin
  for i in Self do
    Method(i);
end;

procedure TArray<T>.Push;
begin
  Add(Item);
end;

function TArray<T>.Pop;
begin
  if fCount = 0 then exit;

  Result := Items[fCount - 1];
  Delete(fCount - 1);
end;

procedure TArray<T>.Queue;
begin
  Add(Item);
end;

function TArray<T>.Dequeue;
begin
  if fCount = 0 then exit;

  Result := Items[0];
  Delete(0);
end;

function TArray<T>.First;
begin
  if fCount > 0 then
    Result := Items[0];
end;

function TArray<T>.Last;
begin
  if fCount > 0 then
    Result := Items[fCount - 1];
end;

function TArray<T>.Empty;
begin
  Result := fCount = 0;
end;

function TArray<T>.SafeGet;
begin
  if (Index < 0) or (Index >= Count) then
    Result := Default
  else
    Result := Items[Index];
end;
{$ENDREGION}

{$REGION 'TObjectArray'}
constructor TObjectArray<t>.Create;
begin
  inherited;

  fFreeOnDelete := True;
end;

function TObjectArray<t>.InternalCompareProc;
begin
  Result := Cardinal(TObject(A)) - Cardinal(TObject(B));
end;

procedure TObjectArray<t>.InternalDelProc;
begin
  if fFreeOnDelete then
    TObject(A).Free;
end;
{$ENDREGION}

{$REGION 'TDictionary'}
function TDictionary<T>.GetCount;
begin
  Result := Items.Count;
end;

function TDictionary<T>.GetName;
begin
  Result := Items[Index]^.Name;
end;

procedure TDictionary<T>.SetName;
begin
  Items[Index]^.Name := Name;
end;

function TDictionary<T>.GetValue;
var
  i: Integer;
begin
  i := Find(Name);
  if i = -1 then exit;

  Result := Items[i]^.Value;
end;

procedure TDictionary<T>.SetValue;
var
  i: Integer;
begin
  i := Find(Name);
  if i = -1 then exit;

  Items[i]^.Value := Value;
end;

constructor TDictionary<T>.Create;
begin
  inherited;

  fItems := TArray<PItem>.Create;

  fItems.CompareProc := InternalCompareProc;
  fItems.AddProc     := InternalAddProc;
  fItems.DelProc     := InternalDelProc;
end;

destructor TDictionary<T>.Destroy;
begin
  Clear;
  fItems.Free;

  inherited;
end;

function TDictionary<T>.InternalCompareProc;
begin
  Result := PItem(A)^.Name.Compare(PItem(B)^.Name);
end;

procedure TDictionary<T>.InternalAddProc;
begin

end;

procedure TDictionary<T>.InternalDelProc;
begin
  dispose(PItem(A));
end;

function TDictionary<T>.Add;
var
  I: PItem;
begin
  new(I);

  I^.Name  := Name;
  I^.Value := Value;

  Result := fItems.Add(I, Index);
end;

procedure TDictionary<T>.Delete;
begin
  fItems.Delete(Index, Count);
end;

procedure TDictionary<T>.Clear;
var
  i: Integer;
begin
  for i := Items.Count - 1 downto 0 do
    InternalDelProc(fItems.Items[i]);

  fItems.Clear;
end;

function TDictionary<T>.Find;
var
  i: Integer;
begin
  for i := Start to fItems.Count - 1 do
    if Name.Compare(fItems[i]^.Name) = 0 then Exit(i);

  Result := -1;
end;

function TDictionary<T>.FindAll;
var
  i: Integer;
begin
  Result := TDictionary<T>.Create;

  for i := Start to fItems.Count - 1 do
    if Name.Compare(fItems[i]^.Name) = 0 then
      Result.Add(Name, fItems[i]^.Value);
end;

function TDictionary<T>.MatchAll;
var
  i: Integer;
begin
  Result := TDictionary<T>.Create;

  for i := Start to fItems.Count - 1 do
    if fItems[i]^.Name.Match(Mask) then
      Result.Add(fItems[i].Name, fItems[i]^.Value);
end;
{$ENDREGION}

end.