uses
  Consts, Classes; // 追加する
const
  MaxListSize = Maxint div 16;
type

{ TD2Words class }

  PD2WordItem = ^TD2WordItem;
  TD2WordItem = record      // ２次元 word レコード
    x: word;
    y: word;
  end;

  TD2Words = class(TPersistent)
  private
    FUpdateCount: Integer;
  protected
    procedure Error(const Msg: string; Data: Integer);
    function Get(Index: Integer): TD2WordItem; virtual; abstract;
    function GetCapacity: Integer; virtual;
    function GetCount: Integer; virtual; abstract;
    procedure Put(Index: Integer; const Rec: TD2WordItem); virtual;
    procedure SetCapacity(NewCapacity: Integer); virtual;
    procedure SetUpdateState(Updating: Boolean); virtual;
  public
    destructor Destroy; override;
    function Add(const X, Y: word): Integer; virtual;
    procedure Append(const X, Y: word);
    procedure AddD2Words(DWords: TD2Words); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure Clear; virtual; abstract;
    procedure Delete(Index: Integer); virtual; abstract;
    procedure EndUpdate;
    procedure Insert(Index: Integer; const X, Y: word); virtual; abstract;
    property Capacity: Integer read GetCapacity write SetCapacity;
    property Count: Integer read GetCount;
    property Data[Index: Integer]: TD2WordItem read Get write Put; default;
  end;

{ TD2WordList class }

  TDuplicates = (dupIgnore, dupAccept, dupError);

  PD2WordItemList = ^TD2WordItemList;
  TD2WordItemList = array[0..MaxListSize] of TD2WordItem;

  TD2WordList = class(TD2Words)
  private
    FList: PD2WordItemList;
    FCount: Integer;
    FCapacity: Integer;
    FDuplicates: TDuplicates;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure Grow;
    procedure InsertItem(Index: Integer; const xVal, yVal: word);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    function Get(Index: Integer): TD2WordItem; override;
    function GetCapacity: Integer; override;
    function GetCount: Integer; override;
    procedure Put(Index: Integer; const Rec: TD2WordItem); override;
    procedure SetCapacity(NewCapacity: Integer); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    destructor Destroy; override;
    function Add(const X, Y: word): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const X, Y: word); override;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  end;


{ TD2WordList }

function TD2WordList.Add(const X, Y: word): Integer;
begin
  Result := FCount;
  InsertItem(Result, x, y);
end;

procedure TD2WordList.Changed;
begin
  if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
end;

procedure TD2WordList.Changing;
begin
  if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
end;

procedure TD2WordList.Clear;
begin
  if FCount <> 0 then begin
    Changing;
    Finalize(FList^[0], FCount);
    FCount := 0;
    SetCapacity(0);
    Changed;
  end;
end;

procedure TD2WordList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  Changing;
  Finalize(FList^[Index]);
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(TD2WordItem));
  Changed;
end;

destructor TD2WordList.Destroy;
begin
  FOnChange := nil;
  FOnChanging := nil;
  inherited Destroy;
  if FCount <> 0 then Finalize(FList^[0], FCount);
  FCount := 0;
  SetCapacity(0);
end;

function TD2WordList.Get(Index: Integer): TD2WordItem;
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  Result.X := FList^[Index].X;
  Result.Y := FList^[Index].Y;
end;

function TD2WordList.GetCapacity: Integer;
begin
  Result := FCapacity;
end;

function TD2WordList.GetCount: Integer;
begin
  Result := FCount;
end;

procedure TD2WordList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then Delta := FCapacity div 4 else
    if FCapacity > 8 then Delta := 16 else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

procedure TD2WordList.Insert(Index: Integer; const X, Y: word);
begin
  if (Index < 0) or (Index > FCount) then Error(SListIndexError, Index);
  InsertItem(Index, x, y);
end;

procedure TD2WordList.InsertItem(Index: Integer; const xVal, yVal: word);
begin
  Changing;
  if FCount = FCapacity then Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(TD2WordItem));
  with FList^[Index] do begin
    X := xVal;
    Y := yVal;
  end;
  Inc(FCount);
  Changed;
end;

procedure TD2WordList.Put(Index: Integer; const Rec: TD2WordItem);
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  Changing;
  FList^[Index].x := Rec.x;
  FList^[Index].y := Rec.y;
  Changed;
end;

procedure TD2WordList.SetCapacity(NewCapacity: Integer);
begin
  ReallocMem(FList, NewCapacity * SizeOf(TD2WordItem));
  FCapacity := NewCapacity;
end;

procedure TD2WordList.SetUpdateState(Updating: Boolean);
begin
  if Updating then Changing else Changed;
end;

{ TD2Words }

function TD2Words.Add(const X, Y: word): Integer;
begin
  Result := GetCount;
  Insert(Result, x, y);
end;

procedure TD2Words.AddD2Words(DWords: TD2Words);
var
  I: Integer;
begin
  BeginUpdate;
  try
    for I := 0 to DWords.Count - 1 do
      Add(DWords[I].x, DWords[I].y);
  finally
    EndUpdate;
  end;
end;

procedure TD2Words.Append(const X, Y: word);
begin
  Add(x, y);
end;

procedure TD2Words.Assign(Source: TPersistent);
begin
  if Source is TD2Words then
  begin
    BeginUpdate;
    try
      Clear;
      AddD2Words(TD2Words(Source));
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TD2Words.BeginUpdate;
begin
  if FUpdateCount = 0 then SetUpdateState(True);
  Inc(FUpdateCount);
end;

destructor TD2Words.Destroy;
begin
  inherited Destroy;
end;

procedure TD2Words.EndUpdate;
begin
  Dec(FUpdateCount);
  if FUpdateCount = 0 then SetUpdateState(False);
end;

procedure TD2Words.Error(const Msg: string; Data: Integer);
  function ReturnAddr: Pointer;
  asm
          MOV     EAX,[EBP+4]
  end;
begin
  raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;
end;

function TD2Words.GetCapacity: Integer;
begin
  Result := Count;
end;

procedure TD2Words.Put(Index: Integer; const Rec: TD2WordItem);
begin
  Delete(Index);
  Insert(Index, Rec.x, Rec.y);
end;

procedure TD2Words.SetCapacity(NewCapacity: Integer);
begin
  // do nothing - descendants may optionally implement this method
end;

procedure TD2Words.SetUpdateState(Updating: Boolean);
begin
end;

00/02/23(水) 11:37 妙義のかたつむり(QWK05270) __@ﾉ'

Original document by 妙義のかたつむり氏 ID:(QWK05270)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。