unit WaitFreeList;

interface

uses
  RyuLibBase, PacketList, SimpleThread,
  Windows, Classes, SysUtils;

type
  IWaitFreeObject = interface
    ['{C9CCDEF3-128D-4649-8D71-78F5ECDC19B0}']

    function IsDeleted:boolean;
    procedure SetDeleted(AVlaue:boolean);

    procedure WaitFreeObjectAdded;
    procedure WaitFreeObjectRemoved;

    function CompareWith(AObject:TObject):boolean;
    procedure WaitFreeObjectDuplicated;

    procedure SetLeftWaitFreeObject(AObject:TObject; AInterface:IWaitFreeObject);
    function GetLeftWaitFreeObject:TObject;
    function GetLeftWaitFreeInterface:IWaitFreeObject;

    procedure SetRightWaitFreeObject(AObject:TObject; AInterface:IWaitFreeObject);
    function GetRightWaitFreeObject:TObject;
    function GetRightWaitFreeInterface:IWaitFreeObject;
  end;

  IWaitFreeIterator = interface
    ['{13DD8A6A-5335-41C5-8FEA-BE7D41DC5C3E}']

    procedure Iterate(AHeader:IWaitFreeObject);
  end;

  TWaitFreeObject = class (TInterfaceBase, IWaitFreeObject, IWaitFreeIterator)
  strict private
    FIsDeleted : boolean;
    function IsDeleted:boolean;
    procedure SetDeleted(AValue:boolean);
  strict private
    FObjectLeft : TObject;
    FObjectRight : TObject;

    FInterfaceLeft : IWaitFreeObject;
    FInterfaceRight : IWaitFreeObject;

    procedure SetLeftWaitFreeObject(AObject:TObject; AInterface:IWaitFreeObject);
    function GetLeftWaitFreeObject:TObject;
    function GetLeftWaitFreeInterface:IWaitFreeObject;

    procedure SetRightWaitFreeObject(AObject:TObject; AInterface:IWaitFreeObject);
    function GetRightWaitFreeObject:TObject;
    function GetRightWaitFreeInterface:IWaitFreeObject;
  protected
    procedure Iterate(AHeader:IWaitFreeObject); virtual;
  protected
    procedure WaitFreeObjectAdded; virtual;
    procedure WaitFreeObjectRemoved; virtual;
  protected
    function CompareWith(AObject:TObject):boolean; virtual;
    procedure WaitFreeObjectDuplicated; virtual;
  public
    constructor Create; virtual;
  end;

  TSimpleIterateProcedure = reference to procedure(AWaitFreeObject:IWaitFreeObject);
  TIterateProcedure = reference to procedure(AWaitFreeObject:IWaitFreeObject; var ANeedStop:boolean);

  {*
    TWaitFreeObjectList is not perfect wait-free list.
    TWaitFreeObjectList provides wait-free read(Iterate) function.
  *}
  TWaitFreeObjectList = class
  private
    FAllowDuplicatedObject : boolean;
    FActionThread : TSimpleThread;
    procedure do_Clear;
    procedure do_Add(AObject:IWaitFreeObject);
    procedure do_Remove(AObject:IWaitFreeObject);
    procedure do_Iterate(AIterator:IWaitFreeIterator);
    procedure do_Duplicated(AObject:IWaitFreeObject);
    procedure delete_DuplicatedObject(AObject:IWaitFreeObject);
  private
    FHeaderInterface : IWaitFreeObject;
    FCount: integer;
    function GetIsEmpty: boolean;
    function GetIsBusy: boolean;
  public
    constructor Create(AAllowDuplicatedObject:boolean); reintroduce;
    destructor Destroy; override;

    procedure Clear;
    procedure Add(AObject:IWaitFreeObject);
    procedure Remove(AObject:IWaitFreeObject);

    function GetFirstObject:IWaitFreeObject;

    procedure Iterate(AProcedure:TSimpleIterateProcedure); overload;
    procedure Iterate(AProcedure:TIterateProcedure); overload;
    procedure Iterate(AIterator:IWaitFreeIterator); overload;

    property Header : IWaitFreeObject read FHeaderInterface;
    property IsBusy : boolean read GetIsBusy;
    property IsEmpty : boolean read GetIsEmpty;
    property Count : integer read FCount;
  end;

implementation

type
  TListAction = (laClear, laAdd, laRemove, laIterate);

  TActionThread = class (TSimpleThread)
  private
    FEventHandle: THandle;
    FList : TWaitFreeObjectList;
    FActionList : TPacketList;
  protected
    procedure Execute; override;
  public
    constructor Create(AList: TWaitFreeObjectList); reintroduce;
    destructor Destroy; override;

    procedure Clear;
    procedure Add(AObject:IWaitFreeObject);
    procedure Remove(AObject:IWaitFreeObject);
    procedure Iterate(AIterator:IWaitFreeIterator);

    procedure Stop;
  end;

{ TActionThread }

procedure TActionThread.Add(AObject: IWaitFreeObject);
begin
  FActionList.Add(Pointer(AObject), Pointer(laAdd));
  SetEvent(FEventHandle);
end;

procedure TActionThread.Clear;
begin
  FActionList.Add(nil, Pointer(laClear));
  SetEvent(FEventHandle);
end;

constructor TActionThread.Create(AList: TWaitFreeObjectList);
begin
  FEventHandle := CreateEvent(nil, false, false, nil);

  FList := AList;
  FActionList := TPacketList.Create;

  FreeOnTerminate := true;

  inherited Create;
end;

destructor TActionThread.Destroy;
begin
  Stop;

  FreeAndNil(FActionList);

  inherited;
end;

procedure TActionThread.Execute;
var
  ListAction : pointer;
  TargetObject : pointer;
begin
  while not Terminated do begin
    while FActionList.Get(TargetObject, ListAction) do begin;
      case TListAction(ListAction) of
        laClear:   FList.do_Clear;
        laAdd:     FList.do_Add(IWaitFreeObject(TargetObject));
        laRemove:  FList.do_Remove(IWaitFreeObject(TargetObject));
        laIterate: FList.do_Iterate(IWaitFreeIterator(TargetObject));
      end;
    end;

    if not Terminated then WaitforSingleObject(FEventHandle, INFINITE);
  end;
end;

procedure TActionThread.Iterate(AIterator: IWaitFreeIterator);
begin
  FActionList.Add(Pointer(AIterator), Pointer(laIterate));
  SetEvent(FEventHandle);
end;

procedure TActionThread.Remove(AObject: IWaitFreeObject);
begin
  FActionList.Add(Pointer(AObject), Pointer(laRemove));
  SetEvent(FEventHandle);
end;

procedure TActionThread.Stop;
begin
  Terminate;
  SetEvent(FEventHandle);
end;

{ TWaitFreeObject }

function TWaitFreeObject.CompareWith(AObject: TObject): boolean;
begin
  Result := false;
end;

constructor TWaitFreeObject.Create;
begin
  inherited;

  FIsDeleted := true;

  FObjectLeft     := nil;
  FObjectRight    := nil;
  FInterfaceLeft  := nil;
  FInterfaceRight := nil;
end;

function TWaitFreeObject.GetLeftWaitFreeInterface: IWaitFreeObject;
begin
  Result := FInterfaceLeft;
end;

function TWaitFreeObject.GetLeftWaitFreeObject: TObject;
begin
  Result := FObjectLeft;
end;

function TWaitFreeObject.GetRightWaitFreeInterface: IWaitFreeObject;
begin
  Result := FInterfaceRight;
end;

function TWaitFreeObject.GetRightWaitFreeObject: TObject;
begin
  Result := FObjectRight;
end;

function TWaitFreeObject.IsDeleted: boolean;
begin
  Result := FIsDeleted;
end;

procedure TWaitFreeObject.Iterate(AHeader: IWaitFreeObject);
begin
end;

procedure TWaitFreeObject.SetDeleted(AValue: boolean);
begin
  FIsDeleted := AValue;
end;

procedure TWaitFreeObject.SetLeftWaitFreeObject(AObject: TObject;
  AInterface: IWaitFreeObject);
begin
  FObjectLeft    := AObject;
  FInterfaceLeft := AInterface;

  {$IFDEF DEBUG}
//  OutputDebugString(PChar(Format('TWaitFreeObject.SetLeftWaitFreeObject: Self=%d, Left=%d', [Integer(Self), Integer(AObject)])));
  {$ENDIF}
end;

procedure TWaitFreeObject.SetRightWaitFreeObject(AObject: TObject;
  AInterface: IWaitFreeObject);
begin
  FObjectRight    := AObject;
  FInterfaceRight := AInterface;

  {$IFDEF DEBUG}
//  OutputDebugString(PChar(Format('TWaitFreeObject.SetRightWaitFreeObject: Self=%d, Right=%d', [Integer(Self), Integer(AObject)])));
  {$ENDIF}
end;

procedure TWaitFreeObject.WaitFreeObjectAdded;
begin
end;

procedure TWaitFreeObject.WaitFreeObjectDuplicated;
begin
end;

procedure TWaitFreeObject.WaitFreeObjectRemoved;
begin
end;

{ TWaitFreeObjectList }

procedure TWaitFreeObjectList.Add(AObject: IWaitFreeObject);
begin
  TActionThread(FActionThread).Add(AObject)
end;

procedure TWaitFreeObjectList.Clear;
begin
  TActionThread(FActionThread).Clear;
end;

constructor TWaitFreeObjectList.Create(AAllowDuplicatedObject: boolean);
begin
  inherited Create;

  FAllowDuplicatedObject := AAllowDuplicatedObject;

  FCount := 0;
  FHeaderInterface := nil;

  FActionThread := TActionThread.Create(Self);
end;

procedure TWaitFreeObjectList.delete_DuplicatedObject(AObject: IWaitFreeObject);
var
  Node : IWaitFreeObject;
begin
  Node := FHeaderInterface;
  while node <> nil do begin
    if Node.CompareWith(AObject as TObject) then do_Duplicated(Node);
    Node := Node.GetRightWaitFreeInterface;
  end;
end;

destructor TWaitFreeObjectList.Destroy;
begin
  TActionThread(FActionThread).Stop;

  do_Clear;

  inherited;
end;

procedure TWaitFreeObjectList.do_Add(AObject: IWaitFreeObject);
begin
  if AObject = nil then Exit;

  if not AObject.IsDeleted then Exit;
  AObject.SetDeleted(false);

  if not FAllowDuplicatedObject then delete_DuplicatedObject(AObject);

  AObject.SetLeftWaitFreeObject(nil, nil);

  if FHeaderInterface <> nil then begin
    FHeaderInterface.SetLeftWaitFreeObject(AObject as TObject, AObject);
    AObject.SetRightWaitFreeObject(FHeaderInterface as TObject, FHeaderInterface);
  end else begin
    AObject.SetRightWaitFreeObject(nil, nil);
  end;

  FHeaderInterface := AObject;

  AObject.WaitFreeObjectAdded;

  InterlockedIncrement(FCount);
end;

procedure TWaitFreeObjectList.do_Clear;
var
  OldHeader : IWaitFreeObject;
begin
  OldHeader := IWaitFreeObject(InterlockedExchangePointer(Pointer(FHeaderInterface), nil));
  FCount := 0;

  while OldHeader <> nil do begin
    OldHeader.WaitFreeObjectRemoved;
    OldHeader := OldHeader.GetRightWaitFreeInterface;
  end;
end;

procedure TWaitFreeObjectList.do_Duplicated(AObject: IWaitFreeObject);
var
  LeftObject, RightObject : TObject;
  LeftNode, RightNode : IWaitFreeObject;
begin
  if AObject = nil then Exit;

  if AObject.IsDeleted then Exit;
  AObject.SetDeleted(true);

  LeftNode  := AObject.GetLeftWaitFreeInterface;
  if LeftNode <> nil then LeftObject := LeftNode as TObject
  else LeftObject := nil;

  RightNode := AObject.GetRightWaitFreeInterface;
  if RightNode <> nil then RightObject := RightNode as TObject
  else RightObject := nil;

  if AObject = FHeaderInterface then FHeaderInterface := RightNode;

  if LeftNode  <> nil then LeftNode .SetRightWaitFreeObject(RightObject, RightNode);
  if RightNode <> nil then RightNode.SetLeftWaitFreeObject (LeftObject,  LeftNode);

  AObject.WaitFreeObjectDuplicated;

  InterlockedDecrement(FCount);
end;

procedure TWaitFreeObjectList.do_Iterate(AIterator: IWaitFreeIterator);
begin
  AIterator.Iterate(FHeaderInterface);
end;

procedure TWaitFreeObjectList.do_Remove(AObject: IWaitFreeObject);
var
  LeftObject, RightObject : TObject;
  LeftNode, RightNode : IWaitFreeObject;
begin
  if AObject = nil then Exit;

  if AObject.IsDeleted then Exit;
  AObject.SetDeleted(true);

  LeftNode  := AObject.GetLeftWaitFreeInterface;
  if LeftNode <> nil then LeftObject := LeftNode as TObject
  else LeftObject := nil;

  RightNode := AObject.GetRightWaitFreeInterface;
  if RightNode <> nil then RightObject := RightNode as TObject
  else RightObject := nil;

  if AObject = FHeaderInterface then FHeaderInterface := RightNode;

  if LeftNode  <> nil then LeftNode .SetRightWaitFreeObject(RightObject, RightNode);
  if RightNode <> nil then RightNode.SetLeftWaitFreeObject (LeftObject,  LeftNode);

  AObject.WaitFreeObjectRemoved;

  InterlockedDecrement(FCount);
end;

function TWaitFreeObjectList.GetFirstObject: IWaitFreeObject;
begin
  Result := FHeaderInterface;
end;

function TWaitFreeObjectList.GetIsBusy: boolean;
begin
  Result := TActionThread(FActionThread).FActionList.Count > 0;
end;

function TWaitFreeObjectList.GetIsEmpty: boolean;
begin
  Result := FHeaderInterface = nil;
end;

procedure TWaitFreeObjectList.Iterate(AProcedure: TSimpleIterateProcedure);
var
  Node : IWaitFreeObject;
begin
  Node := FHeaderInterface;
  while node <> nil do begin
    AProcedure(Node);
    Node := Node.GetRightWaitFreeInterface;
  end;
end;

procedure TWaitFreeObjectList.Iterate(AProcedure: TIterateProcedure);
var
  Node : IWaitFreeObject;
  NeedStop : boolean;
begin
  NeedStop := false;

  Node := FHeaderInterface;
  while node <> nil do begin
    AProcedure(Node, NeedStop);

    if NeedStop then Break;

    Node := Node.GetRightWaitFreeInterface;
  end;
end;

procedure TWaitFreeObjectList.Remove(AObject: IWaitFreeObject);
begin
  TActionThread(FActionThread).Remove(AObject);
end;

procedure TWaitFreeObjectList.Iterate(AIterator: IWaitFreeIterator);
begin
  TActionThread(FActionThread).Iterate(AIterator);
end;

{ TTestNode }

type
  TTestNode = class (TWaitFreeObject)
  private
  public
    Data : integer;
    constructor Create(AData:integer); reintroduce;
  end;

constructor TTestNode.Create(AData: integer);
begin
  inherited Create;

  Data := AData;
end;

{$IFDEF DEBUG}
var
  Str : set of byte;
  List : TWaitFreeObjectList;
{$ENDIF}

initialization
{$IFDEF DEBUG}
  List := TWaitFreeObjectList.Create(false);
  try
    List.Add(TTestNode.Create(1));
    List.Add(TTestNode.Create(2));
    List.Add(TTestNode.Create(3));

    while List.IsBusy do Sleep(10);

    Str := [];
    List.Iterate(
      procedure (WaitFreeObject:IWaitFreeObject; var NeedStop:boolean) begin
        Str := Str + [TTestNode(WaitFreeObject).Data];
      end
    );
    Assert(Str = [1, 2, 3], 'Str = [1, 2, 3]');

  finally
    List.Free;
  end;
{$ENDIF}
end.
