More handy classes, part 2

For interlocked functions (atomic operations) I have a special class in BB.Sync:

type

TInterlocked = class
  public
    class function CAS(var aTarget: integer; aCurrentVal, aNewVal: integer): boolean; overload;
    class function CAS(var aTarget: cardinal; aCurrentVal, aNewVal: cardinal): boolean; overload;
    class function CAS(var aTarget: pointer; aCurrentVal, aNewVal: pointer): boolean; overload;
    class function CAS(var aTarget: TObject; aCurrentVal, aNewVal: TObject): boolean; overload;
    class function CAS(var aTarget: LongBool; aCurrentVal, aNewVal: LongBool): boolean; overload;
    class function Inc(var aValue: integer): integer; overload;
    class function Inc(var aValue: int64): integer; overload;
    class function Dec(var aValue: integer): integer; overload;
    class function Dec(var aValue: int64): integer; overload;
    class function Add(var aValue: integer; aCounter: integer): integer;
    class function Sub(var aValue: integer; aCounter: integer): integer;
    class function SetValue(var aTarget: integer; aValue: integer): integer;
  end;

CAS is a acronym of "Compare And Swap", is a must operation in parallel code. Think on a certain class that has an owner thread as the first caller (for whatever reason), the easiest possibility is to use a critical section, but that affects the performance quite a  lot, another possibility is to use CAS():

constructor TLock.Create;
begin
  inherited;

  FCurrentThread := 0; //Nobody owns me
  FDepth := 0;
end;

destructor TLock.Destroy;
begin
  Unlock;

  inherited;
end;

function TLock.IsLocked: boolean;
begin
  result := FCurrentThread <> 0; //Somebody owns me?
end;

function TLock.Lock(aTime: cardinal): boolean;
var
  ticks: Cardinal;

begin
  result := False;

  ticks := GetTickCount;
  repeat
    if TryLock then
    begin
      result := True;
      Break;
    end;

    Sleep(5);
  until GetTickCount - ticks > aTime;
end;

procedure TLock.Lock;
begin
  Lock(INFINITE);
end;

function TLock.TryLock: boolean;
begin
  //The special part of the code
  //It can be translated as
  //
  //ATOMIC ON
  // if FCurrentThread = 0 then
  //    FCurrentThread := GetCurrentThreadId;
  //  Exit(FCurrentThread);
  //ATOMIC OFF
  //
//This can only happens once, so next thread will exit the function 
  //without success
//
  //You could use a critical section here
  //  result := (FCurrentThread = GetCurrentThreadId) or 
(TInterlocked.CAS(FCurrentThread, 0, GetCurrentThreadId));
  if result then
    TInterlocked.Inc(FDepth); //How many times does my owner owns me?
end;

function TLock.Unlock: boolean;
begin
  result := False;
  if FCurrentThread = GetCurrentThreadId then //If caller = owner then release
  begin
    if TInterlocked.Dec(FDepth) = 0 then
    begin
      FCurrentThread := 0; //Now any other thread is able to own me
      result := True;
    end;
  end;
end;

Next post I will talk about ParallelForEach<T>

Arena tournament

Last night I prepared a chess tournament among some chess engines via Arena (including of course ChessKISS), these are the results:

Well, fourth is not bad, but against BigLion and Piranha the engine missed some easy wins, but due to a bloddy bug in the repetition code, the program played three times the same move (of course the other two engines seems to have the same problem...) ending in a draw, what a pitty...

I hope soon I can fix that error.

Some utils...

Today I will present some handy classes, they are all located in BB.Utils.* namespace.

This class will swap any kind of value:

TSwap<T> = class
public
  class procedure Swap(var a, b: T);
end;

Implementation:

class procedure TSwap<T>.Swap(var a, b: T);
var
  tmp: T;

begin
  tmp := a;
  a := b;
  b := tmp;
end

Example:

var
  a, b: integer;

begin
  a := 1;
  b := 2;
  TSwap<integer>.Swap(a, b);
  //Now a=2 & b=1
end;

This class let you do dynamic calls:

TCaller = class
public
  class procedure Call(aMethod: TMethod); overload;
  class procedure Call(aMethod: TMethod; aSender: TObject); overload;
  class procedure Call(aObject: TObject; const aMethod: string); overload;
end;

The implementation:

class procedure TCaller.Call(aMethod: TMethod);
begin
  TMethodPointer(aMethod)();
end;

class procedure TCaller.Call(aObject: TObject; const aMethod: string);
var
  m: TMethod;

begin
  m.Data := aObject;
  m.Code := aObject.MethodAddress(aMethod);
  Call(m);
end;

class procedure TCaller.Call(aMethod: TMethod; aSender: TObject);
begin
  TNotifyEvent(aMethod)(aSender);
end;
Example:

begin
  TCaller.Call(Button1, 'click');  
  //This will dinamically call the click method of a button.
  //This enables you to persist method names and use them
  //for your own purpose (by configuration you dedice
  //which action calls which method
end;
This class behaves like a bit container:

TBitSet = record
private
  FData: int64;
public
  constructor Create(aValue: int64);
  procedure ClearBit(aBit: integer); inline;
  function GetBit(aBit: integer): boolean; inline;
  procedure SetBit(aBit: integer); inline;
  function AsByte: byte; inline;
  function AsWord: word; inline;
  function AsInt: integer; inline;
  function AsInt64: int64; inline;
end;

Implementation

{ TBitSet }

//Bit64: array [0..63] of int64 =
//is an int64 precalculated array (it does not look good when I paste the values)
function TBitSet.AsByte: byte;
begin
  Exit(byte(FData));
end;

function TBitSet.AsInt: integer;
begin
  Exit(integer(FData));
end;

function TBitSet.AsInt64: int64;
begin
  Exit(FData);
end;

function TBitSet.AsWord: word;
begin
  Exit(word(FData));
end;

procedure TBitSet.ClearBit(aBit: integer);
begin
  FData := FData and ($FFFFFFFFFFFFFFFF xor Bit64[aBit]);
end;

constructor TBitSet.Create(aValue: int64);
begin
  FData := aValue;
end;

function TBitSet.GetBit(aBit: integer): boolean;
begin
  Exit(FData and Bit64[aBit] <> 0);
end;

procedure TBitSet.SetBit(aBit: integer);
begin
  FData := FData or Bit64[aBit];
end;

Example:

var
  t: TBitSet;
  i: integer;

begin
  t := TBitSet.Create($ffff);
  t.ClearBit(15);
  i := t.AsInt; //Now i = $fff
end;
And the last class is a time helper, is used also in ChessKISS for the Winboard protocol.

TTimeSpan = class
public
  class function Make(aDays, aHours, aMinutes, aSeconds, aMilliseconds: cardinal): cardinal;
  class procedure Unmake(aValue: cardinal; out aDays, aHours, aMinutes, aSeconds, aMilliseconds: cardinal);
  class function MillisecondsToDays(aValue: cardinal): cardinal;
  class function MillisecondsToHours(aValue: cardinal): cardinal;
  class function MillisecondsToMinutes(aValue: cardinal): cardinal;
  class function MillisecondsToSeconds(aValue: cardinal): cardinal;
  class function Milliseconds(aValue: cardinal): cardinal;
  class function SecondsToMilliseconds(aValue: cardinal): cardinal; inline;
  class function MinutesToMilliseconds(aValue: cardinal): cardinal; inline;
  class function HoursToMilliseconds(aValue: cardinal): cardinal; inline;
  class function DaysToMilliseconds(aValue: cardinal): cardinal; inline;
end;

Implementation

{ TTimeSpan }

class function TTimeSpan.DaysToMilliseconds(aValue: cardinal): cardinal;
begin
  result := HoursToMilliseconds(aValue) * 24;
end;

class function TTimeSpan.HoursToMilliseconds(aValue: cardinal): cardinal;
begin
  result := MinutesToMilliseconds(aValue) * 60;
end;

class function TTimeSpan.MinutesToMilliseconds(aValue: cardinal): cardinal;
begin
  result := SecondsToMilliseconds(aValue) * 60;
end;

class function TTimeSpan.SecondsToMilliseconds(aValue: cardinal): cardinal;
begin
  result := aValue * 1000;
end;

class procedure TTimeSpan.Unmake(aValue: cardinal; out aDays, aHours, aMinutes, aSeconds, aMilliseconds: cardinal);
begin
  aDays := MillisecondsToDays(aValue);
  Dec(aValue, DaysToMilliseconds(aDays));

  aHours := MillisecondsToHours(aValue);
  Dec(aValue, HoursToMilliseconds(aHours));

  aMinutes := MillisecondsToMinutes(aValue);
  Dec(aValue, MinutesToMilliseconds(aMinutes));

  aSeconds := MillisecondsToSeconds(aValue);
  Dec(aValue, SecondsToMilliseconds(aSeconds));

  aMilliseconds := aValue;
end;

class function TTimeSpan.Make(aDays, aHours, aMinutes, aSeconds, aMilliseconds: cardinal): cardinal;
begin
  result := Milliseconds(aMilliseconds) + SecondsToMilliseconds(aSeconds) + MinutesToMilliseconds(aMinutes) + HoursToMilliseconds(aHours) + DaysToMilliseconds(aDays);
end;

class function TTimeSpan.MillisecondsToDays(aValue: cardinal): cardinal;
begin
  Result := aValue div (1000 * 60 * 60 * 24);
end;

class function TTimeSpan.MillisecondsToHours(aValue: cardinal): cardinal;
begin
  Result := aValue div (1000 * 60 * 60);
end;

class function TTimeSpan.Milliseconds(aValue: cardinal): cardinal;
begin
  Result := aValue;
end;

class function TTimeSpan.MillisecondsToMinutes(aValue: cardinal): cardinal;
begin
  Result := aValue div (1000 * 60);
end;

class function TTimeSpan.MillisecondsToSeconds(aValue: cardinal): cardinal;
begin
  Result := aValue div 1000;
end

Example:
if Pos('level', cmd) = 1 then
begin
  //level 40 30 0  (40 moves, 30 minutes, 0)
  SplitString(cmd, ' ', list);
  FEngine.SetTimePerGame(TTimeSpan.MinutesToMilliseconds(StrToInt(list[2])));
  { TODO : 40 moves 5 minutes }
  Exit(True);
end;
Enjoy it?

Future, a very handy class

In BB.Synch there is a class called TFuture<T> whose goal is to launch a process and check if the result is available, if so, then get the result. This class is used in ChessKISS twice, once for the search and the other for the Winboard protocol, let's see an easy example.

On a console application:

function GetMessage: string;
var
  msg: AnsiString;
  c: AnsiChar;

begin
  msg := '';
  c := #0;
  repeat
    Read(Input, c);
    msg := msg + c;
  until (c = #13) or (c = #10);
  Delete(msg, Length(msg), 1);  //Delete CR

  Exit(msg);
end;

We have to check if we have receive a command, but this would block the application since we are calling Read(), a solution would be to create a Thread, but doing it is something always tedious, this is where TFuture helps us. Let's create a function that uses the new class, the only thing to do is pass the function as parameter in the constructor.

var
  t: TFuture<string> = nil;

function Process: string;
begin
  result := '';

  if t = nil then
    t := TFuture<string>.Create(GetMessage, tpNormal);

  if t.Available then
  begin
    result := t.GetValue;
    FreeAndNil(t);
  end;
end;
If the variable is null it creates a new task, and then once the result is  available (somebody has send or type a command in the console window), it gets the value, frees the class and return it.

The main process might look like this:

begin
  repeat
    p := Process;
    if p <> '' then
      DoSomethingWithTheValue(p);

    Sleep(500);
  until False;

end.

 Very handy and non blocking class, tip from Primoz Gabrijelcic.

How to log

It is always very important to log (at least in real world applications) what's going on in the application in order to  review actions that have already passed.

In BB.Log there is helpful class called TLog and TLogHandler tha main features are:

• Concurrent, we use it at work in applications with many threads writing to the same file.
• Multi file, you might need more than one file 
• for instance ChessKISS logs to three different files
• One for the Winboard protocol
• One for internal errors
• And the lat one for printing the board on every move (useful for revising games)
• Prefixes, timestamp and headers are writed on every entry
• Auto creates folders per date if desired.

The handler helps the maintenance of the different logs, this is how to use it:

var
  log: TLog;

begin
  log := TLogHandler.Instance.Add('log.txt', 'logs\');
  log.Add('Initializing');
  log.Add('Executing';
  log.Add('Finalizing');
end;

If you nneed more logs just add another one via TLogHandler.

I hope it helps

Memoize in Delphi

Memoize is a generic caching function, it accepts a closure as a function and return a function that does the same stuff but caches the results, very interesting.

The implementation:

TFunctionHelpers = class
  public
    class function Memoize<A, R>(aFunc: TFunc<A, R>): TFunc<A, R>;
    //other helper functions
  end;

Example of use:

type
  TSlowClass = class
  public
    //A time consuming function that changes the
    //result depending on the input value.
    //It does not matter the goal of the function, it can do whatever you want
    function Execute(aValue: integer): integer;
  end;

var
  slow: TSlowClass;
  F: TFunc<integer, integer>;
  i: integer;

begin
  slow := TSlowClass.Create;
  F := TFunctionHelpers.Memorize<integer, integer>(slow.Execute);
  for i := 0 to 999 do
    Memo1.Lines.Add(IntToStr(F(i div 10);  
  //So only 10 out of 1000 calls to the method have been really madeend;
The implementation is quite tricky, it uses a devired class from TDictionary as A(rgument) and R(esult) that does not need to be freed.
{ TManagedDictionary<TKey, TValue> }

function TManagedDictionary<TKey, TValue>.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TManagedDictionary<TKey,TValue>._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TManagedDictionary<TKey,TValue>._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

{ TFunctionHelpers<A, R> }
class function TFunctionHelpers.Memoize<A,R>(aFunc: TFunc<A, R>): TFunc<A, R>;
var
  Map: IDictionary<A, R>;

begin
  Map := TManagedDictionary<A, R>.Create;

  Result := function(aArg: A): R
  var
    FuncResult: R;

  begin
    if Map.TryGetValue(aArg, FuncResult) then
    begin
      Exit(FuncResult);
    end;

    FuncResult := aFunc(aArg);
    Map.Add(aArg, FuncResult);

    Exit(FuncResult);
  end;
end;
That's all for today

A generic HashMap, my crazy implementation...

Last but not least, my crazy implementation of a generic HashMap (aka dictionary), is crazy because I use TStrings for storing buckets, which give very fast access in any case...

The way HashMap works is like contacts in your movile device, they are stored as Name/Number (key/value) and the dispersion factor is the First letter (A...Z), in a hashmap you define the large your contact list is and how you store each entry, the "how" is the most  important, for instance, take 1000 entries, if your dispersion ratio is something like five, all your entries will be only inserted into five buckets...

bucket = Hash(aKey) mod SIZE;

Source can be found in BB.Collection.Hash

THashList<T: class> = class(TPooledObject, IIterator<T>)
  private
    FData: THashData;
    FCount: integer;
    FOwned: boolean;
    FBucket: integer;
    FIndex: integer;
    FSize: integer;

    function GetItem(aIndex: integer): T;
    procedure GetOffset(const aElement: integer; out aBucket, aIndex: integer);
    function GetKey(aIndex: integer): string;
    procedure SetSize(const aValue: integer);
    procedure Grow(aFrom: integer; aTo: integer);
  protected
    function FirstObject: T;
    function NextObject: T;
    function LastObject: T;
    function PriorObject: T;
    function GetCount: integer;
    function IsEmpty: boolean;
  public
    constructor Create(aSize: integer = DEFAULT_HASHMAP_SIZE); reintroduce;
    destructor Destroy; override;
    function Add(const aKey: string; aObject: T): integer; virtual;
    procedure Clear; override;
    procedure Rename(const aOldKey, aNewKey: string; aObject: T); overload;
    function Modify(const aKey: string; aObject: T): integer; overload; virtual;
    procedure Delete(const aKey: string);
    function IndexOf(const aKey: string): T; overload;
    function Find(const aPartialKey: string): T;
    function Sort: TStrings;
    function GetStatistics: TArrayOfInt;
    // IIterator
    function First: boolean;
    function Last: boolean;
    function Next: boolean;
    function GetCurrent: T;

    property Items[index: integer]: T read GetItem; default;
    property Keys[index: integer]: string read GetKey;
    property Owned: boolean read FOwned write FOwned;
    property Size: integer read FSize write SetSize;
    property Count: integer read GetCount;
  end;

Implementation:

 {THashList }

function THashList<T>.Add(const aKey: string; aObject: T): integer;
begin
  result := FData[TVar.GetHash(aKey) mod FSize].AddObject(aKey, aObject);

  Inc(FCount);
end;

procedure THashList<T>.Clear;
var
  i, j: integer;
  obj: T;
  l: TStringList;

begin
  inherited;

  for i := Low(FData) to High(FData) do
  begin
    l := FData[i];
    for j := FData[i].Count - 1 DownTo 0 do
    begin
      obj := l.Objects[j];
      if (obj <> nil) and (FOwned) then
        obj.Free;
    end;

    l.Clear;
  end;

  FCount := 0;
end;

function THashList<T>.GetCount: integer;
begin
  result := FCount;
end;

constructor THashList<T>.Create(aSize: integer = DEFAULT_HASHMAP_SIZE);
begin
  inherited Create;

  FOwned := False;
  FCount := 0;
  FBucket := -1;
  FIndex := -1;

  Grow( Low(FData), aSize);
end;

procedure THashList<T>.Delete(const aKey: string);
var
  bucket, i: integer;
  obj: T;
  l: TStringList;

begin
  bucket := TVar.GetHash(aKey) mod FSize;
  l := FData[bucket];
  i := l.IndexOf(aKey);
  obj := l.Objects[i];
  l.Delete(i);

  Dec(FCount);
  if FOwned then
    obj.Free;
end;

destructor THashList<T>.Destroy;
var
  i: integer;

begin
  Clear;
  for i := Low(FData) to High(FData) do
    FData[i].Free;

  inherited Destroy;
end;

function THashList<T>.Find(const aPartialKey: string): T;
var
  obj: T;
  key: string;

begin
  result := nil;
  obj := FirstObject;
  while obj <> nil do
  begin
    key := FData[FBucket].Strings[FIndex];
    if Pos(aPartialKey, key) > 0 then
    begin
      result := FData[FBucket].Objects[FIndex];
      Break;
    end;

    obj := NextObject;
  end;
end;

function THashList<T>.First: boolean;
begin
  result := FirstObject <> nil;
end;

function THashList<T>.FirstObject: T;
begin
  if IsEmpty then
  begin
    result := nil;
    Exit;
  end;

  FBucket := 0;
  while FData[FBucket].Count = 0 do
    Inc(FBucket);
  FIndex := 0;

  result := GetCurrent;
end;

function THashList<T>.GetCurrent: T;
begin
  if (FBucket > -1) and (FIndex < FData[FBucket].Count) then
    result := FData[FBucket].Objects[FIndex]
  else
    result := nil;
end;

function THashList<T>.GetItem(aIndex: integer): T;
var
  bucket, i: integer;

begin
  GetOffset(aIndex, bucket, i);
  result := FData[bucket].Objects[i];
end;

function THashList<T>.GetKey(aIndex: integer): string;
var
  bucket, i: integer;

begin
  GetOffset(aIndex, bucket, i);
  result := FData[bucket][i];
end;

procedure THashList<T>.GetOffset(const aElement: integer;
  out aBucket, aIndex: integer);
var
  total: integer;

begin
  total := 0;
  aBucket := 0;
  aIndex := aElement;
  while (total <= aElement) or (total = 0) do
  begin
    Inc(total, FData[aBucket].Count);
    Inc(aBucket);
  end;
  Dec(aBucket);

  Dec(total, FData[aBucket].Count);
  Dec(aIndex, total);
end;

function THashList<T>.IndexOf(const aKey: string): T;
var
  bucket, i: integer;
  l: TStringList;

begin
  bucket := TVar.GetHash(aKey) mod FSize;
  l := FData[bucket];
  i := l.IndexOf(aKey);
  if i > -1 then
    result := l.Objects[i]
  else
    result := nil;
end;

function THashList<T>.IsEmpty: boolean;
begin
  result := FCount = 0;
end;

function THashList<T>.Last: boolean;
begin
  result := LastObject <> nil;
end;

function THashList<T>.LastObject: T;
begin
  if IsEmpty then
  begin
    result := nil;
    Exit;
  end;

  FBucket := High(THashData);
  while FData[FBucket].Count = 0 do
    Dec(FBucket);
  FIndex := FData[FBucket].Count - 1;

  result := GetCurrent;
end;

function THashList<T>.Modify(const aKey: string; aObject: T): integer;
var
  bucket: integer;
  l: TStringList;

begin
  bucket := TVar.GetHash(aKey) mod FSize;
  l := FData[bucket];
  result := l.IndexOf(aKey);
  if result > -1 then
  begin
    if FOwned then
      l.Objects[result].Free;
    l.Objects[result] := aObject;
  end
  else
    result := Add(aKey, aObject);
end;

function THashList<T>.Next: boolean;
begin
  result := NextObject <> nil;
end;

function THashList<T>.NextObject: T;
begin
  if IsEmpty then
  begin
    result := nil;
    Exit;
  end;

  Inc(FIndex);
  if FIndex > FData[FBucket].Count - 1 then
  begin
    Inc(FBucket);
    while (FData[FBucket].Count = 0) and (FBucket < High(FData)) do
      Inc(FBucket);
    FIndex := 0;
  end;

  result := GetCurrent;
end;

function THashList<T>.PriorObject: T;
begin
  if IsEmpty then
  begin
    result := nil;
    Exit;
  end;

  Dec(FIndex);
  if FIndex < 0 then
  begin
    Inc(FBucket);
    while (FData[FBucket].Count = 0) and (FBucket > 0) do
      Dec(FBucket);
    FIndex := FData[FBucket].Count - 1;
  end;

  result := GetCurrent;
end;

procedure THashList<T>.SetSize(const aValue: integer);
begin
  if aValue < FSize then
    raise Exception.Create('Hash size can only grow');

  Grow(FSize + 1, aValue);
end;

function THashList<T>.Sort: TStrings;
var
  i, index, bucket: integer;

begin
  result := TStringList.Create;
  TStringList(result).Sorted := True;
  TStringList(result).Duplicates := dupError;

  for i := 0 to GetCount - 1 do
  begin
    GetOffset(i, bucket, index);
    result.AddObject(FData[bucket].Strings[index],
      FData[bucket].Objects[index]);
  end;
end;

function THashList<T>.GetStatistics: TArrayOfInt;
var
  i: integer;

begin
  SetLength(result, Length(FData));
  for i := Low(FData) to High(FData) do
    result[i] := FData[i].Count;
end;

procedure THashList<T>.Grow(aFrom: integer; aTo: integer);
var
  n: integer;

begin
  if aTo = 0 then
    raise Exception.Create('HashList size cannot be zero');

  FSize := aTo;
  SetLength(FData, FSize + 1);

  for n := Low(FData) to High(FData) do
  begin
    FData[n] := TStringList.Create;
    FData[n].Sorted := True;
    FData[n].Duplicates := dupError;
    FData[n].Capacity := 100;
  end;
end;

procedure THashList<T>.Rename(const aOldKey, aNewKey: string; aObject: T);
begin
  Delete(aOldKey);
  Add(aNewKey, aObject);
end;

The hash function looks like this:

class function TVar.GetHash(const aText: string): integer;
var
  i: Integer;

begin
  result := 5381;
  for i := 1 to Length(aText) do
    result := ((result shl 5) + result) + Ord(aText[i]);
//    result := result * 2 + n xor Ord(aText[n]);
end;
The comments means that I'm not happy with the dispersion ratio.

A shared memory class

There are situations in which many threads compete for a memory stream, as you might be aware, the concurrency model is a big issue in this kind of scenarios. So I have created a class that implements some kind of locking mechanism via TDictionary, what?

The idea behind is to do the same as databases to in the real world for locking (for our purpose, rows equal memory positions). The dictionary is a bit tuned otherwise would also have concurrent issues.

The file is locate in BB.Utils.SharedMemory

type
  TSharedMemory = class(TInterfacedObject, ISharedMemory)
  private
    FBuffer: pointer;
    FSize: cardinal;
    FLocks: TConcurrentDictionary<integer,integer>;

    function GetPointer(aOffset: integer): pointer; inline;
    procedure Lock(aOffset, aSize: Integer);
    procedure Unlock(aOffset, aSize: integer);
    procedure CheckSize(aSize: Integer); inline;
  public
    constructor Create(aSize: cardinal); overload;
    constructor Create(aBuffer: pointer; aSize: cardinal); overload;
    destructor Destroy; override;
    function Read(aOffset, aSize: integer): TArray<byte>;
    function Read8(aOffset: integer): byte; inline;
    function Read16(aOffset: integer): word; inline;
    function Read32(aOffset: integer): cardinal; inline;
    function Read64(aOffset: integer): Int64; inline;
    procedure Write(aOffset: integer; const aValues: TArray<byte>); overload;
    procedure Write(aOffset, aSize: integer; aSource: pointer); overload;
    procedure Write8(aOffset: integer; aValue: byte);
    procedure Write16(aOffset: integer; aValue: word);
    procedure Write32(aOffset: integer; aValue: cardinal);
    procedure Write64(aOffset: integer; aValue: Int64);

    property Size: cardinal read FSize;
  end;

I'm doing some test in order to see what performance best a direct lock or this way, and it depends..., reading/writing small portions of memory is better to use a TLock, but for big reading/writing big portions of memory the increase of speed is considerable.

{ TSharedMemory }

constructor TSharedMemory.Create(aSize: cardinal);
begin
  FLocks := TConcurrentDictionary<integer, integer>.Create;
  GetMem(FBuffer, aSize);
  FSize := aSize;
end;

constructor TSharedMemory.Create(aBuffer: pointer; aSize: cardinal);
begin
  FLocks := TConcurrentDictionary<integer, integer>.Create;
  FBuffer := aBuffer;
  FSize := aSize;
end;

destructor TSharedMemory.Destroy;
begin
  FreeMem(FBuffer);
  FLocks.Free;

  inherited;
end;

function TSharedMemory.GetPointer(aOffset: integer): pointer;
begin
  result := @PByteArray(FBuffer)[aOffset];
end;

function TSharedMemory.Read(aOffset: integer; aSize: integer): TArray<byte>;
var
  i: integer;

begin
  result := TArray<byte>.Create(aSize);
  for i := 0 to aSize - 1 do
    result[i] := Read8(aOffset + i);
end;

function TSharedMemory.Read16(aOffset: integer): word;
begin
  result := PWord(GetPointer(aOffset))^;
end;

function TSharedMemory.Read32(aOffset: integer): cardinal;
begin
  result := PCardinal(GetPointer(aOffset))^;
end;

function TSharedMemory.Read64(aOffset: integer): Int64;
begin
  result := PInt64(GetPointer(aOffset))^;
end;

function TSharedMemory.Read8(aOffset: integer): byte;
begin
  result := PByte(GetPointer(aOffset))^;
end;

procedure TSharedMemory.Unlock(aOffset, aSize: integer);
var
  i: integer;
  keys: array of integer;

begin
  SetLength(keys, aSize);
  for i := 0 to aSize - 1 do
    keys[i] := aOffset + i;
  FLocks.Remove(keys);
end;

procedure TSharedMemory.Write(aOffset: integer; const aValues: TArray<byte>);
var
  i: integer;

begin
  CheckSize(Length(aValues));

  Lock(aOffset, Length(aValues));
  try
    for i := 0 to Length(aValues) - 1 do
      PByte(GetPointer(aOffset + i))^ := aValues[i];
  finally
    Unlock(aOffset, Length(aValues));
  end;
end;

procedure TSharedMemory.Lock(aOffset, aSize: Integer);
var
  i: integer;
  //keys: array of integer;

begin
  for i := 0 to aSize - 1 do
  begin
    while not FLocks.TryAdd(aOffset + i, 1) do
      Sleep(10);
  end;

  {
  SetLength(keys, aSize);
  for i := 0 to aSize - 1 do
    keys[i] := aOffset + i;

  while not FLocks.TryAdd(keys) do
    Sleep(10);
    }
end;

procedure TSharedMemory.Write(aOffset, aSize: integer; aSource: pointer);
var
  i: integer;

begin
  CheckSize(aSize);

  Lock(aOffset, aSize);
  try
    i := aSize - 1;
    while i >= 0 do
      PByte(GetPointer(aOffset + i))^ := PByteArray(aSource)[i];
  finally
    Unlock(aOffset, aSize);
  end;
end;

procedure TSharedMemory.Write16(aOffset: integer; aValue: word);
begin
  Lock(aOffset, Sizeof(word));
  try
    PWord(GetPointer(aOffset))^ := aValue;
  finally
    Unlock(aOffset, SizeOf(word));
  end;
end;

procedure TSharedMemory.Write32(aOffset: integer; aValue: cardinal);
begin
  Lock(aOffset, SizeOf(cardinal));
  try
    PCardinal(GetPointer(aOffset))^ := aValue;
  finally
    Unlock(aOffset, SizeOf(cardinal));
  end;
end;

procedure TSharedMemory.Write64(aOffset: integer; aValue: Int64);
begin
  Lock(aOffset, SizeOf(Int64));
  try
    PInt64(GetPointer(aOffset))^ := aValue;
  finally
    Unlock(aOffset, SizeOf(Int64));
  end;
end;

procedure TSharedMemory.CheckSize(aSize: Integer);
begin
  if aSize > FSize then
    raise Exception.Create('Size is too big');
end;

procedure TSharedMemory.Write8(aOffset: integer; aValue: byte);
begin
  Lock(aOffset, SizeOf(byte));
  try
    PByte(GetPointer(aOffset))^ := aValue;
  finally
    Unlock(aOffset, Sizeof(byte));
  end;
end;

end.

I cannot provide an example, since is under test, but I will...

A generic pool

Sometimes under some circunstances, there is a heavy object allocation/deallocation which penalizes the performance quite a lot, a way of improving this issue is an object pool (very similar to a database connection pool). Our implementation resides in BB.Pool and defined in this way:

{$M+}

  TObjectPool<T: class, constructor> = class(TPooledObject, IPool<T>)
  private
    FBusy,
    FFree: TList<T>;
    FOnDataNeeded: TNotifyEvent;
    FCurrent: integer;
    FOnReleaseObject: TNotifyEvent;
    FUseGarbage: boolean;
    FTimeOut: cardinal;
    FOnGarbage: TGarbageNotify;
    FOnKillObject: TNotifyEvent;
    FGarbageSleep: cardinal;
    FOnException: TMessageException;
    FCapacity: cardinal;
    FOnLog: TPoolLog;
    FOnGetObject: TNotifyEvent;
    FLock: ILock;
    FOnCreateObject: TNotifyEvent;
    FOwnObjects: boolean;

    function GetFree(aIndex: integer): T;
    function GetItem(aIndex: integer): T;
    procedure SetPooled(aObject: T);
    procedure CheckNull(aObject: T);
    procedure CheckCapacity;
    procedure ClearObject(aObject: T);
  protected
    function CreateClass: T; virtual;
    procedure DoRelease(aObject: T); virtual;
    procedure DoDataNeeded(aObject: T); virtual;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Clear; override;
    function Get: T; virtual;
    procedure Release(aObject: T);
    procedure ReleaseAll;
    procedure KillObject(aObject: T; aWaitGarbage: boolean = True);
    function Count: cardinal;
    function Used: integer;
    function NonUsed: integer;
    procedure Grow(aSize: cardinal);

    property FreeItems[index: integer]: T read GetFree;
    property UsedItems[index: integer]: T Read GetItem; default;
  published
    property Capacity: cardinal Read FCapacity Write FCapacity;
    property TimeOut: cardinal Read FTimeOut Write FTimeOut;
    property OnGetObject: TNotifyEvent Read FOnGetObject Write FOnGetObject;
    property OnException: TMessageException Read FOnException Write FOnException;
    property OnDataNeeded: TNotifyEvent Read FOnDataNeeded Write FOnDataNeeded;
    property OnReleaseObject: TNotifyEvent Read FOnReleaseObject Write FOnReleaseObject;
    property OnKillObject: TNotifyEvent Read FOnKillObject Write FOnKillObject;
    property OnCreateObject: TNotifyEvent read FOnCreateObject write FOnCreateObject;
    property OnLog: TPoolLog Read FOnLog Write FOnLog;
    property OwnObjects: boolean read FOwnObjects write FOwnObjects;
  end;
  {$M-}

Notice that there is a constraint in the generic, it can only be a class <T: class>, since the purpose is to store objects. The class can be used in a concurrent manner since it implements locking primitives.

Now the implementation:

{ TObjectPool<T> }

procedure TObjectPool<T>.Clear;
var
  i: integer;

begin
  inherited;

  FLock.Lock;
  try
    if FOwnObjects then
    begin
      for i := FFree.Count - 1 downto 0 do
        FFree[i].Free;
    end;
    FFree.Clear;

    if FOwnObjects then
    begin
      for i := FBusy.Count - 1 downto 0 do
        FBusy[i].Free;
    end;
    FBusy.Clear;
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.ClearObject(aObject: T);
var
  I: IPoolable;

begin
  if aObject.GetInterface(IPoolable, I) then
    I.Clear;
end;

function TObjectPool<T>.Count: cardinal;
begin
  Result := FFree.Count + FBusy.Count;
end;

constructor TObjectPool<T>.Create;
begin
  inherited Create;

  FOnLog := nil;
  FOnDataNeeded := nil;
  FOnReleaseObject := nil;
  FOnGetObject := nil;
  FOnKillObject := nil;
  FOnCreateObject := nil;
  FCurrent := -1;
  FTimeOut := 3000;
  FUseGarbage := False;
  FGarbageSleep := 30000;
  FOnGarbage := nil;
  FOnException := nil;
  FOwnObjects := True;
  FCapacity := MaxLongint;
  FFree := TList<T>.Create;
  FBusy := TList<T>.Create;
  FLock := TCriticalLock.Create;
end;

destructor TObjectPool<T>.Destroy;
begin
  Clear;

  FFree.Free;
  FBusy.Free;
  FLock := nil;

  inherited Destroy;
end;

procedure TObjectPool<T>.DoDataNeeded(aObject: T);
begin
  if Assigned(FOnGetObject) then
    FOnGetObject(aObject);
end;

procedure TObjectPool<T>.DoRelease(aObject: T);
begin
  if Assigned(FOnReleaseObject) then
    FOnReleaseObject(aObject);
end;

function TObjectPool<T>.Used: integer;
begin
  Result := FBusy.Count;
end;

function TObjectPool<T>.GetFree(aIndex: integer): T;
begin
  result := FFree[aIndex];
end;

function TObjectPool<T>.GetItem(aIndex: integer): T;
begin
  Result := FBusy[aIndex];
end;

function TObjectPool<T>.Get: T;
var
  i: integer;

begin
  FLock.Lock;
  try
    i := FFree.Count - 1;
    if i >= 0 then
    begin  //At least there is one free object
      Result := GetFree(i);
      FBusy.Add(Result);
      FFree.Delete(i);
      ClearObject(result);
    end else
    begin
      CheckCapacity;

      result := CreateClass;
      FBusy.Add(result);
      SetPooled(result);
    end;

    DoDataNeeded(Result);
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.Grow(aSize: cardinal);
var
  i: integer;
  l: TList<T>;

begin
  if Count + aSize > FCapacity then
    raise Exception.Create('Cannot grow more than capacity ' + IntToStr(FCapacity));

  FLock.Lock;
  try
    l := TList<T>.Create;
    try
      for i := 0 to aSize - 1 do
        l.Add(Get);
    finally
      for i := 0 to l.Count - 1 do
        Release(l[i]);
      l.Free;
    end;
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.CheckCapacity;
begin
  if Count >= FCapacity then
    raise ETooManyObjects.Create('Maximum objects reached', []);
end;

procedure TObjectPool<T>.CheckNull(aObject: T);
begin
  if aObject = nil then
    raise Exception.Create('Nil object is not valid');
end;

procedure TObjectPool<T>.KillObject(aObject: T; aWaitGarbage: boolean = True);
var
  i: integer;

begin
  FLock.Lock;
  try
    CheckNull(aObject);
    { TODO : Wait for garbage }

    i := FBusy.IndexOf(aObject);
    if i > -1 then
      FBusy.Delete(i)
    else
    begin
      i := FFree.IndexOf(aObject);
      if i = -1 then
        raise Exception.Create('Object ' + aObject.ClassName + ' not in pool');
      FFree.Delete(i);
    end;

    if Assigned(FOnKillObject) then
      FOnKillObject(aObject);

    if FOwnObjects then
      aObject.Free;
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.Release(aObject: T);
var
  item: T;

begin
  CheckNull(aObject);

  FLock.Lock;
  try
    item := FBusy.Extract(aObject);
    if item = nil then
      raise Exception.Create('Object ' + aObject.ClassName + ' not in pool');
    FFree.Add(item);

    DoRelease(aObject);
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.ReleaseAll;
var
  i: integer;

begin
  FLock.Lock;
  try
    for i := FBusy.Count - 1 downto 0 do
      FFree.Add(FBusy[i]);
    FBusy.Clear;
  finally
    FLock.UnLock;
  end;
end;

function TObjectPool<T>.CreateClass: T;
begin
  Result := T.Create;

  if Assigned(FOnCreateObject) then
    FOnCreateObject(result);
end;

function TObjectPool<T>.NonUsed: integer;
begin
  Result := FFree.Count;
end;

procedure TObjectPool<T>.SetPooled(aObject: T);
var
  I: IPoolable;

begin
  if aObject.GetInterface(IPoolable, I) then
    I.SetPooled(True);
end;

The use is quite easy:

var
  pool: TObjectPool<TObject>;
  i: integer;
  obj: TObject;

begin
  pool := TObjectPool<TObject>.Create;
  //Although this loop counts 1000000 elements, only one object is created
  for i := 0 to 999999 do
  begin
    obj := pool.Get;  //Every Get() must have its own Release()
    pool.Release;
  end;
end;
A proper use can be located in the 3d engine, the polygon system is cached this way.

Generic Tree

Looks like today is the generic collection day, now is time for a generic tree, it is located in BB.Collection.Tree.Generic.

Tree are a very fast way of insert, add, delete and search, but for linear access is slow (or at least not as fast as other types), for pure maintenance is the best structure, but not the best for specific task (only add or only delete, etc)

It looks like this:

type
  TNode<T> = class
  private
    FLeft: TNode<T>;
    FParent: TNode<T>;
    FRight: TNode<T>;
    FData: T;
  public
    constructor Create; virtual;

    property Parent: TNode<T> Read FParent Write FParent;
    property Left: TNode<T> Read FLeft Write FLeft;
    property Right: TNode<T> Read FRight Write FRight;
    property Data: T Read FData Write FData;
  end;

  TTree<T> = class(TVar, ICollection<T>)
  private
    FRoot,
    FCurrent: TNode<T>;
    FCount: integer;
    FOwnObjects: boolean;
    FDuplicates: boolean;
    FPool: TObjectPool;
    FComparer: IEqualityComparer<T>;

    function Get(aIndex: integer): T;
    procedure Put(aIndex: integer; aObject: T);
    function GetCount: integer;
    function FirstItem: T;
    function NextItem: T;
    function PriorItem: T;
    function LastItem: T;
    procedure AddNode(var aNode: TNode<T>; aParent: TNode<T>; aObject: T; aCmp: IComparable);
    procedure TryFreeObject(aItem: T);
  public
    constructor Create; override;
    destructor Destroy; override;
    function IndexOf(aObject: T): integer;
    function Add(aObject: T): integer;  
    procedure Delete(aObject: T);
    procedure Clear(aExcept: T); reintroduce; overload;
    procedure Clear; overload; override;
    function Extract(aObject: T): T;
    procedure Insert(aObject: T; aWhere: integer); virtual;
    function Clone: TObject; override;
    //IIterator
    function First: boolean;
    function Last: boolean;
    function Next: boolean;
    function GetCurrent: T;

    property Count: integer read GetCount;
    property Current: TNode<T> Read FCurrent;
    property Items[index: integer]: T Read Get Write Put; default;
    property OwnObjects: boolean Read FOwnObjects Write FOwnObjects;
    property Duplicates: boolean Read FDuplicates Write FDuplicates;
  end;

We have typical iterators and maintenance

Generic queues

If you have read the previous post, discusses generic Linked List, in this post I will present you generic queues.

In the chess game, the board is stored in a LIFO<TBoard> queue, so you can play deeper and deeper and easily undo/redo the board state.

It can be found in BB.Collection.Queue

Interface:

TQueue<T> = abstract class(TInterfacedObject, IStack<T>)
  private
    FItems: TLinkedList<T>;
    FCapacity: cardinal;

    function DoPush(aItem: T): integer;
  protected
    procedure QueueEmpty;
    procedure SetCapacity(aValue: cardinal); virtual;
    function IsFull: boolean;
    function Last(out aItem: T): boolean;
    function First(out aItem: T): boolean;
  public
    constructor Create; overload; virtual;
    constructor Create(aCapacity: integer); overload;
    destructor Destroy; override;
    function Push(aItem: T): integer; overload; virtual;
    function Pop: T; virtual; abstract;
    function TryPop(out aItem: T): boolean;
    procedure Clear;
    function IsEmpty: boolean; inline;
    function Count: integer; inline;
    function Extract(aIndex: integer): T;
    procedure Remove(aItem: T);

    property Capacity: cardinal read FCapacity write SetCapacity;
  end;

  TLIFO<T> = class(TQueue<T>)
  public
    constructor Create; override;
    function Pop: T; override;
  end;

  TFIFO<T> = class(TQueue<T>)
  public
    constructor Create; override;
    function Pop: T; override;
  end;

  TCircularQueue<T> = class(TQueue<T>)
  public
    function Push(aItem: T): integer; override;
  end;

Again nothing special, the classes inherit from abstract class TQueue<T> and internally they use Linked List for storing the data.

Implementation:

{ TQueue }

procedure TQueue<T>.Clear;
begin
  FItems.Clear;
end;

function TQueue<T>.Count: integer;
begin
  result := FItems.Count;
end;

constructor TQueue<T>.Create(aCapacity: integer);
begin
  Create;
  FCapacity := aCapacity;
end;

constructor TQueue<T>.Create;
begin
  inherited Create;

  FItems := TLinkedList<T>.Create;
  FCapacity := INFINITE;
end;

destructor TQueue<T>.Destroy;
begin
  FItems.Free;

  inherited;
end;

function TQueue<T>.Extract(aIndex: integer): T;
begin
  result := FItems[aIndex];
  FItems.Delete(result);
end;

function TQueue<T>.First(out aItem: T): boolean;
begin
  result := FItems.First;
  if result then
    aItem := FItems.GetCurrent;
end;

function TQueue<T>.IsEmpty: boolean;
begin
  result := Count = 0;
end;

procedure TQueue<T>.QueueEmpty;
begin
  raise Exception.Create('Queue empty');
end;

procedure TQueue<T>.Remove(aItem: T);
begin
  FItems.Delete(aItem);
end;

function TQueue<T>.DoPush(aItem: T): integer;
begin
  FItems.Add(aItem);
  result := Count - 1;
end;

function TQueue<T>.IsFull: boolean;
begin
  result := cardinal(Count) >= FCapacity;
end;

function TQueue<T>.Last(out aItem: T): boolean;
begin
  result := FItems.Last;
  if result then
    aItem := FItems.GetCurrent;
end;

function TQueue<T>.Push(aItem: T): integer;
begin
  if IsFull then
    raise Exception.Create('The stack has reach its limit');
  result := DoPush(aItem);
end;

procedure TQueue<T>.SetCapacity(aValue: cardinal);
begin
  FCapacity := aValue;
end;

function TQueue<T>.TryPop(out aItem: T): boolean;
begin
  result := Count > 0;
  if result then
    aItem := Pop;
end;

{ TLIFO }

constructor TLIFO<T>.Create;
begin
  inherited;

  FItems.SearchType := stFromLast;
end;

function TLIFO<T>.Pop: T;
begin
  if not Last(result) then
    QueueEmpty;

  Remove(result);
end;

{ TFIFO }

constructor TFIFO<T>.Create;
begin
  inherited;

  FItems.SearchType := stFromFirst;
end;

function TFIFO<T>.Pop: T;
begin
  if not First(result) then
    QueueEmpty;

  Remove(result);
end;

{ TCircularQueue }

function TCircularQueue<T>.Push(aItem: T): integer;
begin
  if IsFull then
    Pop;
  result := DoPush(aItem);
end;

end.