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

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

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)

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対応のリクエストで一杯だったとのこと。

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などに定義がありません。またこれらの関数は現時点ではヘルプ上に記述がありません。

要素数が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)

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の対応に不具合があり差し替えになっています。ご注意ください。

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できない、という点には注意が必要です。

IDE Fix Pack 5.93

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.93となっています。今回はWindows 10対応(Windows 10が関数アライメントのパディングにNOPではなくINT3を使うことに対応)だけとのことです。

IDE Fix Pack 5.93 – Windows 10 support | Andy's Blog and Tools

IDE Fix Pack 5.92

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.92となっています。不具合を2点修正とのことです。

IDE Fix Pack 5.92 released | Andy's Blog and Tools

IDE Fix Pack 5.91

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.91となっています。

IDE Fix Pack 5.91 – Bugfix release | Andy's Blog and Tools

DDevExtensions 2.83/IDE Fix Pack 5.9

Andreas HausladenさんのDDevExtensionsとIDE Fix PackがRAD Studio XE8に対応しました。

DDevExtensions 2.83 for XE8 released | Andy's Blog and Tools
IDE Fix Pack 5.9 for RAD Studio 2009-XE8 | Andy's Blog and Tools

2015/09/20追記: DDevExtensionsがRAD Studio/Delphi/C++Builder 10 Seattleに対応して再リリースされています。内容に変更はないとのことで、バージョンも2.83のままとなっています。

IDE Fix Pack 5.8

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.8になっています。このバージョンでは規模の大きなパッケージが別の大きなパッケージに依存しているときのパフォーマンスの改善などの新機能と、Windows 8.1環境下でのDelphi 2009起動時の問題や、一部の環境でIDE Fix Packをインストール/アンインストールしようとしたときにエラーが発生する問題などの修正が行われています、

IDE Fix Pack 5.8 for 2009-XE7 released | Andy's Blog and Tools

シリアルポートをフレンドリ名で列挙する

以前使用できるシリアルポートをレジストリから列挙する方法について書きましたが、今度はシリアルポートをそのフレンドリ名(デバイスマネージャ上で表示される表記)とともに列挙する方法です。

フレンドリ名の取得にはSetup APIを使用しますが、残念ながらDelphiにはSetup API関係の定義が含まれていない(C++Builderならsetupapi.hがあるのですが)ため、まずは必要なWin32APIと構造体を定義します。

{ Setup APIs }
type
  { HDEVINFO }
  HDEVINFO = THandle;
  {$EXTERNALSYM HDEVINFO}

  { SP_DEVINFO_DATA }
  SP_DEVINFO_DATA = packed record
    cbSize: DWORD;
    ClassGuid: TGUID;
    DevInst: DWORD;
    Reserved: ULONG_PTR;
  end;
  {$EXTERNALSYM SP_DEVINFO_DATA}

const
  { Flags for SetupDiGetClassDevs }
  DIGCF_PRESENT         = $00000002;
  {$EXTERNALSYM DIGCF_PRESENT}

  { Property for SetupDiGetDeviceRegistryProperty }
  SPDRP_DEVICEDESC      = $00000000;
  {$EXTERNALSYM SPDRP_DEVICEDESC}
  SPDRP_FRIENDLYNAME    = $0000000C;
  {$EXTERNALSYM SPDRP_FRIENDLYNAME}

  { Scope for SetupDiOpenDevRegKey }
  DICS_FLAG_GLOBAL      = $00000001;
  {$EXTERNALSYM DICS_FLAG_GLOBAL}

  { KeyType for SetupDiOpenDevRegKey }
  DIREG_DEV             = $00000001;
  {$EXTERNALSYM DIREG_DEV}

{ SetupDiClassGuidsFromName }
function SetupDiClassGuidsFromName(const ClassName: PChar;
                                   ClassGuidList: PGUID;
                                   ClassGuidListSize: DWORD;
                                   var RequiredSize: DWORD): BOOL; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiClassGuidsFromNameW';
{$ELSE}
  'SetupDiClassGuidsFromNameA';
{$ENDIF}
{$EXTERNALSYM SetupDiClassGuidsFromName}

{ SetupDiGetClassDevs }
function SetupDiGetClassDevs(ClassGuid: PGUID;
                             const Enumerator: PChar;
                             hwndParent: HWND;
                             Flags: DWORD): HDEVINFO; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiGetClassDevsW';
{$ELSE}
  'SetupDiGetClassDevsA';
{$ENDIF}
{$EXTERNALSYM SetupDiGetClassDevs}

{ SetupDiDestroyDeviceInfoList }
function SetupDiDestroyDeviceInfoList(DeviceInfoSet: HDEVINFO): BOOL; stdcall;
  external 'SetupApi.dll' name 'SetupDiDestroyDeviceInfoList';
{$EXTERNALSYM SetupDiDestroyDeviceInfoList}

{ SetupDiEnumDeviceInfo }
function SetupDiEnumDeviceInfo(DeviceInfoSet: HDEVINFO;
                               MemberIndex: DWORD;
                               var DeviceInfoData: SP_DEVINFO_DATA): BOOL; stdcall;
  external 'SetupApi.dll' name 'SetupDiEnumDeviceInfo';
{$EXTERNALSYM SetupDiEnumDeviceInfo}

{ SetupDiGetDeviceRegistryProperty }
function SetupDiGetDeviceRegistryProperty(DeviceInfoSet: HDEVINFO;
                                          const DeviceInfoData: SP_DEVINFO_DATA;
                                          Prop: DWORD;
                                          PropertyRegDataType: PDWORD;
                                          PropertyBuffer: Pointer;
                                          PropertyBufferSize: DWORD;
                                          var RequiredSize: DWORD): BOOL; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiGetDeviceRegistryPropertyW';
{$ELSE}
  'SetupDiGetDeviceRegistryPropertyA';
{$ENDIF}
{$EXTERNALSYM SetupDiGetDeviceRegistryProperty}

{ SetupDiOpenDevRegKey }
function SetupDiOpenDevRegKey(DeviceInfoSet: HDEVINFO;
                              var DeviceInfoData: SP_DEVINFO_DATA;
                              Scope: DWORD;
                              HwProfile: DWORD;
                              KeyType: DWORD;
                              samDesired: REGSAM): HKEY; stdcall;
  external 'SetupApi.dll' name 'SetupDiOpenDevRegKey';
{$EXTERNALSYM SetupDiOpenDevRegKey}

これらを使用してシリアルポートをそのフレンドリ名とともに取得します。

function EnumSerialCommWithFriendlyName(const S: TStrings): Integer;
var
  Guid: TGUID;
  Size: DWORD;
  hDevInf: HDEVINFO;
  Index: DWORD;
  DevInfoData: SP_DEVINFO_DATA;
  S1: String;
  hRegKey: HKEY;
  S2: String;
  RegType: DWORD;
  PortNo: Integer;
begin

  Result := 0;

  Size := 0;
  if SetupDiClassGuidsFromName('Ports',@Guid,1,Size) = False then
  begin
    RaiseLastOSError;
  end;

  hDevInf := SetupDiGetClassDevs(@Guid,nil,0,DIGCF_PRESENT);
  if hDevInf = INVALID_HANDLE_VALUE then
  begin
    RaiseLastOSError;
  end;

  try
    Index := 0;
    while True do
    begin
      FillChar(DevInfoData,SizeOf(DevInfoData),0);
      DevInfoData.cbSize := SizeOf(DevInfoData);
      if SetupDiEnumDeviceInfo(hDevInf,Index,DevInfoData) = False then
      begin
        Break;
      end;

      SetupDiGetDeviceRegistryProperty(hDevInf,DevInfoData,SPDRP_FRIENDLYNAME,
                                       nil,nil,0,Size);
      SetLength(S1,(Size + SizeOf(Char)) div SizeOf(Char));

      if SetupDiGetDeviceRegistryProperty(hDevInf,DevInfoData,SPDRP_FRIENDLYNAME,
                                          nil,PChar(S1),Size,Size) = True then
      begin
        SetLength(S1,StrLen(PChar(S1)));
        hRegKey := SetupDiOpenDevRegKey(hDevInf,DevInfoData,DICS_FLAG_GLOBAL,0,DIREG_DEV,KEY_READ);
        if hRegKey <> INVALID_HANDLE_VALUE then
        begin
          try
            if RegQueryInfoKey(hRegKey,nil,nil,nil,nil,nil,nil,nil,nil,
                               @Size,nil,nil) = ERROR_SUCCESS then
            begin
              SetLength(S2,(Size + SizeOf(Char)) div SizeOf(Char));
              if (RegQueryValueEx(hRegKey,'PortName',nil,@RegType,Pointer(PChar(S2)),
                                  @Size) = ERROR_SUCCESS) and
                 (RegType = REG_SZ) then
              begin
                SetLength(S2,StrLen(PChar(S2)));
                if CompareText(Copy(S2,1,3),'COM') = 0 then
                begin
                  if TryStrToInt(Copy(S2,4,Length(S2)),PortNo) = True then
                  begin
                    S.AddObject(S1,Pointer(PortNo));
                    if Result < PortNo then
                    begin
                      Result := PortNo;
                    end;
                  end;
                end;
              end;
            end;

          finally
            RegCloseKey(hRegKey);
          end;
        end;
      end;

      Index := Index + 1;
    end;

  finally
    SetupDiDestroyDeviceInfoList(hDevInf);
  end;

end;

手順ですが、まずSetupDiClassGuidsFromNameでデバイスインタフェースクラスが'Ports'のGUIDを取得し、そのGUIDを使用してSetupDiGetClassDevsで現在システムに認識されているDevice Information Setsを取得し、SetupDiEnumDeviceInfoでDevice Information Set一つずつの情報をSP_DEVINFO_DATAに取り出して、SetupDiGetDeviceRegistryPropertyでフレンドリ名を取得します。さらにSetupDiOpenDevRegKeyでデバイス固有情報の含まれるレジストリキー('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum'の下のデバイスごとのキーに含まれる'Device Parameters'キー)を開き、RegQueryValueExで'PortName'という名前でREG_SZの値のデータを文字列として取得し、'COM'で始まっていたらシリアルポートとしてフレンドリ名とともにパラメータ(S: TStrings)に格納します。全てのDevice Information Setをチェックし終わったらSetupDiDestroyDeviceInfoListでDevice Information Sets全体を解放します。 以前のものと同様に必ずしもポート番号順にはなっていないため、必要に応じて結果をソートしてください。

→シリアルポートをフレンドリ名で列挙 (Gist)

DDevExtensions 2.82/IDE Fix Pack 5.7

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.82になっています。クラス補完関係の機能追加とXE6上での不具合修正が含まれています。またIDE Fix PackもアップデートされてVersion 5.7になっています。こちらはいくつかのfixが追加されています。

DDevExtensions 2.82 and IDE Fix Pack 5.7 released | Andy's Blog and Tools

IDE Fix Pack 5.5

Andreas HausladenさんのIDE Fix Pack 2009-XE5がアップデートされてVersion 5.5になっています。なおDelphi 2010/XE2/XE3/XE4についてはこのバージョンで更新終了とのことです。

IDE Fix Pack 5.5 (2009-XE5) released | Andy's Blog and Tools

DDevExtensions 2.81

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.81になっています。RAD Studio XE6対応とバグフィックスです。

DDevExtensions, DFMCheck and ByteStrings for XE6 | Andy's Blog and Tools

IDE Fix Pack 5.4.1

Andreas HausladenさんのIDE Fix Pack 2009-XE5がアップデートされてVersion 5.4.1になっています。RAD Studio XE5 Update 2でのコンパイラの変更に対応しているとのことです。

IDE Fix Pack 5.4.1 – Support for XE5 Updater 2 | Andy's Blog and Tools