DDevExtensions 2.86

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.86になっています。RAD Studio 10.4 Sydney対応ではなく、TListViewのOwnerDataの問題を修正して、"Find Unit" replacement dialogのパフォーマンスが向上したとのことです。

DDevExtensions 2.86 for Delphi 2009-10.3.3 – Andy's Blog and Tools

DDevExtensions 2.85

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.85になっています。RAD Studio 10.3 Rio対応と、いくつかの改善が行われています。

DDevExtensions and DFMCheck released for Delphi 10.3 Rio – Andy's Blog and Tools

RAD Studio/Delphi/C++Builder 10 Seattle/10.1 Berlin/10.2 Tokyo Files Permissions Patch

RAD Studio/Delphi/C++Builder 10 Seattle/10.1 Berlin/10.2 TokyoのFiles Permissions Patchがリリースされています。Webインストーラでインストールされるファイルのパーミッションが不適切になっている問題を修正します。ISOインストールあるいはweb(GetIt)インストールでも最新の10.2.3 Tokyo Build 3231では不要です。

30850 RAD Studio 10 Files Permissions Patch

RAD Studio 10, 10.1, 10.2 向けファイルパーミッションパッチをリリースしました [JAPAN] (en)

ジェネリックスのリストをアルゴリズムを指定してソートする

Delphi 2009で導入されたジェネリックスのコンテナの一つであるTList<T>にはSortメソッドがあり、比較関数としてデフォルト以外のComparer(コンペアラ)も渡すことができるのですが、ソートアルゴリズムそのものはクイックソートしかありません。一般的には平均して性能が出るとされるクイックソートですが、安定ではないこと、苦手な状況が存在することなど、決して万能というわけではありません。ところがTList<T>.Sortは内部で保持しているTArray.Sortにソートを丸投げしており、ソートアルゴリズムを変更することができません。そこでアルゴリズムを指定してTList<T>(およびTObjectList<T: class>)をソートする方法を考えてみました。ただしDelphi 2009のTList<T>にはExchangeメソッドもMoveメソッドも存在していないため、Delphi 2010以降の対応になります。

まずソートを行うためのレコード型と、ソートアルゴリズムを実装するクラスの継承元クラスの宣言です。

{$IF RTLVersion <= 20.00}
{$MESSAGE ERROR 'Need Delphi 2010 or later'}
{$IFEND}

uses
{$IF RTLVersion >= 23.00}
  System.Rtti, System.Generics.Defaults, System.Generics.Collections;
{$ELSE}
  Rtti, Generics.Defaults, Generics.Collections;
{$IFEND}

type
  { Forward declarations }
  TSortAlgorithm<T> = class;

  { TGenericListSorter }
  TGenericListSorter = record
  private
    class function  GetComparer<T>(List: TList<T>; const AComparer: IComparer<T>): IComparer<T>; static;
  public
    class procedure Sort<T: record>(List: TList<T>; Algorithm: TSortAlgorithm<T>;
                                    const AComparer: IComparer<T>{$IF CompilerVersion >= 24.00} = nil{$IFEND}); overload; static;
{$IF CompilerVersion < 24.00}
    class procedure Sort<T: record>(List: TList<T>; Algorithm: TSortAlgorithm<T>); overload; static;
{$IFEND}
    class procedure Sort<T: class>(List: TObjectList<T>; Algorithm: TSortAlgorithm<T>;
                                   const AComparer: IComparer<T>{$IF CompilerVersion >= 24.00} = nil{$IFEND}); overload; static;
{$IF CompilerVersion < 24.00}
    class procedure Sort<T: class>(List: TObjectList<T>; Algorithm: TSortAlgorithm<T>); overload; static;
{$IFEND}
    class procedure Sort(List: TList<String>; Algorithm: TSortAlgorithm<String>;
                         const AComparer: IComparer<String>{$IF CompilerVersion >= 24.00} = nil{$IFEND}); overload; static;
{$IF CompilerVersion < 24.00}
    class procedure Sort(List: TList<String>; Algorithm: TSortAlgorithm<String>); overload; static;
{$IFEND}
  end;

  { TSortAlgorithm (abstract) }
  TSortAlgorithm<T> = class(TObject)
  public
    class function  Instance: TSortAlgorithm<T>; virtual; abstract;
    class procedure Sort(List: TList<T>; const AComparer: IComparer<T>); virtual; abstract;
  end;

TGenericListSorterはソートを行うためのレコード型で、overloadされたpublicな3つ(XE2およびそれ以前は6つ、後述)のSortメソッドと、比較を行うコンペアラを決定するためのprivateなGetComparerメソッドを持ちます。Sortメソッドの1つめは値型用(レコード制約)、2つめはクラス型用(クラス制約)、3つめはこのどちらにも含まれない文字列型用です。IComparer<T>にデフォルトパラメータを指定できるのはDelphi XE3以降のため、それ以前のバージョンではコンペアラを指定しないオーバロードをさらに3つ用意しました。またTSortAlgorithm<T>はソートアルゴリズムを実装するためのクラスの継承元になります。実際にソートを行うSortメソッドと、シングルトンなインスタンスを取得するためのInstanceメソッドを持ちます。TGenericListSorterの実装は次のようになります。

class procedure TGenericListSorter.Sort<T>(List: TList<T>; Algorithm: TSortAlgorithm<T>;
                                           const AComparer: IComparer<T>);
var
  Comparer: IComparer<T>;
begin

  if (List = nil) or (List.Count <= 1) then
  begin
    Exit;
  end;

  Comparer := GetComparer<T>(List,AComparer);

  Algorithm.Sort(List,Comparer);

end;

{$IF CompilerVersion < 24.00}
class procedure TGenericListSorter.Sort<T>(List: TList<T>; Algorithm: TSortAlgorithm<T>);
var
  Comparer: IComparer<T>;
begin

  if (List = nil) or (List.Count <= 1) then
  begin
    Exit;
  end;

  Comparer := GetComparer<T>(List,nil);

  Algorithm.Sort(List,Comparer);

end;
{$IFEND}

class procedure TGenericListSorter.Sort<T>(List: TObjectList<T>; Algorithm: TSortAlgorithm<T>;
                                           const AComparer: IComparer<T>);
var
  Comparer: IComparer<T>;
  OwnsObjects: Boolean;
begin

  if (List = nil) or (List.Count <= 1) then
  begin
    Exit;
  end;

  Comparer := GetComparer<T>(List,AComparer);

  OwnsObjects := List.OwnsObjects;
  try
    List.OwnsObjects := False;
    Algorithm.Sort(List,Comparer);

  finally
    List.OwnsObjects := OwnsObjects;
  end;

end;

{$IF CompilerVersion < 24.00}
class procedure TGenericListSorter.Sort<T>(List: TObjectList<T>; Algorithm: TSortAlgorithm<T>);
var
  Comparer: IComparer<T>;
  OwnsObjects: Boolean;
begin

  if (List = nil) or (List.Count <= 1) then
  begin
    Exit;
  end;

  Comparer := GetComparer<T>(List,nil);

  OwnsObjects := List.OwnsObjects;
  try
    List.OwnsObjects := False;
    Algorithm.Sort(List,Comparer);

  finally
    List.OwnsObjects := OwnsObjects;
  end;

end;
{$IFEND}

class procedure TGenericListSorter.Sort(List: TList<String>; Algorithm: TSortAlgorithm<String>;
                                        const AComparer: IComparer<String>);
var
  Comparer: IComparer<String>;
begin

  if (List = nil) or (List.Count <= 1) then
  begin
    Exit;
  end;

  Comparer := GetComparer<String>(List,AComparer);

  Algorithm.Sort(List,Comparer);

end;

{$IF CompilerVersion < 24.00}
class procedure TGenericListSorter.Sort(List: TList<String>; Algorithm: TSortAlgorithm<String>);
var
  Comparer: IComparer<String>;
begin

  if (List = nil) or (List.Count <= 1) then
  begin
    Exit;
  end;

  Comparer := GetComparer<String>(List,nil);

  Algorithm.Sort(List,Comparer);

end;
{$IFEND}

class function TGenericListSorter.GetComparer<T>(List: TList<T>; const AComparer: IComparer<T>): IComparer<T>;
var
  ctx: TRttiContext;
begin

  Result := AComparer;
  if Result = nil then
  begin
    Result := ctx.GetType(List.ClassType).GetField('FComparer').GetValue(List).AsType<IComparer<T>>;
  end;

end;

Sortメソッドはいずれもコンペアラを確定し、指定されたソートアルゴリズムのインスタンスのSortメソッドを呼び出しています。ただしTObjectList<T>用のオーバロードはソートを行っている間、一時的にOwnsObjectsをFalseに変更しています。これはOwnsObjectsがTrueだと(以下の例のマージソートのように)Items[]に代入を行ったときに、もともと格納されているTのインスタンスを解放してしまうためで、ソートアルゴリズムのクラスで直接ソートを行うのではなく、レコード型TGenericListSorterの3つのオーバロードに処理を分けて、そこから間接的に呼び出すようになっているのはこれが理由です。またGetComparerメソッドはコンペアラが指定されていない(=nil)ときに、TList<T>の持つデフォルトのコンペアラを(RTTIを使って)取得します。 次に実際のソートアルゴリズムを実装したクラスですが、まずコムソートを実装してみます。

type
  TCombSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TCombSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TCombSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TCombSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
const
  SHRINK_FACTOR = 1.247330950103979;
var
  Index: Integer;
  Gap: Integer;
  Swapped: Boolean;
begin

  Gap := List.Count;
  Swapped := True;

  while (Gap > 1) or (Swapped = True) do
  begin
    if Gap > 1 then
    begin
      Gap := Trunc(Gap / SHRINK_FACTOR);
    end;

    if Gap < 1 then
    begin
      Gap := 1;
    end;

    Swapped := False;
    Index := 0;

    while (Gap + Index) < List.Count do
    begin
      if AComparer.Compare(List.Items[Index],List.Items[Index + Gap]) > 0 then
      begin
        List.Exchange(Index,Index + Gap);
        Swapped := True;
      end;
      Index := Index + 1;
    end;
  end;

end;

前述の通り(TGenericListSorterとは異なり)1種類の<T>に対してのみSortを実装すればよいようになっています。またSortメソッド以外にシングルトンなインスタンスを取得するためのInstanceメソッドと、そのインスタンスを解放するためのクラスデストラクタを用意します。これで例えばInteger型のリストに対しては

var
  I: Integer;
  Value: Integer;
  List: TList<Integer>;
begin
  List := TList<Integer>.Create;
  try
    for I := 0 to 999 do
    begin
      List.Add(Random(100000));
    end;

    TGenericListSorter.Sort<Integer>(List,TCombSort<Integer>.Instance,TComparer<Integer>.Construct(
      function(const Left, Right: Integer): Integer
      begin
        Result := Left - Right;
      end));

    for Value in List do
    begin
      Memo1.Lines.Add(IntToStr(Value));
    end;

  finally
    List.Free;
  end
end;

このような形でソートを呼び出すことができます。 同じようにその他のソートアルゴリズムを実装していきます。ノームソートです。

type
  TGnomeSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TGnomeSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TGnomeSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TGnomeSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  Index: Integer;
begin

  Index := 0;
  while Index < List.Count do
  begin
    if (Index = 0) or (AComparer.Compare(List.Items[Index],List.Items[Index - 1]) >= 0) then
    begin
      Index := Index + 1;
    end
    else
    begin
      List.Exchange(Index,Index - 1);
      Index := Index - 1;
    end;
  end;

end;

選択ソートです。

type
  TSelectionSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TSelectionSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TSelectionSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TSelectionSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  Index1: Integer;
  Index2: Integer;
  MinIndex: Integer;
  Temp: T;
begin

  for Index1 := 0 to List.Count - 2 do
  begin
    MinIndex := Index1;
    Temp := List.Items[MinIndex];

    for Index2 := Index1 + 1 to List.Count - 1 do
    begin
      if AComparer.Compare(List.Items[Index2],Temp) < 0 then
      begin
        MinIndex := Index2;
        Temp := List.Items[MinIndex];
      end;
    end;

    if MinIndex <> Index1 then
    begin
      List.Move(MinIndex,Index1);
    end;
  end;

end;

挿入ソートです。

type
  TInsertionSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TInsertionSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TInsertionSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TInsertionSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  Comparer: IComparer<T>;
  Index1: Integer;
  Index2: Integer;
  Temp: T;
begin

  for Index1 := 1 to List.Count - 1 do
  begin
    Temp := List.Items[Index1];
    Index2 := Index1 - 1;

    while (Index2 >= 0) and (AComparer.Compare(List.Items[Index2],Temp) > 0) do
    begin
      Index2 := Index2 - 1;
    end;

    List.Move(Index1,Index2 + 1);
  end;

end;

クイックソートです。

type
  TQuickSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
    class procedure  InternalSort(List: TList<T>; Left: Integer; Right: Integer;
                                  const AComparer: IComparer<T>);
    class function   Partition(List: TList<T>; Left: Integer; Right: Integer;
                               const AComparer: IComparer<T>): Integer;
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TQuickSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TQuickSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TQuickSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  Comparer: IComparer<T>;
begin

  InternalSort(List,0,List.Count - 1,AComparer);

end;

class procedure TQuickSort<T>.InternalSort(List: TList<T>; Left: Integer; Right: Integer;
                                           const AComparer: IComparer<T>);
var
  Pivot: Integer;
begin

  if Left < Right then
  begin
    Pivot := Partition(List,Left,Right,AComparer);

    InternalSort(List,Left,     Pivot,AComparer);
    InternalSort(List,Pivot + 1,Right,AComparer);
  end;

end;

class function TQuickSort<T>.Partition(List: TList<T>; Left: Integer; Right: Integer;
                                       const AComparer: IComparer<T>): Integer;
var
  Index1: Integer;
  Index2: Integer;
  Pivot: T;
begin

  Pivot := List.Items[(Left + Right) div 2];
  Index1 := Left  - 1;
  Index2 := Right + 1;

  while True do
  begin
    repeat
      Index1 := Index1 + 1;
    until (AComparer.Compare(List.Items[Index1],Pivot) >= 0);

    repeat
      Index2 := Index2 - 1;
    until (AComparer.Compare(List.Items[Index2],Pivot) <= 0);

    if Index1 >= Index2 then
    begin
      Result := Index2;
      Exit;
    end;

    List.Exchange(Index1,Index2);
  end;

end;

ヒープソートです。

type
  THeapSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
    class procedure  BuildHeap(List: TList<T>; const AComparer: IComparer<T>);
    class procedure  Heapify(List: TList<T>; Index: Integer; Max: Integer;
                             const AComparer: IComparer<T>);
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor THeapSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function THeapSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure THeapSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  Index: Integer;
begin

  BuildHeap(List,AComparer);

  for Index := List.Count - 1 downto 1 do
  begin
    List.Exchange(0,Index);

    Heapify(List,0,Index,AComparer);
  end;

end;

class procedure THeapSort<T>.BuildHeap(List: TList<T>; const AComparer: IComparer<T>);
var
  Index: Integer;
begin

  for Index := (List.Count div 2) - 1 downto 0 do
  begin
    Heapify(List,Index,List.Count,AComparer);
  end;

end;

class procedure THeapSort<T>.Heapify(List: TList<T>; Index: Integer; Max: Integer;
                                     const AComparer: IComparer<T>);
var
  Left: Integer;
  Right: Integer;
  Largest: Integer;
begin

  Left  := Index * 2 + 1;
  Right := Index * 2 + 2;

  if (Left < Max) and (AComparer.Compare(List.Items[Left],List.Items[Index]) > 0) then
  begin
    Largest := Left;
  end
  else
  begin
    Largest := Index;
  end;

  if (Right < Max) and (AComparer.Compare(List.Items[Right],List.Items[Largest]) > 0) then
  begin
    Largest := Right;
  end;

  if Largest <> Index then
  begin
    List.Exchange(Index,Largest);

    Heapify(List,Largest,Max,AComparer);
  end;

end;

マージソートです。

type
  TMergeSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
    class procedure  InternalSort(List: TList<T>; var Work: array of T;
                                  Left: Integer; Right: Integer;
                                  const AComparer: IComparer<T>);
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TMergeSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TMergeSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TMergeSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  WorkArea: array of T;
begin

  SetLength(WorkArea,List.Count);
  try
    InternalSort(List,WorkArea,0,List.Count - 1,AComparer);

  finally
    SetLength(WorkArea,0);
  end;

end;

class procedure TMergeSort<T>.InternalSort(List: TList<T>; var Work: array of T;
                                           Left: Integer; Right: Integer;
                                           const AComparer: IComparer<T>);
var
  Index1: Integer;
  Index2: Integer;
  Index3: Integer;
  Mid: Integer;
begin

  if Left >= Right then
  begin
    Exit;
  end;

  Mid := (Left + Right) div 2;
  InternalSort(List,Work,Left,   Mid,  AComparer);
  InternalSort(List,Work,Mid + 1,Right,AComparer);

  for Index1 := Left to Mid do
  begin
    Work[Index1] := List.Items[Index1];
  end;

  Index2 := Right;
  for Index1 := Mid + 1 to Right do
  begin
    Work[Index1] := List.Items[Index2];
    Index2 := Index2 - 1;
  end;

  Index1 := Left;
  Index2 := Right;
  for Index3 := Left to Right do
  begin
    if AComparer.Compare(Work[Index1],Work[Index2]) > 0 then
    begin
      List.Items[Index3] := Work[Index2];
      Index2 := Index2 - 1;
    end
    else
    begin
      List.Items[Index3] := Work[Index1];
      Index1 := Index1 + 1;
    end;
  end;

end;

シェルソートです。

type
  TShellSort<T> = class(TSortAlgorithm<T>)
  protected
    class var
      FInstance: TSortAlgorithm<T>;
    class procedure  InternalSort(List: TList<T>; Gap: Integer;
                                  const AComparer: IComparer<T>);
  public
    class destructor Destroy;
    class function   Instance: TSortAlgorithm<T>; override;
    class procedure  Sort(List: TList<T>; const AComparer: IComparer<T>); override;
  end;

class destructor TShellSort<T>.Destroy;
begin

  FInstance.Free;

end;

class function TShellSort<T>.Instance: TSortAlgorithm<T>;
begin

  if FInstance = nil then
  begin
    FInstance := Self.Create;
  end;

  Result := FInstance;

end;

class procedure TShellSort<T>.Sort(List: TList<T>; const AComparer: IComparer<T>);
var
  Gap: Integer;
begin

  Gap := List.Count div 2;
  while Gap > 0 do
  begin
    InternalSort(List,Gap,AComparer);

    Gap := Gap div 2;
  end;

end;

class procedure TShellSort<T>.InternalSort(List: TList<T>; Gap: Integer;
                                           const AComparer: IComparer<T>);
var
  Index1: Integer;
  Index2: Integer;
begin

  for Index1 := Gap to List.Count - 1 do
  begin
    Index2 := Index1 - Gap;
    while Index2 >= 0 do
    begin
      if AComparer.Compare(List.Items[Index2 + Gap],List.Items[Index2]) > 0 then
      begin
        Break;
      end;

      List.Exchange(Index2,Index2 + Gap);
      Index2 := Index2 - Gap;
    end;
  end;

end;

Instanceメソッドとクラスデストラクタを毎回書かなければならないことを除けば、ソートのコードを1つ書くだけで値型に対するTList<T>(TList<String>を含む)、クラスに対するTObjectList<T>のどちらであってもソートを行うことができます。

→ジェネリックスのリストをアルゴリズムを指定してソートする(Gist)

RAD Studio/Delphi/C++Builder 10 Seattle November 2016 Update

RAD Studio/Delphi/C++Builder 10 SeattleのNovember 2016 Updateがリリースされています。有効なアップデートサブスクリプションが必要です。

30663 November 2016 Seattle Update Subscription Update

Fall 2016 XE8 and 10 Seattle Updates - Embarcadero Community

IDE Fix Pack 5.95

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.95となっています。RAD Studio/Delphi/C++Builder 10.1 Berlin対応といくつかの新しいパッチが追加されています。

IDE Fix Pack 5.95 for Delphi 10.1 Berlin | Andy's Blog and Tools

DDevExtensions 2.84

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.84となっています。RAD Studio 10.1 Berlinへの対応とちょっとした機能追加が行われています。

DDevExtensions and DFMCheck for 10.1 Berlin | Andy's Blog and Tools

ちなみにAndreas Hausladenさんが休暇から戻ったらGoogle+とメールはIDEFixPackの10.1 Berlin対応のリクエストで一杯だったとのこと。

RAD Studio/C++Builder 10 Seattle AQTime Hotfix

RAD Studio 10 SeattleのHotfixがリリースされています。RAD Studio/Delphi/C++Builder 10 SeattleでAQTimeを使用している場合の問題を修正するものです。

30489 RAD Studio Deployment hotfix for 10 Seattle (Beta)

Windowsがサーバ版かどうかを調べる

プログラムが動作している環境(Windows)がサーバ版かどうかを調べたいことがまれにあります(WMIでサーバ版Windowsではサポートされていない項目の問い合わせをするときなど)。RTLのソースをちょっと覗いてみたところ、Win32APIのGetVersionEx (ja)関数で取得したOSVERSIONINFOEX構造体のwProductTypeがVER_NT_WORKSTATIONかどうかで判断できるようなのですが、GetVersionEx関数のRemarksにはVerifyVersionInfo (ja)関数を使ったほうがパフォーマンス上望ましい、と書いてあるようなので、VerifyVersionInfo関数(とそのパラメータを組み立てるためにVerSetConditionMask関数の組み合わせ)で実現してみました。

function IsWindowsServer: Boolean;
var
  OSVI: TOSVersionInfoEx;
  ConditionMask: UInt64;
begin

  FillChar(OSVI,SizeOf(TOSVersionInfoEX),0);
  OSVI.dwOSVersionInfoSize := SizeOf(OSVI);
  OSVI.wProductType := VER_NT_WORKSTATION;

  ConditionMask := VerSetConditionMask(0,VER_PRODUCT_TYPE,VER_EQUAL);

  Result := not (VerifyVersionInfo(OSVI,VER_PRODUCT_TYPE,ConditionMask));

end;

OSVERSIONINFOEX構造体を初期化後、wProductTypeにVER_NT_WORKSTATIONを格納し、これに対応する条件マスク(VER_PRODUCT_TYPEがVER_EQUAL)をVerifyVersionInfoで作成してVerifyVersionInfoで問い合わせて、結果がFalse(wProductTypeがVER_NT_WORKSTATION以外)ならサーバ版Windows、という判定です。

→Windowsがサーバ版かどうかを調べる(Gist)

整数の中で立っているビットの数を数える

それほど機会が多いわけではありませんが、整数の中で立っているビットの数を数えたいということがあります。C++であればstd::bitsetのcountを使えば一発ですが、残念ながらDelphiでは符号なし整数型のヘルパ(TByteHelper/TWordHelper/TCardinalHelper/TUInt64Helper)を含め、標準ではそのような機能がありません。でちょっと検索してみたところ、population countあるいはHamming weightというキーワードが浮かんできました。最近のCPUには専用の命令(x86だとSSE4.2以降のPOPCNT)がありますが、移植性などを考慮して、Delphiで実装してみました。とはいってもCで書かれたものをそのままDelphiに置き換えただけです。詳細や原理については○×つくろーどっとコムさんのその17 ビット演算あれこれや中村実さんのビットを数える・探すアルゴリズムなどを、またx86/x64のPOPCNT命令との比較についてはtakesakoさんのx86x64 SSE4.2 POPCNTあたりを参照してください。

function PopulationCount(Value: UInt8): Integer;
begin

  Value := (Value and $55) + ((Value shr 1) and $55);
  Value := (Value and $33) + ((Value shr 2) and $33);
  Value := (Value and $0F) + ((Value shr 4) and $0F);
  Result := Value;

end;

function PopulationCount(Value: UInt16): Integer;
begin

  Value := (Value and $5555) + ((Value shr 1) and $5555);
  Value := (Value and $3333) + ((Value shr 2) and $3333);
  Value := (Value and $0F0F) + ((Value shr 4) and $0F0F);
  Value := (Value and $00FF) + ((Value shr 8) and $00FF);
  Result := Value;

end;

function PopulationCount(Value: UInt32): Integer;
begin

  Value := (Value and $55555555) + ((Value shr  1) and $55555555);
  Value := (Value and $33333333) + ((Value shr  2) and $33333333);
  Value := (Value and $0F0F0F0F) + ((Value shr  4) and $0F0F0F0F);
  Value := (Value and $00FF00FF) + ((Value shr  8) and $00FF00FF);
  Value := (Value and $0000FFFF) + ((Value shr 16) and $0000FFFF);
  Result := Value;

end;

function PopulationCount(Value: UInt64): Integer;
begin

  Value := (Value and $5555555555555555) + ((Value shr  1) and $5555555555555555);
  Value := (Value and $3333333333333333) + ((Value shr  2) and $3333333333333333);
  Value := (Value and $0F0F0F0F0F0F0F0F) + ((Value shr  4) and $0F0F0F0F0F0F0F0F);
  Value := (Value and $00FF00FF00FF00FF) + ((Value shr  8) and $00FF00FF00FF00FF);
  Value := (Value and $0000FFFF0000FFFF) + ((Value shr 16) and $0000FFFF0000FFFF);
  Value := (Value and $00000000FFFFFFFF) + ((Value shr 32) and $00000000FFFFFFFF);
  Result := Value;

end;

→整数の中で立っているビットの数を数える(Gist)

2020/06/01追記: Delphi 10.4 Sydneyでは標準関数(かつ組み込みルーチン(en))としてCountLeadingZeros32(先頭の(MSBからの)連続している0の数/32bit整数)、CountLeadingZeros64(先頭の(MSBからの)連続している0の数/64bit整数)、CountTrailingZeros32(末尾のの(LSBからの)連続している0の数/32bit整数)、CountTrailingZeros64(末尾のの(LSBからの)連続している0の数/64bit整数)、CountPopulation32(1になっているビットの数/32bit整数)、CountPopulation64(1になっているビットの数/64bit整数)が追加されました。これらの関数はコンパイラによってインラインで展開されるため、System.pasなどに定義がありません。またこれらの関数は現時点ではヘルプ上に記述がありません。

RAD Studio/C++Builder 10 Seattle Update 1 VCL AppAnalytics Hotfix

RAD Studio 10 Seattle Update 1のHotfixがリリースされています。RAD Studio/Delphi/C++Builder 10 SeattleのUpdate 1適用後のVCL AppAnalyticsアプリケーションでサーバとの接続の問題を修正するものです。

30457 10 Seattle Update 1 VCL AppAnalytics Hotfix

2016/02/17追記: 2016/02/16付で更新されています。Pro SKU適用時の問題を解決することのことです。

10 Seattle アップデートサブスクリプション加入ユーザー向け「10 Seattle Update 1 VCL AppAnalytics Hotfix」の更新

RAD Studio/C++Builder 10 Seattle Hotfix for iOS 9.2

RAD Studio 10 SeattleのHotfixがリリースされています。RAD Studio/C++Builder 10 SeattleでターゲットがiOS 9.2のときにコンパイルエラーが発生する不具合を修正するものです。

30456 10 Seattle iOS 9.2 C++ Hotfix - December 2015

Team Japan » 10 Seattle 向け「10 Seattle iOS 9.2 C++ Hotfix - December 2015」

明示はされていませんが、RTM、Update 1のどちらにも適用可能と思われます。またアップデートサブスクリプションの加入とは関係なくダウンロードできます。

要素数が256を超える集合型を作る

このアーティクルはDelphi Advent Calendar 2015の14日目の記事です(3年ぶり3回目)。

Delphiの特徴的な型として集合型というものがあります。これは基底型となる列挙型、部分範囲型の組み合わせを保持できるというもので、C言語のビットフィールドに相当するものですが、各種演算子などが用意されており、非常に便利な言語機能です。しかし集合型にはその基底型の要素数が256以下、正確には順序値として0から255まで、という制約があります。しかし状況によっては256要素を超えるような、あるいは基底型で負値となるものを含むような集合型が欲しいということがあります。そこで既存の集合型になるべく近い形で実装してみることにします。ただしDelphiのジェネリックスはC++のテンプレートとは実装が異なり文法的制約が厳しい(というか値型にはほぼ使えない)ため、ジェネリックスによる汎用の実装ではなく個別の実装になってしまいます。また本来の集合型と同様に使えるよう、参照型(クラスによる実装)ではなく値型である高度なレコード型による実装とします。

まず基底型となる列挙型を定義します。

type
  TFoo = (Foo0 = -1,
          Foo1,
          Foo2,
          Foo3,
          Foo4,
          Foo5,
          FooMax = 256);

順序値が-1から256なのでこれを基底型とする集合型を定義すると

type
  TFooSet = set of TFoo;  // Error: E2028 Sets may have at most 256 elements

(当然ですが)エラーになります。では代替となる高度なレコード型を定義していきます。

const
  BYTE_BIT = 8;  //  Number of bits in byte

type
  TFooSet = record
  private
    FData: array [0..((Ord(High(TFoo)) - Ord(Low(TFoo)) + 1 + (BYTE_BIT - 1)) div BYTE_BIT) - 1] of Byte;
  public
    procedure   Empty;
    function    IsEmpty: Boolean;
  end;

procedure TFooSet.Empty;
begin

  FillChar(FData[0],SizeOf(FData),0);

end;

function TFooSet.IsEmpty: Boolean;
var
  Offset: Integer;
begin

  Result := False;

  for Offset := Low(FData) to High(FData) do
  begin
    if FData[Offset] <> 0 then
    begin
      Result := True;
      Exit;
    end;
  end;

end;

FDataは基底型に対応したビット列を実際に格納する領域で、Emptyはその領域を0クリアするメソッド、IsEmptyはビット列が全て0となっているかどうかをチェックするメソッドです。

次に基底型に対応する要素を追加、削除するメソッド(Include、Exclude)です。単独の要素、複数の要素(array of)のどちらにも対応します。

type
  TFooSet = record
  private
    ...
    class procedure CalcOffsets(Value: TFoo; var AOffset: Integer; var ABit: Byte); static;
  public
    ...
    procedure   Include(Value: TFoo); overload;
    procedure   Include(const Values: array of TFoo); overload;
    procedure   Exclude(Value: TFoo); overload;
    procedure   Exclude(const Values: array of TFoo); overload;
  end;

procedure TFooSet.Include(Value: TFoo);
var
  Offset: Integer;
  Bit: Byte;
begin

  CalcOffsets(Value,Offset,Bit);
  FData[Offset] := FData[Offset] or Bit;

end;

procedure TFooSet.Include(const Values: array of TFoo);
var
  Value: TFoo;
begin

  if Length(Values) > 0 then
  begin
    for Value in Values do
    begin
      Include(Value);
    end;
  end;

end;

procedure TFooSet.Exclude(Value: TFoo);
var
  Offset: Integer;
  Bit: Byte;
begin

  CalcOffsets(Value,Offset,Bit);
  FData[Offset] := FData[Offset] and (not Bit);

end;

procedure TFooSet.Exclude(const Values: array of TFoo);
var
  Value: TFoo;
begin

  for Value in Values do
  begin
    Exclude(Value);
  end;

end;

class procedure TFooSet.CalcOffsets(Value: TFoo; var AOffset: Integer; var ABit: Byte);
var
  RelPos: Integer;
begin

  RelPos  := Ord(Value) - Ord(Low(TFoo));
  AOffset := RelPos div BYTE_BIT;
  ABit    := 1 shl (RelPos mod BYTE_BIT);

end;

CalcOffsetsは基底型の要素がどのビット位置に割り当てられているのかを計算します。

次は基底型の要素が含まれているかどうかを調べるInメソッドです。Inは予約語のため"&"で修飾します。

type
  TFooSet = record
    ...
  public
    ...
    function    &In(Value: TFoo): Boolean;
  end;

function TFooSet.&In(Value: TFoo): Boolean;
var
  Offset: Integer;
  Bit: Byte;
begin

  CalcOffsets(Value,Offset,Bit);
  Result := (FData[Offset] and Bit) <> 0;

end;

あとは何らかの形で文字列化できないと不便なので、16進文字列化するToStringと16進文字列からレコード型に値を入れるParseを用意します。

type
  TFooSet = record
    ...
  public
    ...
    function    ToString(ZeroSuppression: Boolean = True): String;
    class function Parse(const Value: String): TFooSet; static;
  end;

function TFooSet.ToString(ZeroSuppression: Boolean): String;
var
  Index: Integer;
  Len: Integer;
  Offset: Integer;
begin

  Result := '';

  for Offset := Low(FData) to High(FData) do
  begin
    Result := IntToHex(FData[Offset],2) + Result;
  end;

  if ZeroSuppression = True then
  begin
    Index := 1;
    Len := Length(Result);
    while (Index < Len) and (Result[Index] = '0') do
    begin
      Index := Index + 1;
    end;

    if Index > 1 then
    begin
      Delete(Result,1,Index - 1);
    end;
  end;

end;

class function TFooSet.Parse(const Value: String): TFooSet;
var
  Offset: Integer;
  S: String;
begin

  Result.Clear;

  S := StringOfChar('0',(SizeOf(Result.FData) * 2) - Length(Value)) + Value;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := StrToInt('$' + Copy(S,(SizeOf(Result.FData) * 2) - (Offset * 2) - 1,2));
  end;

end;

必要な処理はこれで概ね揃いましたが、まだ既存の集合型と同じように使う、というわけにはいきません。そこで演算子オーバロードを用意します。集合型に対応する演算子には"+"(和集合)、"-"(差集合)、"*"(積集合)、"<="(サブセット)。">="(スーパーセット)、"="(等しい)、"<>"(等しくない)、"in"(メンバかどうか)の8つがあります。まず基底型の配列からの暗黙的な型キャストを行うImplicitと、"+"(class operator Add)、"-"(class operator Subtract)、"*"(class operator Multiply)の3つの演算子オーバロードです。

type
  TFooSet = record
    ...
  public
    ...
{$IF CompilerVersion>=24.00}
    class operator Implicit(const Values: array of TFoo): TFooSet;
{$IFEND}
    class operator Add(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet; overload;
{$IF CompilerVersion>=28.00}
    class operator Add(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet; overload;
{$IFEND}
    class operator Subtract(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet; overload;
{$IF CompilerVersion>=28.00}
    class operator Subtract(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet; overload;
{$IFEND}
    class operator Multiply(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet; overload;
{$IF CompilerVersion>=28.00}
    class operator Multiply(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet; overload;
{$IFEND}
  end;

{$IF CompilerVersion>=24.00}
class operator TFooSet.Implicit(const Values: array of TFoo): TFooSet;
begin

  Result.Clear;
  Result.Include(Values);

end;
{$IFEND}

class operator TFooSet.Add(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet;
var
  Offset: Integer;
begin

  Result.Clear;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := lvalue.FData[Offset] or rvalue.FData[Offset];
  end;

end;

{$IF CompilerVersion>=28.00}
class operator TFooSet.Add(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet;
var
  Value: TFoo;
begin

  Result := lvalue;

  for Value in rvalue do
  begin
    Result.Include(Value);
  end;

end;
{$IFEND}

class operator TFooSet.Subtract(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet;
var
  Offset: Integer;
begin

  Result.Clear;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := lvalue.FData[Offset] and (not rvalue.FData[Offset]);
  end;

end;

{$IF CompilerVersion>=28.00}
class operator TFooSet.Subtract(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet;
var
  Value: TFoo;
begin

  Result := lvalue;

  for Value in rvalue do
  begin
    Result.Exclude(Value);
  end;

end;
{$IFEND}

class operator TFooSet.Multiply(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet;
var
  Offset: Integer;
begin

  Result.Clear;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := lvalue.FData[Offset] and rvalue.FData[Offset];
  end;

end;

{$IF CompilerVersion>=28.00}
class operator TFooSet.Multiply(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet;
begin

  Result := lvalue * TFooSet(rvalue);

end;
{$IFEND}

ここで明示的な型キャストを行うExplicitを用意しなかったのは、"TFooSet([Foo0,Foo2])"の"[Foo0,Foo2]"の部分がarray of TFooではなくset of TFooと解釈されてしまいコンパイルエラー(E1012)となる問題を解決できなかったためです。また同様の理由からImplicitはXE3以降、Add/Subtract/Multiplyの2番目のoverload(右項がarray of TFoo)はXE7以降のみ有効です。

次に"<="(class operator LessThanOrEqual)。">="(class operator GreaterThanOrEqual)、"="(class operator Equal)、"<>"(class operator NotEqual)、"in"(class operator In)です。

type
  TFooSet = record
    ...
  public
    ...
    class operator LessThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator GreaterThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator Equal(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator NotEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator In(lvalue: TFoo; const rvalue: TFooSet): Boolean;
  end;

class operator TFooSet.LessThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
var
  Offset: Integer;
begin

  for Offset := Low(lvalue.FData) to High(lvalue.FData) do
  begin
    if (lvalue.FData[Offset] and rvalue.FData[Offset]) <> lvalue.FData[Offset] then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;

end;

class operator TFooSet.GreaterThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
var
  Offset: Integer;
begin

  for Offset := Low(lvalue.FData) to High(lvalue.FData) do
  begin
    if (lvalue.FData[Offset] and rvalue.FData[Offset]) <> rvalue.FData[Offset] then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;

end;

class operator TFooSet.Equal(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
var
  Offset: Integer;
begin

  for Offset := Low(lvalue.FData) to High(lvalue.FData) do
  begin
    if (lvalue.FData[Offset] xor rvalue.FData[Offset]) <> 0 then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;

end;

class operator TFooSet.NotEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
begin

  Result := not (lvalue = rvalue);

end;

class operator TFooSet.In(lvalue: TFoo; const rvalue: TFooSet): Boolean;
begin

  Result := rvalue.&In(lvalue);

end;

ここでclass operator LessThanOrEqual/GreaterThanOrEqual/Equal/NotEqualにAdd/Subtract/Multiplyのようにarray of TFooを第2パラメータ(右項)とするものを用意しなかったのもExplicitと同様の理由です。

これでTFooSetに対する演算子も一通り揃いました。残るはfor-inループ構造への対応です。必要なものはfor 文を使用するコンテナの繰り返しにあるように、Booleanを返し次の値を指し示すMoveNextメソッドとコレクションに含まれる値を返すCurrentプロパティとを持つようなクラス、インタフェース、レコードのいずれかを返すGetEnumeratorメソッド、ということになります。ここではネストした形でクラスを定義します。

type
  PFooSet = ^TFooSet;
  TFooSet = record
  private
    type
      TEnumerator = class(TObject)
      private
        FContainer: PFooSet;
        FIndex: Integer;
        function GetCurrent: TFoo;
      public
        constructor Create(Container: PFooSet);
        function MoveNext: Boolean;
        property Current: TFoo
                   read GetCurrent;
      end;
  public
    ...
    function GetEnumerator: TEnumerator;
  end;

function TFooSet.GetEnumerator: TEnumerator;
begin

  Result := TEnumerator.Create(@Self);

end;

constructor TFooSet.TEnumerator.Create(Container: PFooSet);
begin

  inherited Create;

  FIndex := Ord(Low(TFoo)) - 1;
  FContainer := Container;

end;

function TFooSet.TEnumerator.MoveNext: Boolean;
begin

  while (FIndex < Ord(High(TFoo))) do
  begin
    FIndex := FIndex + 1;
    if TFoo(FIndex) in FContainer^ then
    begin
      Result := True;
      Exit;
    end;
  end;

  Result := False;

end;

function TFooSet.TEnumerator.GetCurrent: TFoo;
begin

  Result := TFoo(FIndex);

end;

これでTFooSetに対して通常の集合型のように"+"、"-"、"*"のような演算や"="、"<>"のような比較、for..inによる要素の取り出しを行うことができるようになりました。 同様にすることで部分範囲型で値が0..255に収まらないようなものを基底型とするような集合型も実装することができます。 →要素数が256を超える列挙型の集合型(Gist) →値範囲が0..255に収まらない部分範囲型の集合型(Gist)

RAD Studio 10 Seattle Update 1 Hotfix

RAD Studio 10 Seattle Update 1のHotfixが2件リリースされています。1件目はIDEが使っているModernThemeのメモリ/GDIリソースリーク(RSP-13023)を修正するものです

30453 10 Seattle Update 1 ModernTheme Hotfix - December 2015

2件目はC++/Clangのローカライズ時の不具合(詳細不明)を修正するものです。

30454 10 Seattle Update 1 C++ Clang FR/DE/JA Hotfix


Team Japan » 10 Seattle アップデートサブスクリプション加入ユーザー向け「10 Seattle Update 1 C++ Clang FR/DE/JA Hotfix」
2 Hot-Fixes for 10 Seattle Update 1

RAD Studio/Delphi/C++Builder 10 Seattle Update 1

RAD Studio/Delphi/C++Builder 10 SeattleのSubcription Update 1がリリースされています。

30445 Delphi and C++Builder 10 Seattle ISO (includes Update 1)

Subscription Update 1 - RAD Studio

RAD Studio 10 Seattle における不具合修正リスト (en)

RAD Studio 10 Seattle Update 1 公開
Team Japan » サブスクリプション加入ユーザー向け「10 Seattle Subscription Update 1」

Update 1の適用は(上書きではなく)アンインストール後の再インストールとなります。またUpdate Subscription加入者限定となります。

IDE Fix Pack 5.94

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.94となっています。RAD Studio/Delphi/C++Builder 10 Seattle対応といくつかの新しいパッチが追加されています。

IDE Fix Pack 5.94 released – RAD Studio 10 Seattle support | Andy's Blog and Tools

2015/11/02追記: SSE4.2非サポートのCPUの対応に不具合があり差し替えになっています。ご注意ください。

RAD Studio/Delphi 10 Seattle Windows/x64 Compiler Hotfix (Beta)

RAD Studio/Delphi 10 SeattleのDelphi/Windows/x64コンパイラのコンパイル結果が決定論的ではない([RSP-12512] DCC64 codegen isn't deterministic (regression))という不具合が報告されており、これを修正するHotfix(Beta)がリリースされています。

30428 Delphi Win64 Compiler hotfix for 10 Seattle Professional (Beta)
30429 Delphi Win64 Compiler hotfix for 10 Seattle Enterprise (Beta)

10 Seattle向けDelphi Win64コンパイラホットフィックス

最終的な修正は次のアップデート(Update 1)に含まれる予定とのことです。

Spring4Dのマルチキャストイベントを使う

Delphi/VCLの大きな特徴のひとつである"PMEモデル(Properties, Methods and Events model)"の"E"、イベントハンドラは基本的に関数ポインタ(実際にはTMethod = データポインタ + 関数ポインタ)で実装されており、結果としてイベントはユニキャスト、つまりある事象の通知を受け取れるのは一つのイベントハンドラのみ、ということになっています。しかし状況によってはマルチキャスト、つまり複数のイベントハンドラに事象の通知を送りたい、ということがあります。デザインパターンでいうとオブザーバパターンとなるような状況です。デザインパターンの定石に従って、たとえばBranko StojakovicさんのGoF Patterns in DelphiのObserverやNick HodgesさんのMore Coding in Delphiにあるように、IObserverとISubjectを実装して…というやりかたも考えましたが、マルチキャストで通知したい事象が何種類もある状況だと、何らかの形でジェネリックス化されている実装でないと厳しそうです。そこで探してみると、Spring4DというDI(dependency injection)フレームワークでマルチキャストイベントが実装されているということだったので、これを試してみることにします。なおSpring4DのライセンスはApache License 2.0です(日本語参考訳)。またSpring4Dそのもの(DIコンテナとしてのSpring4D)については第28回エンバカデロ・デベロッパーキャンプのLTの岡野さんのプレゼンテーション資料が非常に参考になります。

まずSpring4Dのなかでマルチキャストを実現しているのはEvent<T>レコード型になります。これを使用するのに必要なユニットですが、Source\Baseフォルダにある

• Spring.pas
• Spring.inc
• Spring.ResourceStrings.pas
• Spring.Events.Base.pas
• Spring.Events.pas
• jedi.inc

です。もちろんSpring4Dをインストールして検索パスにSpring4D関係のフォルダを追加しても構いませんが、マルチキャストだけを試すのであればこれらのファイルをコピーして.pasファイルをプロジェクトに追加するだけでも大丈夫です。

では実際にEvent<T>でマルチキャストを試してみます。今回はメインフォームからモードレスなサブフォームをいくつか表示して、フォーム上のボタンクリックの発生と、その累計回数を各フォームに通知します。

まず通知のためのイベントと、イベントを登録/削除するインタフェースを定義します。

type
  TNotifyNumber = procedure (Sender: TObject; Number: Integer) of object;

  ISubject = interface
    procedure Add(AEvent: TNotifyNumber);
    procedure Remove(AEvent: TNotifyNumber);
  end;

TNotifyNumberが通知のためのイベントハンドラの型、ISubjectがそのイベントハンドラを登録/削除する機能を持たせたインタフェースです。メインフォーム、サブフォームの両方で使用するので別ユニットで定義しておきます。次はメインフォームです。

uses
  Spring, ...

type
  TForm1 = class(TForm,ISubject)
    ...
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FEvent: Event<TNotifyNumber>
  public
    procedure Add(AEvent: TNotifyNumber);
    procedure Remove(AEvent: TNotifyNumber);
  end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FEvent := Event<TNotifyNumber>.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FEvent.Clear;
end;

procedure TForm1.Add(AEvent: TNotifyNumber);
begin
  FEvent.Add(AEvent);
end;

procedure TForm1.Remove(AEvent: TNotifyNumber);
begin
  FEvent.Remove(AEvent);
end;

メインフォームはISubjectインタフェースを継承するようにして、AddとRemoveを実装します。Event<T>はレコード型ですが、内部の適切な初期化のためにclass function Createを呼び出しておく必要があります。AddとRemoveでは単にEvent<T>のAddとRemoveを呼び出すだけです。一方サブフォームでは

type
  TForm2 = class(TForm)
    ...
  private
    FSubject: ISubject;
  public
    property Subject: ISubject
               read  FSubject
               write FSubject;
  end;

メインフォームをISubjectとして保持するためのプロパティを用意します。これでメインフォームからサブフォームを生成、表示する処理は

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TForm2.Create(Self) do
  begin
    Subject := Self;
    Show;
  end;
end;

となります。サブフォーム側ではボタンクリックで任意にマルチキャストイベントを登録、削除できるようにしてみます、

type
  TForm2 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    ...
    procedure DoNotifyNumber(Sender: TObject; Number: Integer);
  public
    ...
  end;

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Subject.Remove(DoNotifyNumber);
  Action := caFree;
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
  Subject.Add(DoNotifyNumber);
end;

procedure TForm2.Button2Click(Sender: TObject);
begin
  Subject.Remove(DoNotifyNumber);
end;

procedure TForm2.DoNotifyNumber(Sender: TObject; Number: Integer);
begin
  Label1.Caption := 'Notified number is ' + IntToStr(Number);
end;

procedure DoNotifyNumberがマルチキャストイベントのイベントハンドラで、これをButton1/Button2のクリックイベントでSubjectにAdd/Removeすることで登録、削除します。最後にメインフォーム側からのマルチキャストイベントの呼び出しです。

type
  TForm1 = class(TForm,ISubject)
    ...
    Label1: TLabel;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
  private
    FCount: Integer;
    ...
  public
    ...
  end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FCount := FCount + 1;
  Label1.Caption := IntToSTr(FCount);
  FEvent.Invoke(Self,FCount);
end;

Selfと1ずつ増える整数値(FCount)でEvent<T>のInvokeメソッドを呼び出すだけです(正確にはInvokeはイベントハンドラ型(<T> = <TNotifyNumber>)のプロパティで、Invoke(...)とすることでメソッドの呼び出しになる)。

Spring4DのEventがよくできていることもあってそれほど難しくはないと思います(気をつけなければならないのはclass function CreateによるEvent<T>の明示的な初期化くらい)。ただEvent<T>のTには通常のイベントハンドラ(procedure ... of object)だけでなく、無名メソッド(reference to ...)も入れられるのですが、この場合Event<T>で保持されるものが自動的に生成される無名メソッド値(TInterfacedObjectの派生クラスのインスタンス)であり、そのポインタをAddの呼び出し側(TForm2)では知ることができないためRemoveできない、という点には注意が必要です。

RAD Studio/Delphi/C++Builder 10 Seattle PAServer Hotfix

RAD Studio/Delphi/C++Builder 10 SeattleのPAServer Hotfixがリリースされています。OS X 10.11対応とiOS 9 SDK対応とのことです。またUpdate Subscriptionとは関係なくダウンロードできます。

30398 PAServer Hotfix for Delphi, C++Builder and RAD Studio 10 Seattle

PAServer Hotfix for RAD Studio 10 Seattle - iOS 9 and OS X El Capitan
How to use custom Info.plist XML to support iOS 9's new App Transport Security feature

GetIt経由でインストールしたTurboPack LockBox 3.5がRAD Studio XE8と10 Seattleで干渉する問題とその暫定解決策

RAD Studio XE8で導入されたGetItパッケージマネージャは、簡単にコンポーネントなどのパッケージをIDEに登録することができる便利なツールです。ところがここに登録されているTurboPack LockBox 3.5のパッケージ名がXE8のものと10 Seattleのもので同一("LockBox3DR.bpl"、"LockBox3DD.bpl")となっており、パッケージは環境変数PATHに従って検索されるため、同一環境上のXE8と10 Seattleの両方にLockBoxを入れると先にインストールしたIDEが誤って別のバージョンのbplファイルを読み込んでしまいエラーになる、という現象があります(2015/09/24現在)。この問題、既にTurboPackのメンテナであるRomanさんのほうでは認識しており、GitHub上のリポジトリではXE8のほうのLIBサフィックスには220、10 Seattleのほうには230がつけられているのですが、GetItで配布されるものにはまだこれらの変更が反映されていないようです。

ということで暫定解決策ですが、次の3つが考えられます。

1. GetItを使わずGitHubから最新のもの(XE8、10 Seattle)をチェックアウトしてインストールする。
2. 誤動作するほうのバージョンのIDEのショートカットの作業フォルダにbplの保存先を明示的に指定する(XE8なら"C:\Users\Public\Documents\Embarcadero\Studio\16.0\Bpl"、10 Seattleなら"C:\Users\Public\Documents\Embarcadero\Studio\17.0\Bpl")。
3. 自分でLIBサフィックスを指定しなおす。具体的には
   1. "ファイル"→"プロジェクトを開く"でXE8なら"C:\Users\<username>\Documents\Embarcadero\Studio\16.0\CatalogRepository\LockBox-3.5.0\packages\Delphi"、10 Seattleなら"C:\Users\<username>\Documents\Embarcadero\Studio\17.0\CatalogRepository\LockBox-3.5.0\packages\Delphi"にあるDelphi.groupprojを開く
   2. プロジェクトマネージャでLockBox3DD.bplを右クリック→アンインストール
   3. 当該バージョンのbplフォルダにある"LockBox3DR.bpl"と"LockBox3DD.bpl"を削除する
   4. LockBox3DD.bpl、LockBox3DR.bplのプロジェクトオプションでターゲットを"すべての構成 - すべてのプラットフォーム"にしておいて、"説明"のLIBサフィックスを220(XE8)または230(10 Seattle)に変更する
   5. "プロジェクト"→"すべてのプロジェクトをコンパイル"でコンパイルする(DEBUGビルドのみでいいようです)
   6. LockBox3DR220.bpl(XE8)またはLockBox3DR230.bpl(10 Seattle)を右クリック→インストール
   という手順になります。この場合、GetItからLockBox 3.5をアンインストールしたときに完全に削除されなかったりするかもしれませんが、その場合はアンインストール後にマニュアルでbplフォルダの下のLockBox*.*とCatalogRepositoryフォルダ(C:\Users\<username>\Documents\Embarcadero\Studio\XX.X\CatalogRepository)の下のLockBox-3.5.0フォルダを削除すればいいようです。

(C++Builderをお使いの方は"packages\CBuilder\CBuilder.groupproj"だったり"LockBox3CR.bpl"だったり"LockBox3CD.bpl"だったりしますが、適当に読み替えてください)

休日にもかかわらず鋭い指摘をいただいた、おに(@onimaro2010)さんに感謝いたします。とりあえずまとめました。