[Source]Delphi Collection Classes Architecture

[cying (應)]

{

各位使用過 Delphi 以及使用過 Java 應該都知道，在 Delphi 裡面事實上大概只有

兩種容器可以使用：TList 以及 TStringList，其他的容器都是用這兩個容器做出來

的（像TCollection、TComponent、TControl）等等都是。前一陣子由於研究Java 2.0

的 Collection class architecture 不禁感嘆其架構之完美性，回頭看看 Delphi 如

此優秀的語言在此方面卻顯出其缺陷，只有 TList 可以用（又只能存 Pointer ），

我想對初學者而言是相當難以接受的一部份。

而且說穿了，TList 也不是 Linked-List 而比較像是 Vector of pointer ，Delphi 4

出來之後即有了 Dynamic array，不一定要用 TList 才能裝東西，而且 Dynamic array

還是 type-safe 的。在此列出比較：

TList
==============
var
  Ar: TList;
  I: Integer;
begin
  Ar := TList.Create;
  Ar.Add(Pointer(123)); // <<--存入時要做此種cast!!
  I := Integer(Ar[0]);  // <-- 拿出來還要做此種 cast!!! 真是噁爛
end;

Dynamic array:
==============

var Ar: array of Integer;
  I: Integer;
begin
  SetLength(Ar, 1);
  Ar[0] := 123;
  I := Ar[0];
end;


不過這和下面要講的沒什麼關係，只是 Delphi 4 雖有了 Dynamic array 卻還是缺少了

很多基本的資料結構如 Doubly-linked-list 、 Hash table 、 Balanced binary

search tree等等。而我有點模仿 Java 2.0 的 Collection classes 架構私下寫了

幾個兩個的容器：TDeque、TTreeMap，以及幾個有用的介面：IMap、ICollection、

IIterator、IListIterator、IMapIterator、IStringList、IStringMap，以及幾個應用

層面的classes，像是 TEventMultiplexer 等，待各位等下看了程式碼，就會發現所有

程式都是用最新版的 Delphi 寫的，必須要用到 COM 的 interface 觀念（雖然私下

覺得 COM 又肥又大又沒用，不過 Delphi compiler 真的把 interface 寫得好好用喔！

），所以別誤會，雖然用到了interface以及GUID，實際上卻跟 COM 沒什麼瓜葛...


這些 class 中大概就屬 TTreeMap 最令人頭疼了，我使用了資料結構課本上的

「紅黑樹」，這實在是極端複雜...課本程式碼錯誤百出，害得我到最後還得去

看 Java 2.0 怎麼寫的，真是...

}



unit Patt;

interface

uses
  SysUtils, ComObj, Classes;

type
  TBasicObject = class;

  EStorableError = class(Exception)
  end;

  IBasicObject = interface
    ['{A8DAD303-BAF6-11D2-8A0E-00E098142233}']
    function GetObject: TBasicObject;
    function Supports(const IID: TGUID): Boolean;
  end;

  IComparator = interface
    ['{A8DAD302-BAF6-11D2-8A0E-00E098142233}']
    function Compare(a, b: Pointer): Integer;
    procedure Finalize(a: Pointer);
    function Initialize(a: Pointer): Pointer;
  end;

  IIterator = interface
    ['{D7C27BE1-BAC0-11D2-8A0E-00E098142233}']
    function HasElement: Boolean;
    function Get: Pointer;
    procedure Put(Value: Pointer);
    procedure Remove;
    procedure Next;
  end;

  IListIterator = interface
    ['{A8DAD307-BAF6-11D2-8A0E-00E098142233}']
    function HasElement: Boolean;
    function Get: Pointer;
    procedure Remove;
    procedure Next;
    procedure Prior;
    function GetIndex: Integer;

    procedure Add(Value: Pointer);
    procedure Put(Value: Pointer);
  end;

  IMapIterator = interface
    ['{A8DAD308-BAF6-11D2-8A0E-00E098142233}']
    function HasElement: Boolean;
    procedure Next;
    function GetKey: Pointer;
    function GetValue: Pointer;

    procedure Remove;
    procedure SetKey(Key: Pointer);
    procedure SetValue(Value: Pointer);

    property Value: Pointer read GetValue write SetValue;
    property Key: Pointer read GetKey write SetKey;
  end;

  ICollection = interface(IBasicObject)
    ['{D7C27BE2-BAC0-11D2-8A0E-00E098142233}']
    procedure Add(Value: Pointer);
    function Remove(Value: Pointer): Boolean;
    procedure AddAll(C: ICollection);
    procedure RetainAll(C: ICollection);
    procedure RemoveAll(C: ICollection);
    procedure Clear;
    function Iterator: IIterator;
    function IsEmpty: Boolean;
    function Contains(Value: Pointer): Boolean;
    function ContainsAll(C: ICollection): Boolean;
    function CollectionEquals(Value: ICollection): Boolean;

    function GetSize: Integer;
    property Size: Integer read GetSize;

    function GetComparator: IComparator;
    procedure SetComparator(Value: IComparator);
    property Comparator: IComparator read GetComparator write SetComparator;
  end;

  IList = interface(ICollection)
    ['{A8DAD300-BAF6-11D2-8A0E-00E098142233}']
    procedure AddFirst(Value: Pointer);
    procedure AddLast(Value: Pointer);
    function RemoveFirst: Pointer;
    function RemoveLast: Pointer;
    function ReversedIterator: IIterator;
    function ListIterator(Index: Integer): IListIterator;
  end;

  TBasicObject = class(TInterfacedObject, IBasicObject)
  public
    constructor CreateEmpty; virtual;
    function GetObject: TBasicObject;
    function Supports(const IID: TGUID): Boolean;
  end;

  TBasicClass = class of TBasicObject;

  ECollectionError = class(Exception)
  end;

  TDequeNode = class
    Value: Pointer;
    Next, Prev: TDequeNode;
    constructor Create(Value: Pointer; Next, Prev: TDequeNode);
  end;

  TAbstractCollection = class(TBasicObject, ICollection)
  protected
    FComparator: IComparator;
  public
    function GetComparator: IComparator; virtual;
    procedure SetComparator(Value: IComparator); virtual;
  public
    procedure AddAll(C: ICollection); virtual;
    procedure RetainAll(C: ICollection); virtual;
    procedure RemoveAll(C: ICollection); virtual;
    function ContainsAll(C: ICollection): Boolean; virtual;
    function IsEmpty: Boolean; virtual;
  public
    function Contains(Value: Pointer): Boolean; virtual; abstract;
    procedure Clear; virtual; abstract;
    procedure Add(Value: Pointer); virtual; abstract;
    function Remove(Value: Pointer): Boolean; virtual; abstract;
    function Iterator: IIterator; virtual; abstract;
    function GetSize: Integer; virtual; abstract;
    function CollectionEquals(Value: ICollection): Boolean; virtual;
  public
    property Size: Integer read GetSize;
    property Comparator: IComparator read GetComparator write SetComparator;
  end;

  TDeque = class(TAbstractCollection, IList)
  private
    FFirst, FLast: TDequeNode;
    FSize: Integer;
    function GetNodeAt(Index: Integer): TDequeNode;
  public
    constructor Create;
    procedure AddFirst(Value: Pointer);
    procedure AddLast(Value: Pointer);
    procedure Add(Value: Pointer); override;
    function RemoveFirst: Pointer;
    function RemoveLast: Pointer;
    function Remove(Value: Pointer): Boolean; override;
    function Iterator: IIterator; override;
    function ListIterator(Index: Integer): IListIterator;
    function ReversedIterator: IIterator;
    function GetSize: Integer; override;
    function Contains(Value: Pointer): Boolean; override;
    procedure Clear; override;
  end;

  TNodeColor = (ncRED, ncBLACK);

  TTreeMap = class;

  TTreeNode = class
  private
    function GetColor: TNodeColor;
    function GetLeft: TTreeNode;
    function GetParent: TTreeNode;
    function GetRight: TTreeNode;
    procedure SetColor(const Value: TNodeColor);
    procedure SetLeft(const Value: TTreeNode);
    procedure SetParent(const Value: TTreeNode);
    procedure SetRight(const Value: TTreeNode);
  public
    FLeft, FRight, FParent: TTreeNode;
    FColor: TNodeColor;
    Key, Value: Pointer;
    constructor Create;
    property Parent: TTreeNode read GetParent write SetParent;
    property Left: TTreeNode read GetLeft write SetLeft;
    property Right: TTreeNode read GetRight write SetRight;
    property Color: TNodeColor read GetColor write SetColor;
    procedure Clear(TreeMap: TTreeMap);
  end;

  TTreeMapIterator = class(TBasicObject, IMapIterator, IIterator, IListIterator)
  private
    Map: TTreeMap;
    Cursor: TTreeNode;
    Reversed: Boolean;
    constructor Create(Cursor: TTreeNode; Map: TTreeMap; Reversed: Boolean);
  public
    function HasElement: Boolean;
    function GetKey: Pointer;
    function GetValue: Pointer;
    function Get: Pointer; virtual;
    procedure Next;
    procedure Prior;
    procedure Remove;
    procedure SetKey(Key: Pointer);
    procedure SetValue(Value: Pointer);
    function GetIndex: Integer;
    procedure Add(Value: Pointer);
    procedure Put(Value: Pointer);
  public
    property Value: Pointer read GetValue write SetValue;
    property Key: Pointer read GetKey write SetKey;
  end;

  TMapKeyIterator = class(TTreeMapIterator)
  public
    function Get: Pointer; override;
  end;

  IMap = interface
    ['{541E3F60-BB72-11D2-8A0E-00E098142233}']
    procedure Clear;
    procedure Put(Key, Value: Pointer);
    function RemoveKey(Key: Pointer): Boolean;
    function RemoveValue(Value: Pointer): Boolean;

    function GetSize: Integer;
    function Get(Key: Pointer): Pointer;
    function FindKey(Key: Pointer): IMapIterator;
    function Iterator: IIterator;
    function MapIterator: IMapIterator;
    function ReversedIterator: IIterator;

    function GetValueComparator: IComparator;
    procedure SetValueComparator(const Value: IComparator);
    function GetKeyComparator: IComparator;
    procedure SetKeyComparator(const Value: IComparator);

    property Size: Integer read GetSize;
    property ValueComparator: IComparator read GetValueComparator write SetValueComparator;
    property KeyComparator: IComparator read GetKeyComparator write SetKeyComparator;

    function ContainsKey(Key: Pointer): Boolean;
    function ContainsValue(Value: Pointer): Boolean;
    procedure PutAll(M: IMap);

    function IsEmpty: Boolean;

    function MapEquals(M: IMap): Boolean;

    function Keys: ICollection;
    function Values: ICollection;
  end;

  TAbstractMap = class(TBasicObject, IMap)
  protected
    FKeyOwnership: Boolean;
    FValueOwnership: Boolean;
  protected
    FValueComparator, FKeyComparator: IComparator;
  public
    constructor Create;
    function GetValueComparator: IComparator;
    procedure SetValueComparator(const Value: IComparator);
    function GetKeyComparator: IComparator;
    procedure SetKeyComparator(const Value: IComparator);
  public
    procedure Clear; virtual; abstract;
    procedure Put(Key, Value: Pointer); virtual; abstract;
    function RemoveKey(Key: Pointer): Boolean; virtual; abstract;
    function RemoveValue(Value: Pointer): Boolean; virtual; abstract;
    function GetSize: Integer; virtual; abstract;
    function Get(Key: Pointer): Pointer; virtual; abstract;
    function FindKey(Key: Pointer): IMapIterator; virtual; abstract;
    function Iterator: IIterator; virtual; abstract;
    function MapIterator: IMapIterator; virtual; abstract;

    function ReversedIterator: IIterator; virtual;
    function ContainsKey(Key: Pointer): Boolean; virtual;
    function ContainsValue(Value: Pointer): Boolean; virtual;
    procedure PutAll(M: IMap); virtual;

    function MapEquals(M: IMap): Boolean; virtual;

    function Keys: ICollection; virtual; abstract;
    function Values: ICollection; virtual; abstract;

    function IsEmpty: Boolean;
  public
    property Size: Integer read GetSize;
    property ValueComparator: IComparator read GetValueComparator write SetValueComparator;
    property KeyComparator: IComparator read GetKeyComparator write SetKeyComparator;
  end;

  TTreeMap = class(TAbstractMap)
  private
    FSize: Integer;
    FRoot: TTreeNode;
    FKeys: ICollection;
    FValues: ICollection;
    function TreeMinimum(x: TTreeNode): TTreeNode;
    function TreeMaximum(x: TTreeNode): TTreeNode;
    procedure LeftRotate(x: TTreeNode);
    procedure RightRotate(x: TTreeNode);
    procedure TreeInsert(z: TTreeNode);
    function TreeSuccessor(x: TTreeNode): TTreeNode;
    function TreePredecessor(x: TTreeNode): TTreeNode;
    procedure RB_Insert(x: TTreeNode);
    procedure RB_Delete(p: TTreeNode);
    procedure RB_DeleteFixup(x: TTreeNode);
    procedure SwapPosition(x, y: TTreeNode);
    function FindNode(Key: Pointer): TTreeNode;
  public
    procedure Clear; override;
    procedure Put(Key, Value: Pointer); override;
    function RemoveKey(Key: Pointer): Boolean; override;
    function RemoveValue(Value: Pointer): Boolean; override;
    function GetSize: Integer; override;
    function Get(Key: Pointer): Pointer; override;
    function FindKey(Key: Pointer): IMapIterator; override;
    function Iterator: IIterator; override;
    function MapIterator: IMapIterator; override;
    function ReversedIterator: IIterator; override;

    function Keys: ICollection; override;
    function Values: ICollection; override;

    destructor Destroy; override;
  end;

  TTreeSet = class(TAbstractCollection)
  protected
    FMap: IMap;
  public
    constructor Create;
    function Contains(Value: Pointer): Boolean; override;
    procedure Clear; override;
    procedure Add(Value: Pointer); override;
    function Remove(Value: Pointer): Boolean; override;
    function Iterator: IIterator; override;
    function GetSize: Integer; override;
//    function CollectionEquals(Value: ICollection): Boolean; override;

    function GetComparator: IComparator; override;
    procedure SetComparator(Value: IComparator); override;
  end;

  TBlobComparator = class(TBasicObject, IComparator)
  public
    Length: Integer;
    constructor Create(Length: Integer);
    function Compare(a, b: Pointer): Integer;
    function Initialize(a: Pointer): Pointer;
    procedure Finalize(a: Pointer);
  end;

  TObjectComparator = class(TBasicObject, IComparator)
  public
    function Compare(a, b: Pointer): Integer;
    function Initialize(a: Pointer): Pointer;
    procedure Finalize(a: Pointer);
  end;

  TEventMultiplexer = class
  public
    FListeners: IList;
    constructor Create;
    procedure Add(Method: TNotifyEvent);
    procedure Remove(Method: TNotifyEvent);
    procedure RemoveSource(Source: TObject);
    procedure FireNotifyEvent(Sender: TObject);
    function Iterator: IIterator;
  end;

  TStringComparator = class(TBasicObject, IComparator)
    function Compare(a, b: Pointer): Integer;
    procedure Finalize(a: Pointer);
    function Initialize(a: Pointer): Pointer;
  end;

  IStringIterator = interface
    ['{07666934-BDBD-11D2-88CE-000021994143}']
    function HasElement: Boolean;
    function Get: string;
    procedure Next;
  end;

  IStringList = interface
    ['{07666933-BDBD-11D2-88CE-000021994143}']
    procedure Add(Value: string);
    function Remove(Value: string): Boolean;
    procedure AddAll(C: IStringList);
    procedure RetainAll(C: IStringList);
    procedure RemoveAll(C: IStringList);
    procedure Clear;
    function StringIterator: IStringIterator;
    function Iterator: IIterator;
    function IsEmpty: Boolean;
    function Contains(Value: string): Boolean;
    function ContainsAll(C: IStringList): Boolean;
    function CollectionEquals(Value: IStringList): Boolean;

    function GetSize: Integer;
    property Size: Integer read GetSize;
  end;

  IStringMap = interface
    ['{07666932-BDBD-11D2-88CE-000021994143}']
    procedure Clear;
    procedure Put(Key: string; Value: Pointer);
    function RemoveKey(Key: string): Boolean;
    function RemoveValue(Value: Pointer): Boolean;

    function GetSize: Integer;
    function Get(Key: string): Pointer;
    function FindKey(Key: string): IIterator;
    function Iterator: IIterator;

    function GetComparator: IComparator;
    procedure SetComparator(const Value: IComparator);

    property Size: Integer read GetSize;
    property Comparator: IComparator read GetComparator write SetComparator;

    function ContainsKey(Key: string): Boolean;
    function ContainsValue(Key: Pointer): Boolean;

    function Keys: IStringList;
    function Values: ICollection;

    function IsEmpty: Boolean;
  end;

  TStringMap = class(TBasicObject, IStringMap)
  private
    FMap: IMap;
    FKeys: IStringList;
  public
    constructor Create;

    procedure Clear;
    procedure Put(Key: string; Value: Pointer);
    function RemoveKey(Key: string): Boolean;
    function RemoveValue(Value: Pointer): Boolean;

    function GetSize: Integer;
    function Get(Key: string): Pointer;
    function FindKey(Key: string): IIterator;
    function Iterator: IIterator;

    function GetComparator: IComparator;
    procedure SetComparator(const Value: IComparator);

    property Size: Integer read GetSize;
    property Comparator: IComparator read GetComparator write SetComparator;

    function ContainsKey(Key: string): Boolean;
    function ContainsValue(Key: Pointer): Boolean;

    function Keys: IStringList;
    function Values: ICollection;

    function IsEmpty: Boolean;
  end;

  TCollections = class
    class function CreateList: IList;
    class function CreateMap: IMap;
    class function CreateStringMap: IStringMap;
  end;

implementation

type
  TDequeIterator = class(TInterfacedObject, IListIterator, IIterator)
  public
    function HasElement: Boolean;
    function Get: Pointer;
    procedure Next;
    procedure Put(Value: Pointer);
    procedure Add(Value: Pointer);
    function GetIndex: Integer;
    procedure Prior;
    procedure Remove;
  private
    Index: Integer;
    Deque: TDeque;
    Cursor: TDequeNode;
    Reversed: Boolean;
    constructor Create(Deque: TDeque; Cursor: TDequeNode; Reversed: Boolean; Index: Integer);
  end;

procedure CollectionError(Msg: string);
begin
  raise ECollectionError.Create(Msg);
end;

function Supports(Intf: IUnknown; const IID: TGUID): Boolean;
var
  Buf: Integer;
begin
  Intf.QueryInterface(IID, Buf);
  Result := Buf <> 0;
end;

procedure UnsupportedError;
begin
  CollectionError('Unsupported operation');
end;

function CompareObject(a, b: Pointer; Cmp: IComparator): Integer;
begin
  if Cmp <> nil then
    Result := Cmp.Compare(a, b)
  else
    Result := Integer(a) - Integer(b);
end;

procedure FinalizeObject(a: Pointer; Cmp: IComparator);
begin
  if Cmp <> nil then
    Cmp.Finalize(a);
end;

function InitializeObject(b: Pointer; Cmp: IComparator): Pointer;
begin
  if Cmp <> nil then
    Result := Cmp.Initialize(b)
  else
    Result := b;
end;

procedure ComparasionError;
begin
  CollectionError('Cannot perform comparasion on different type of object');
end;

{ TDeque }

procedure TDeque.Add(Value: Pointer);
begin
  AddLast(Value);
end;

procedure TDeque.AddLast(Value: Pointer);
var
  N: TDequeNode;
begin
  N := TDequeNode.Create(InitializeObject(Value, FComparator), nil, FLast);
  if FLast <> nil then
    FLast.Next := N;
  FLast := N;
  if FFirst = nil then
    FFirst := FLast;
  Inc(FSize);
end;

procedure TDeque.AddFirst(Value: Pointer);
var
  N: TDequeNode;
begin
  N := TDequeNode.Create(InitializeObject(Value, FComparator), FFirst, nil);
  if FFirst <> nil then
    FFirst.Prev := N;
  FFirst := N;
  if FLast = nil then
    FLast := FFirst;
  Inc(FSize);
end;

constructor TDeque.Create;
begin
end;

function TDeque.Iterator: IIterator;
begin
  Result := TDequeIterator.Create(Self, FFirst, False, 0);
end;

function TDeque.Remove(Value: Pointer): Boolean;
var
  N: TDequeNode;
begin
  N := FFirst;
  while N <> nil do
  begin
    if CompareObject(N.Value, Value, FComparator) = 0 then
    begin
      if N = FFirst then
      begin
        FFirst := FFirst.Next;
        FFirst.Prev := nil;
      end
      else
      begin
        N.Prev.Next := N.Next;
        N.Next.Prev := N.Prev;
      end;
      FinalizeObject(N.Value, FComparator);
      N.Free;
      Result := True;
      Dec(FSize);
      Exit;
    end;
    N := N.Next;
  end;
  Result := False;
end;

function TDeque.RemoveLast: Pointer;
var
  N: TDequeNode;
begin
  if FSize = 0 then
    CollectionError('Cannot not remove any last element in an empty deque');
  N := FLast;
  FLast := FLast.Prev;
  if FLast <> nil then
    FLast.Next := nil
  else
    FFirst := nil;
  Result := N.Value;
  FinalizeObject(N.Value, FComparator);
  N.Free;
  Dec(FSize);
end;

function TDeque.RemoveFirst: Pointer;
var
  N: TDequeNode;
begin
  if FSize = 0 then
    CollectionError('Cannot not remove any last element in an empty deque');
  N := FFirst;
  FFirst := FFirst.Next;
  if FFirst <> nil then
    FFirst.Prev := nil
  else
    FLast := nil;
  Result := N.Value;
  FinalizeObject(N.Value, FComparator);
  N.Free;
  Dec(FSize);
end;

function TDeque.ReversedIterator: IIterator;
begin
  Result := TDequeIterator.Create(Self, FLast, True, FSize-1);
end;

function TDeque.GetSize: Integer;
begin
  Result := FSize;
end;

function TDeque.Contains(Value: Pointer): Boolean;
var
  N: TDequeNode;
begin
  N := FFirst;
  while N <> nil do
  begin
    if CompareObject(N.Value, Value, FComparator) = 0 then
    begin
      Result := True;
      Exit
    end;
    N := N.Next;
  end;
  Result := False;
end;

function CompareBasicObject(a, b: Pointer; Comparator: IComparator): Integer;
begin
  if Comparator = nil then
    Result := Integer(a) - Integer(b) // Pointer comparasion
  else
    Result := Comparator.Compare(a, b);
end;

procedure TDeque.Clear;
var
  p, pp: TDequeNode;
begin
  p := FFirst;
  while p <> nil do
  begin
    pp := p.Next;
    p.Free;
    p := pp;
  end;
  FFirst := nil;
  FLast := nil;
  FSize := 0;
end;

function TDeque.ListIterator(Index: Integer): IListIterator;
begin
  Result := TDequeIterator.Create(Self, GetNodeAt(Index), False, Index);
end;

function TDeque.GetNodeAt(Index: Integer): TDequeNode;
var
  I: Integer;
begin
  if (Index >= 0) and (Index < (FSize div 2)) then
  begin
    I := 0;
    Result := FFirst;
    while (Result <> nil) and (I <> Index) do
    begin
      Inc(I);
      Result := Result.Next;
    end;
    if Result = nil then
      CollectionError('Deque access out of range');
  end
  else if (Index >= (FSize div 2)) and (Index < FSize) then
  begin
    I := FSize-1;
    Result := FLast;
    while (Result <> nil) and (I <> Index) do
    begin
      Dec(I);
      Result := Result.Next;
    end;
    if Result = nil then
      CollectionError('Deque access out of range');
  end else
  begin
    Result := nil;
    CollectionError('Deque access out of range');
  end;
end;

{ TDequeNode }

constructor TDequeNode.Create(Value: Pointer; Next, Prev: TDequeNode);
begin
  Self.Value := Value;
  Self.Next := Next;
  Self.Prev := Prev;
end;

{ TDequeIterator }

procedure TDequeIterator.Add(Value: Pointer);
var
  Node: TDequeNode;
begin
  if Cursor <> nil then
  begin
    Node := TDequeNode.Create(InitializeObject(Value, Deque.FComparator), nil, nil);
    if not Reversed then
    begin
      Node.Next := Cursor;
      Node.Prev := Cursor.Prev;
      if Cursor.Prev <> nil then
        Cursor.Prev.Next := Node
      else
        Deque.FFirst := Node;
      Cursor.Prev := Node;
    end
    else
    begin
      Node.Next := Cursor.Next;
      Node.Prev := Cursor;
      if Cursor.Next <> nil then
        Cursor.Next.Prev := Node
      else
        Deque.FLast := Node;
      Cursor.Next := Node;
    end;
    Cursor := Node;
  end else
  begin
    if not Reversed then
    begin
      Deque.AddLast(Value);
      Cursor := Deque.FLast;
    end
    else
    begin
      Deque.AddFirst(Value);
      Cursor := Deque.FFirst;
    end;
  end;
end;

constructor TDequeIterator.Create(Deque: TDeque; Cursor: TDequeNode; Reversed: Boolean; Index: Integer);
begin
  Self.Deque := Deque;
  Self.Cursor := Cursor;
  Self.Reversed := Reversed;
  Self.Index := Index;
end;

function TDequeIterator.Get: Pointer;
begin
  if Cursor = nil then
    CollectionError('Attempting to get element from an already empty deque iteration. ');
  Result := Cursor.Value;
end;

function TDequeIterator.GetIndex: Integer;
begin
  Result := Index;
end;

function TDequeIterator.HasElement: Boolean;
begin
  Result := Cursor <> nil;
end;

procedure TDequeIterator.Next;
begin
  if Cursor = nil then
    CollectionError('Deque iteration is out of range');
  if Reversed then
  begin
    Cursor := Cursor.Prev;
    Inc(Index)
  end
  else
  begin
    Cursor := Cursor.Next;
    Dec(Index);
  end;
end;

procedure TDequeIterator.Prior;
begin
  if Cursor = nil then
    CollectionError('Deque iteration is out of range');
  if Reversed then
  begin
    Cursor := Cursor.Next;
    Dec(Index)
  end
  else
  begin
    Cursor := Cursor.Prev;
    Inc(Index);
  end;
end;

procedure TDequeIterator.Put(Value: Pointer);
begin
  UnsupportedError;
end;

procedure TDequeIterator.Remove;
var
  Temp: TDequeNode;
begin
  if Cursor = nil then
    CollectionError('Cannot remove anything in an empty deque');
  if Cursor = Deque.FFirst then
    Deque.FFirst := Cursor.Next;
  if Cursor = Deque.FLast then
    Deque.FLast := Cursor.Prev;
  Temp := Cursor;
  if not Reversed then
  begin
    Cursor := Cursor.Next;
    if Cursor <> nil then
      Cursor.Prev := nil;
  end
  else
  begin
    Cursor := Cursor.Prev;
    if Cursor <> nil then
      Cursor.Next := nil;
  end;
  FinalizeObject(Temp.Value, Deque.FComparator);
  Temp.Free;
end;

{ TAbstractCollection }

procedure TAbstractCollection.AddAll(C: ICollection);
var
  I: IIterator;
begin
  I := C.Iterator;
  while I.HasElement do
  begin
    Add(I.Get);
    I.Next;
  end;
end;

// Performs a rough equality comparasion between two abstract collection
function TAbstractCollection.CollectionEquals(Value: ICollection): Boolean;
var
  I, J: IIterator;
  C: ICollection;
begin
  Result := False;
  if Value.Supports(ICollection) then
  begin
    C := Value as ICollection;
    if GetSize <> C.Size then
      Exit;
    I := Iterator;
    J := C.Iterator;
    while (I <> nil) and (J <> nil) do
    begin
      if CompareObject(I.Get, J.Get, FComparator) <> 0 then
        Exit;
      I.Next;
      J.Next;
    end;
    if (I <> nil) or (J <> nil) then
      Exit;
    Result := True;
  end;
end;

procedure TAbstractCollection.RemoveAll(C: ICollection);
var
  I: IIterator;
begin
  I := C.Iterator;
  while I.HasElement do
  begin
    Remove(I.Get);
    I.Next;
  end;
end;

procedure TAbstractCollection.RetainAll(C: ICollection);
begin
  UnsupportedError;
end;

function TAbstractCollection.ContainsAll(C: ICollection): Boolean;
var
  I: IIterator;
begin
  I := C.Iterator;
  Result := False;
  while I.HasElement do
  begin
    if not Contains(I.Get) then
      Exit;
    I.Next;
  end;
  Result := True;
end;

function TAbstractCollection.GetComparator: IComparator;
begin
  Result := FComparator;
end;

procedure TAbstractCollection.SetComparator(Value: IComparator);
begin
  FComparator := Value;
end;

function TAbstractCollection.IsEmpty: Boolean;
begin
  Result := GetSize = 0;
end;

{ TBasicObject }

constructor TBasicObject.CreateEmpty;
begin

end;

function TBasicObject.GetObject: TBasicObject;
begin
  Result := Self;
end;

function TBasicObject.Supports(const IID: TGUID): Boolean;
var
  Buf: Integer;
begin
  QueryInterface(IID, Buf);
  Result := Buf <> 0;
  _Release;
end;

{ TTreeMap }

procedure TTreeMap.Put(Key, Value: Pointer);
var
  x: TTreeNode;
begin
  x := FindNode(Key);
  if x = nil then
  begin
    x := TTreeNode.Create;
    x.Key := InitializeObject(Key, FKeyComparator);
    x.Value := InitializeObject(Value, FValueComparator);
    RB_Insert(x);
  end
  else
  begin
    FinalizeObject(x.Value, FValueComparator);
    x.Value := InitializeObject(Value, FValueComparator);
  end;
end;

function TTreeMap.GetSize: Integer;
begin
  Result := FSize;
end;

procedure TTreeMap.LeftRotate(x: TTreeNode);
var
  y: TTreeNode;
begin
  y := x.Right;
  x.Right := y.Left;
  if y.Left <> nil then
    y.Left.Parent := x;
  y.Parent := x.Parent;
  if x.Parent = nil then
    FRoot := y
  else
  begin
    if x = x.Parent.Left then
      x.Parent.Left := y
    else
      x.Parent.Right := y;
  end;
  y.Left := x;
  x.Parent := y;
end;

procedure TTreeMap.RB_Delete(p: TTreeNode);
var
  replacement, s: TTreeNode;
begin
  Dec(FSize);

    // If strictly internal, first swap position with successor.
    if (p.left <> nil) and (p.right <> nil) then begin
        s := TreeSuccessor(p);
        SwapPosition(s, p);
    end;

    // Start fixup at replacement node, if it exists.
    if p.left <> nil then
      replacement := p.left
    else
      replacement := p.right;

    if (replacement <> nil) then begin
        // Link replacement to parent
        replacement.parent := p.parent;
        if (p.parent = nil) then
            froot := replacement
        else if (p = p.parent.left) then
            p.parent.left  := replacement
        else
            p.parent.right := replacement;

        // nil out links so they are OK to use by fixAfterDeletion.
        p.left := nil;
        p.right := nil;
        p.parent := nil;

        // Fix replacement
        if (p.color = ncBlack) then
            RB_DeleteFixup(replacement);
    end else if (p.parent = nil) then begin // return if we are the only node.
        froot := nil;
    end else begin //  No children. Use self as phantom replacement and unlink.
        if (p.color = ncBlack) then
            RB_DeleteFixup(p);

        if (p.parent <> nil) then begin
            if (p = p.parent.left) then
                p.parent.left := nil
            else if (p = p.parent.right) then
                p.parent.right := nil;
            p.parent := nil;
        end
    end;
    FinalizeObject(p.Key, FKeyComparator);
    FinalizeObject(p.Value, FValueComparator);
    p.Free;
end;

procedure TTreeMap.SwapPosition(x, y: TTreeNode);
var
  px, py, lx, ly, rx, ry: TTreeNode;
  xWasLeftChild, yWasLeftChild: Boolean;
  c: TNodeColor;
begin
    // Save initial values.
    px := x.parent;
    lx := x.left;
    rx := x.right;
    py := y.parent;
    ly := y.left;
    ry := y.right;
    xWasLeftChild := (px <> nil) and (x = px.left);
    yWasLeftChild := (py <> nil) and (y = py.left);

    // Swap, handling special cases of one being the other's parent.
    if (x = py) then
    begin  // x was y's parent
        x.parent := y;
        if (yWasLeftChild) then begin
            y.left := x;
            y.right := rx;
        end else begin
            y.right := x;
            y.left := lx;
        end
    end else
    begin
        x.parent := py;
        if (py <> nil) then begin
            if (yWasLeftChild) then
                py.left := x
            else
                py.right := x;
        end;
        y.left := lx;
        y.right := rx;
    end;

    if (y = px) then begin // y was x's parent
        y.parent := x;
        if (xWasLeftChild) then begin
            x.left := y;
            x.right := ry;
        end else begin
            x.right := y;
            x.left := ly;
        end
    end else begin
        y.parent := px;
        if (px <> nil) then begin
            if (xWasLeftChild) then
                px.left := y
            else
                px.right := y;
        end;
        x.left := ly;
        x.right := ry;
    end;

    // Fix children's parent pointers
    if (x.left <> nil) then
        x.left.parent := x;
    if (x.right <> nil) then
        x.right.parent := x;
    if (y.left <> nil) then
        y.left.parent := y;
    if (y.right <> nil) then
        y.right.parent := y;

    // Swap colors
    c := x.color;
    x.color := y.color;
    y.color := c;

    // Check if root changed
    if (froot = x) then
        froot := y
    else if (froot = y) then
        froot := x;
end;

procedure TTreeMap.RB_DeleteFixup(x: TTreeNode);
var
  w: TTreeNode;
begin
  while (x <> FRoot) and (x.Color = ncBlack) do
  begin
    if x = x.Parent.Left then
    begin
      w := x.Parent.Right;
      if w.Color = ncRed then
      begin
        w.Color := ncBlack;
        x.Parent.Color := ncRed;
        LeftRotate(x.Parent);
        w := x.Parent.Right;
      end;
      if (w.Left.Color = ncBlack) and (w.Right.Color = ncBlack) then
      begin
        w.Color := ncRed;
        x := x.Parent;
      end else
      begin
        if w.Right.Color = ncBlack then
        begin
          w.Left.Color := ncBlack;
          w.Color := ncRed;
          RightRotate(w);
          w := x.Parent.Right;
        end;
        w.Color := x.Parent.Color;
        x.Parent.Color := ncBlack;
        w.Right.Color := ncBlack;
        LeftRotate(x.Parent);
        x := FRoot;
      end;
    end
    else
    begin
      w := x.Parent.Left;
      if w.Color = ncRed then
      begin
        w.Color := ncBlack;
        x.Parent.Color := ncRed;
        RightRotate(x.Parent);
        w := x.Parent.Left;
      end;
      if (w.Right.Color = ncBlack) and (w.Left.Color = ncBlack) then
      begin
        w.Color := ncRed;
        x := x.Parent;
      end else
      begin
        if w.Left.Color = ncBlack then
        begin
          w.Right.Color := ncBlack;
          w.Color := ncRed;
          LeftRotate(w);
          w := x.Parent.Left;
        end;
        w.Color := x.Parent.Color;
        x.Parent.Color := ncBlack;
        w.Left.Color := ncBlack;
        RightRotate(x.Parent);
        x := FRoot;
      end;
    end;
  end;
  x.Color := ncBlack;
end;

procedure TTreeMap.RB_Insert(x: TTreeNode);
var
  y: TTreeNode;
begin
  TreeInsert(x);
  x.Color := ncRed;
  while (x <> FRoot) and (x.Parent.Color = ncRed) do
  begin
    if x.Parent = x.Parent.Parent.Left then
    begin
      y := x.Parent.Parent.Right;
      if y.Color = ncRed then
      begin
        x.Parent.Color := ncBlack;
        y.Color := ncBlack;
        x.Parent.Parent.Color := ncRed;
        x := x.Parent.Parent;
      end else
      begin
        if x = x.Parent.Right then
        begin
          x := x.Parent;
          LeftRotate(x);
        end;
        x.Parent.Color := ncBlack;
        x.Parent.Parent.Color := ncRed;
        RightRotate(x.Parent.Parent);
      end;
    end else
    begin
      y := x.Parent.Parent.Left;
      if y.Color = ncRed then
      begin
        x.Parent.Color := ncBlack;
        y.Color := ncBlack;
        x.Parent.Parent.Color := ncRed;
        x := x.Parent.Parent;
      end else
      begin
        if x = x.Parent.Left then
        begin
          x := x.Parent;
          RightRotate(x);
        end;
        x.Parent.Color := ncBlack;
        x.Parent.Parent.Color := ncRed;
        LeftRotate(x.Parent.Parent);
      end;
    end;
  end;
  FRoot.Color := ncBlack;
  Inc(FSize);
end;

function TTreeMap.RemoveKey(Key: Pointer): Boolean;
var
  x: TTreeNode;
begin
  x := FindNode(Key);
  Result := False;
  if x <> nil then
  begin
    RB_Delete(x);
    Result := True;
  end;
end;

function TTreeMap.RemoveValue(Value: Pointer): Boolean;
var
  I: TTreeMapIterator;
begin
  Result := False;
  I := (Iterator as IBasicObject).GetObject as TTreeMapIterator;
  while I.HasElement do
  begin
    if CompareBasicObject(I.Value, Value, nil) = 0 then
    begin
      RB_Delete(I.Cursor);
      Result := True;
      Exit;
    end;
    I.Next;
  end;
end;

procedure TTreeMap.RightRotate(x: TTreeNode);
var
  y: TTreeNode;
begin
  y := x.Left;
  x.Left := y.Right;
  if y.Right <> nil then
    y.Right.Parent := x;
  y.Parent := x.Parent;
  if x.Parent = nil then
    FRoot := y
  else
  begin
    if x = x.Parent.Right then
      x.Parent.Right := y
    else
      x.Parent.Left := y;
  end;
  y.Right := x;
  x.Parent := y;
end;

procedure TTreeMap.TreeInsert(z: TTreeNode);
var
  x, y: TTreeNode;
begin
  y := nil;
  x := FRoot;
  while x <> nil do
  begin
    y := x;
    if CompareObject(z.Key, x.Key, FKeyComparator) < 0 then
      x := x.Left
    else
      x := x.Right;
  end;
  z.Parent := y;
  if y = nil then
    FRoot := z
  else if CompareObject(z.Key, y.Key, FKeyComparator) < 0 then
    y.Left := z
  else
    y.Right := z;
end;

function TTreeMap.TreeSuccessor(x: TTreeNode): TTreeNode;
var
  y: TTreeNode;
begin
  if x.Right <> nil then
  begin
    Result := TreeMinimum(x.Right);
    Exit;
  end;
  y := x.Parent;
  while (y <> nil) and (x = y.Right) do
  begin
    x := y;
    y := y.Parent;
  end;
  Result := y;
end;

function TTreeMap.TreeMinimum(x: TTreeNode): TTreeNode;
begin
  while x.Left <> nil do
    x := x.Left;
  Result := x;
end;

function TTreeMap.FindNode(Key: Pointer): TTreeNode;
var
  x: TTreeNode;
begin
  x := FRoot;
  while (x <> nil) do
  begin
    if CompareObject(Key, x.Key, FKeyComparator) = 0 then
    begin
      Result := x;
      Exit;
    end;
    if CompareObject(Key, x.Key, FKeyComparator) < 0 then
      x := x.Left
    else
      x := x.Right;
  end;
  Result := nil;
end;

function TTreeMap.TreeMaximum(x: TTreeNode): TTreeNode;
begin
  while x.Right <> nil do
    x := x.Right;
  Result := x;
end;

function TTreeMap.TreePredecessor(x: TTreeNode): TTreeNode;
var
  y: TTreeNode;
begin
  if x.Left <> nil then
  begin
    Result := TreeMaximum(x.Left);
    Exit;
  end;
  y := x.Parent;
  while (y <> nil) and (x = y.Left) do
  begin
    x := y;
    y := y.Parent;
  end;
  Result := y;
end;

function TTreeMap.FindKey(Key: Pointer): IMapIterator;
begin
  Result := TTreeMapIterator.Create(FindNode(Key), Self, False);
end;

function TTreeMap.Iterator: IIterator;
begin
  Result := TTreeMapIterator.Create(TreeMinimum(FRoot), Self, False);
end;

function TTreeMap.Get(Key: Pointer): Pointer;
var
  x: TTreeNode;
begin
  x := FindNode(Key);
  if x = nil then
    Result := nil
  else
    Result := x.Value;
end;

procedure TTreeMap.Clear;
begin
  if FRoot <> nil then
  begin
    FRoot.Clear(Self);
    FRoot.Free;
    FRoot := nil;
  end;
end;

destructor TTreeMap.Destroy;
begin
  Clear;
  inherited Destroy;
end;

type
  TMapKeys = class(TAbstractCollection)
  public
    function Contains(Value: Pointer): Boolean; override;
    procedure Add(Value: Pointer); override;
    function Remove(Value: Pointer): Boolean; override;
    function Iterator: IIterator; override;
    function GetSize: Integer; override;
    procedure Clear; override;
  private
    TreeMap: TTreeMap;
    constructor Create(TreeMap: TTreeMap);
  end;

  TMapValues = class(TAbstractCollection)
  public
    function Contains(Value: Pointer): Boolean; override;
    procedure Add(Value: Pointer); override;
    function Remove(Value: Pointer): Boolean; override;
    function Iterator: IIterator; override;
    function GetSize: Integer; override;
    procedure Clear; override;
  private
    TreeMap: TTreeMap;
    constructor Create(TreeMap: TTreeMap);
  end;

function TTreeMap.Keys: ICollection;
begin
  if FKeys = nil then
    FKeys := TMapKeys.Create(Self);
  Result := FKeys;
end;

function TTreeMap.Values: ICollection;
begin
  if FValues = nil then
    FValues := TMapValues.Create(Self);
  Result := FValues;
end;

function TTreeMap.ReversedIterator: IIterator;
begin
  Result := TTreeMapIterator.Create(TreeMinimum(FRoot), Self, True);
end;

function TTreeMap.MapIterator: IMapIterator;
begin
  Result := Iterator as IMapIterator;
end;

{ TTreeMapIterator }

procedure TTreeMapIterator.Add(Value: Pointer);
begin
  UnsupportedError;
end;

constructor TTreeMapIterator.Create(Cursor: TTreeNode; Map: TTreeMap; Reversed: Boolean);
begin
  Self.Cursor := Cursor;
  Self.Map := Map;
  Self.Reversed := Reversed;
end;

function TTreeMapIterator.Get: Pointer;
begin
  Result := GetValue;
end;

function TTreeMapIterator.GetIndex: Integer;
begin
  Result := -1;
  UnsupportedError;
end;

function TTreeMapIterator.GetKey: Pointer;
begin
  Result := Cursor.Key;
end;

function TTreeMapIterator.GetValue: Pointer;
begin
  Result := Cursor.Value;
end;

function TTreeMapIterator.HasElement: Boolean;
begin
  Result := Cursor <> nil;
end;

procedure TTreeMapIterator.Next;
begin
  if Cursor = nil then
    CollectionError('No element(s) left');
  if not Reversed then
    Cursor := Map.TreeSuccessor(Cursor)
  else
    Cursor := Map.TreePredecessor(Cursor);
end;

procedure TTreeMapIterator.Prior;
begin
  if Cursor = nil then
    CollectionError('No element(s) left');
  if not Reversed then
    Cursor := Map.TreePredecessor(Cursor)
  else
    Cursor := Map.TreeSuccessor(Cursor);
end;

procedure TTreeMapIterator.Put(Value: Pointer);
begin
  UnsupportedError;
end;

procedure TTreeMapIterator.Remove;
var
  Temp: TTreeNode;
begin
  if Cursor = nil then
    CollectionError('Cannot remove nothing');
  Temp := Cursor;
  if not Reversed then
    Cursor := Map.TreeSuccessor(Cursor)
  else
    Cursor := Map.TreePredecessor(Cursor);
  Map.RB_Delete(Temp);
end;

procedure TTreeMapIterator.SetKey(Key: Pointer);
begin
  UnsupportedError;
end;

procedure TTreeMapIterator.SetValue(Value: Pointer);
begin
  UnsupportedError;
end;

{ TTreeNode }

procedure TTreeNode.Clear(TreeMap: TTreeMap);
begin
  if Left <> nil then
  begin
    Left.Clear(TreeMap);
    Left.Free;
    Left := nil;
  end;
  if Right <> nil then
  begin
    Right.Clear(TreeMap);
    Right.Free;
    Right := nil;
  end;
  FinalizeObject(Key, TreeMap.FKeyComparator);
  FinalizeObject(Value, TreeMap.FValueComparator);
  Parent := nil;
end;

constructor TTreeNode.Create;
begin
end;

function TTreeNode.GetColor: TNodeColor;
begin
  if Self = nil then
    Result := ncBlack
  else
    Result := FColor;
end;

function TTreeNode.GetLeft: TTreeNode;
begin
  if Self = nil then
    Result := nil
  else
    Result := FLeft;
end;

function TTreeNode.GetParent: TTreeNode;
begin
  if Self = nil then
    Result := nil
  else
  Result := FParent;
end;

function TTreeNode.GetRight: TTreeNode;
begin
  if Self = nil then
    Result := nil
  else
  Result := FRight;
end;

procedure TTreeNode.SetColor(const Value: TNodeColor);
begin
  if Self <> nil then
    FColor := Value;
end;

procedure TTreeNode.SetLeft(const Value: TTreeNode);
begin
  if Self <> nil then
    FLeft := Value;
end;

procedure TTreeNode.SetParent(const Value: TTreeNode);
begin
  if Self <> nil then
    FParent := Value;
end;

procedure TTreeNode.SetRight(const Value: TTreeNode);
begin
  if Self <> nil then
    FRight := Value;
end;

{ TAbstractMap }

function TAbstractMap.ContainsKey(Key: Pointer): Boolean;
begin
  Result := FindKey(Key).HasElement;
end;

function TAbstractMap.ContainsValue(Value: Pointer): Boolean;
var
  I: IIterator;
begin
  I := Iterator;
  while I.HasElement do
  begin
    if CompareObject(I.Get, Value, FValueComparator) = 0 then
    begin
      Result := True;
      Exit;
    end;
    I.Next;
  end;
  Result := False;
end;

function TAbstractMap.MapEquals(M: IMap): Boolean;
begin
  Result := False;
  UnsupportedError;
end;

procedure TAbstractMap.PutAll(M: IMap);
var
  I: IMapIterator;
begin
  I := M.Iterator as IMapIterator;
  while I.HasElement do
  begin
    Put(I.GetKey, I.GetValue);
    I.Next;
  end;
end;

function TAbstractMap.GetKeyComparator: IComparator;
begin
  Result := FKeyComparator;
end;

function TAbstractMap.GetValueComparator: IComparator;
begin
  Result := FValueComparator;
end;

procedure TAbstractMap.SetKeyComparator(const Value: IComparator);
begin
  FKeyComparator := Value;
end;

procedure TAbstractMap.SetValueComparator(const Value: IComparator);
begin
  FValueComparator := Value;
end;

constructor TAbstractMap.Create;
begin
  FValueOwnership := True;
  FKeyOwnership := True;
end;

function TAbstractMap.IsEmpty: Boolean;
begin
  Result := GetSize = 0;
end;

function TAbstractMap.ReversedIterator: IIterator;
begin
  UnsupportedError;
end;

{ TMapKeys }

procedure TMapKeys.Add(Value: Pointer);
begin
  TreeMap.Put(Value, nil);
end;

procedure TMapKeys.Clear;
begin
  TreeMap.Clear;
end;

function TMapKeys.Contains(Value: Pointer): Boolean;
begin
  Result := TreeMap.ContainsKey(Value);
end;

constructor TMapKeys.Create(TreeMap: TTreeMap);
begin
  Self.TreeMap := TreeMap;
end;

function TMapKeys.GetSize: Integer;
begin
  Result := TreeMap.GetSize;
end;

function TMapKeys.Iterator: IIterator;
begin
  Result := TMapKeyIterator.Create(TreeMap.TreeMinimum(TreeMap.FRoot), TreeMap, False);
end;

function TMapKeys.Remove(Value: Pointer): Boolean;
begin
  Result := TreeMap.RemoveKey(Value);
end;

{ TMapKeyIterator }

function TMapKeyIterator.Get: Pointer;
begin
  Result := GetKey;
end;

{ TMapValues }

procedure TMapValues.Add(Value: Pointer);
begin
  UnsupportedError;
end;

procedure TMapValues.Clear;
begin
  TreeMap.Clear;
end;

function TMapValues.Contains(Value: Pointer): Boolean;
begin
  Result := TreeMap.ContainsValue(Value);
end;

constructor TMapValues.Create(TreeMap: TTreeMap);
begin
  Self.TreeMap := TreeMap;
end;

function TMapValues.GetSize: Integer;
begin
  Result := TreeMap.GetSize;
end;

function TMapValues.Iterator: IIterator;
begin
  Result := TreeMap.Iterator;
end;

function TMapValues.Remove(Value: Pointer): Boolean;
begin
  Result := TreeMap.RemoveValue(Value);
end;

{ TStringComparator }

function TStringComparator.Compare(a, b: Pointer): Integer;
begin
  Result := AnsiCompareStr(PString(a)^, PString(b)^);
end;

procedure TStringComparator.Finalize(a: Pointer);
begin
//  WriteLn(PString(a)^, ' is being destroyed');
  DisposeStr(a);
end;

function TStringComparator.Initialize(a: Pointer): Pointer;
begin
  Result := NewStr(PString(a)^);
end;

{ TTreeSet }

procedure TTreeSet.Add(Value: Pointer);
begin
  FMap.Put(Value, nil);
end;

procedure TTreeSet.Clear;
begin
  FMap.Clear;
end;

function TTreeSet.Contains(Value: Pointer): Boolean;
begin
  Result := FMap.ContainsKey(Value);
end;

constructor TTreeSet.Create;
begin
  FMap := TTreeMap.Create;
end;

function TTreeSet.GetComparator: IComparator;
begin
  Result := FMap.GetKeyComparator;
end;

function TTreeSet.GetSize: Integer;
begin
  Result := FMap.GetSize;
end;

function TTreeSet.Iterator: IIterator;
begin
  Result := FMap.Keys.Iterator;
end;

function TTreeSet.Remove(Value: Pointer): Boolean;
begin
  Result := FMap.RemoveKey(Value);
end;

procedure TTreeSet.SetComparator(Value: IComparator);
begin
  FMap.SetKeyComparator(Value);
end;

{ TEventMultiplexer }

procedure TEventMultiplexer.Add(Method: TNotifyEvent);
begin
  FListeners.Add(@Method);
end;

constructor TEventMultiplexer.Create;
begin
  FListeners := TDeque.Create;
  FListeners.Comparator := TBlobComparator.Create(SizeOf(TMethod));
end;

procedure TEventMultiplexer.Remove(Method: TNotifyEvent);
begin
  FListeners.Remove(@Method);
end;

procedure TEventMultiplexer.RemoveSource(Source: TObject);
var
  I: IIterator;
begin
  I := FListeners.Iterator;
  while I.HasElement do
  begin
    if TMethod(I.Get^).Data = Pointer(Source) then
      I.Remove
    else
      I.Next;
  end;
end;

procedure TEventMultiplexer.FireNotifyEvent(Sender: TObject);
var
  I: IIterator;
begin
  I := FListeners.Iterator;
  while I.HasElement do
  begin
    TNotifyEvent(I.Get^)(Self);
    I.Next;
  end;
end;

{ TPointerComparator }

function TEventMultiplexer.Iterator: IIterator;
begin
  Result := FListeners.Iterator;
end;

{ TBlobComparator }

function TBlobComparator.Compare(a, b: Pointer): Integer;
var
  pa, pb: PChar;
  i: Integer;
begin
  Result := 0;
  pa := a;
  pb := b;
  for i:=0 to Length-1 do
    Inc(Result, Ord(pa[i]) - Ord(pb[i]));
end;

constructor TBlobComparator.Create(Length: Integer);
begin
  Self.Length := Length;
end;

procedure TBlobComparator.Finalize(a: Pointer);
begin
  Dispose(a);
end;

type
  TStringMapKeys = class(TBasicObject, IStringList)
  private
    StringMap: TStringMap;
  public
    constructor Create(StringMap: TStringMap);
    procedure Add(Value: string);
    function Remove(Value: string): Boolean;
    procedure AddAll(C: IStringList);
    procedure RetainAll(C: IStringList);
    procedure RemoveAll(C: IStringList);
    procedure Clear;
    function StringIterator: IStringIterator;
    function Iterator: IIterator;
    function IsEmpty: Boolean;
    function Contains(Value: string): Boolean;
    function ContainsAll(C: IStringList): Boolean;
    function CollectionEquals(Value: IStringList): Boolean;
    function GetSize: Integer;
    property Size: Integer read GetSize;
  end;

  TStringMapKeysIterator = class(TBasicObject, IStringIterator)
  private
    FIter: IMapIterator;
  public
    constructor Create(StringMap: TStringMap);
    function HasElement: Boolean;
    function Get: string;
    procedure Next;
  end;

function TBlobComparator.Initialize(a: Pointer): Pointer;
begin
  GetMem(Result, Length);
  Move(a^, Result^, Length);
end;

{ TStringMap }

procedure TStringMap.Clear;
begin
  FMap.Clear;
end;

function TStringMap.ContainsKey(Key: string): Boolean;
begin
  Result := FMap.ContainsKey(@Key);
end;

function TStringMap.ContainsValue(Key: Pointer): Boolean;
begin
  Result := FMap.ContainsValue(Key);
end;

constructor TStringMap.Create;
begin
  FMap := TTreeMap.Create;
  FMap.KeyComparator := TStringComparator.Create;
end;

function TStringMap.FindKey(Key: string): IIterator;
begin
  Result := FMap.FindKey(@Key) as IIterator;
end;

function TStringMap.Get(Key: string): Pointer;
begin
  Result := FMap.Get(@Key);
end;

function TStringMap.GetComparator: IComparator;
begin
  Result := FMap.GetValueComparator;
end;

function TStringMap.GetSize: Integer;
begin
  Result := FMap.Size;
end;

function TStringMap.IsEmpty: Boolean;
begin
  Result := FMap.IsEmpty;
end;

function TStringMap.Iterator: IIterator;
begin
  Result := FMap.Iterator;
end;

function TStringMap.Keys: IStringList;
begin
  if FKeys = nil then
    FKeys := TStringMapKeys.Create(Self);
  Result := FKeys;
end;

procedure TStringMap.Put(Key: string; Value: Pointer);
begin
  FMap.Put(NewStr(Key), Value);
end;

function TStringMap.RemoveKey(Key: string): Boolean;
begin
  Result := FMap.RemoveKey(@Key);
end;

function TStringMap.RemoveValue(Value: Pointer): Boolean;
begin
  Result := FMap.RemoveValue(Value);
end;

procedure TStringMap.SetComparator(const Value: IComparator);
begin
  FMap.SetValueComparator(Value);
end;

function TStringMap.Values: ICollection;
begin
  Result := FMap.Values;
end;

{ TStringMapKeys }

procedure TStringMapKeys.Add(Value: string);
begin
  StringMap.Put(Value, nil);
end;

procedure TStringMapKeys.AddAll(C: IStringList);
var
  I: IStringIterator;
begin
  I := C.StringIterator;
  while I.HasElement do
  begin
    Add(I.Get);
    I.Next;
  end;
end;

procedure TStringMapKeys.Clear;
begin
  StringMap.Clear;
end;

function TStringMapKeys.CollectionEquals(Value: IStringList): Boolean;
begin
  UnsupportedError;
  Result := False;
end;

function TStringMapKeys.Contains(Value: string): Boolean;
begin
  Result := StringMap.ContainsKey(Value);
end;

function TStringMapKeys.ContainsAll(C: IStringList): Boolean;
var
  I: IStringIterator;
begin
  I := C.StringIterator;
  Result := False;
  while I.HasElement do
  begin
    if not Contains(I.Get) then
      Exit;
    I.Next;
  end;
  Result := True;
end;

constructor TStringMapKeys.Create(StringMap: TStringMap);
begin
  Self.StringMap := StringMap;
end;

function TStringMapKeys.GetSize: Integer;
begin
  Result := StringMap.GetSize;
end;

function TStringMapKeys.IsEmpty: Boolean;
begin
  Result := StringMap.IsEmpty;
end;

function TStringMapKeys.Iterator: IIterator;
begin
  Result := StringMap.Iterator;
end;

function TStringMapKeys.Remove(Value: string): Boolean;
begin
  Result := StringMap.RemoveKey(Value);
end;

procedure TStringMapKeys.RemoveAll(C: IStringList);
var
  I: IStringIterator;
begin
  I := C.StringIterator;
  while I.HasElement do
  begin
    Remove(I.Get);
    I.Next;
  end;
end;

procedure TStringMapKeys.RetainAll(C: IStringList);
begin
end;

function TStringMapKeys.StringIterator: IStringIterator;
begin
  Result := TStringMapKeysIterator.Create(StringMap);
end;

{ TStringMapKeysIterator }

constructor TStringMapKeysIterator.Create(StringMap: TStringMap);
begin
  FIter := StringMap.Iterator as IMapIterator;
end;

function TStringMapKeysIterator.Get: string;
begin
  Result := PString(FIter.GetKey)^;
end;

function TStringMapKeysIterator.HasElement: Boolean;
begin
  Result := FIter.HasElement;
end;

procedure TStringMapKeysIterator.Next;
begin
  FIter.Next;
end;

{ TObjectComparator }

function TObjectComparator.Compare(a, b: Pointer): Integer;
begin
  Result := Integer(a) - Integer(b);
end;

procedure TObjectComparator.Finalize(a: Pointer);
begin
  TObject(a).Free;
end;

function TObjectComparator.Initialize(a: Pointer): Pointer;
begin
  Result := a;
end;

{ TCollections }

class function TCollections.CreateList: IList;
begin
  Result := TDeque.Create;
end;

class function TCollections.CreateMap: IMap;
begin
  Result := TTreeMap.Create;
end;

class function TCollections.CreateStringMap: IStringMap;
begin
  Result := TStringMap.Create;
end;

procedure Test1;
var
  Map: IStringMap;
  I: IStringIterator;
begin
  Map := TCollections.CreateStringMap;
  Map.Comparator := TStringComparator.Create;
  Map.Put('1pragman', NewStr('value'));
  Map.Put('2pragman', NewStr('value'));
  Map.Put('3pragman', NewStr('value'));
  Map.Put('4pragman', NewStr('value'));
  Map.Put('5pragman', NewStr('value'));
  Map.Put('6pragman', NewStr('value'));
  Map.RemoveKey('1pragman');
  Map.RemoveKey('3pragman');
  Map.RemoveKey('4pragman');
  I := Map.Keys.StringIterator;
  while I.HasElement do
  begin
    WriteLn(I.Get);
    I.Next;
  end;
end;

initialization

  Test1;

end.

--
Chaos is the best description of the constant state of human society.
Therefore, dynamic balance is required for us to to survive when vital fault
occurrs. So in the society, we don't chase for peace and order, but existence
and survival, instead.

--
※ 發信站: 批踢踢實業坊(ptt.twbbs.org) 
◆ From: 140.112.3.12