この発言は
#01393　HATENA          さんのレコード型を動的配列で管理するクラス
に対するコメントです




implementation

const
  SListIndexError = 'リストのインデックスが範囲を超えています (%d)';
  SListCapacityError = 'リストの容量が超えました (%d)';
  SListCountError = 'リストの個数を超えました (%d)';
  SSortedListError = 'ソートされるリストに対しては許されない動作です';
  GrowSize = 16; //配列の拡張単位、事例により適切なサイズを指定する

{ TRecList }

destructor TRecList.Destroy;
begin
  Clear;
end;

function TRecList.Add(Item: TMyRec): Integer;
begin
  if not Sorted then Result := FCount
    else Find(Item, Result);
  InsertItem(Result, Item);
end;

procedure TRecList.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;

procedure TRecList.Delete(Index, ACount: Integer);
begin
  if (Index<0)or(Index>=FCount) then TList.Error(SListIndexError, Index);
  Dec(FCount);
  if Index < FCount then
    System.Move(FRecArray[Index + ACount], FRecArray[Index],
      (FCount - Index - ACount) * SizeOf(TMyRec));
end;

procedure TRecList.Exchange(Index1, Index2: Integer);
var
  Item: TMyRec;
begin
  if (Index1<0)or(Index1>=FCount) then TList.Error(SListIndexError, Index1);
  if (Index2<0)or(Index2>=FCount) then TList.Error(SListIndexError, Index2);
  Item := FRecArray[Index1];
  FRecArray[Index1] := FRecArray[Index2];
  FRecArray[Index2] := Item;
end;

function TRecList.Expand: TRecList;
begin
  if FCount = FCapacity then Grow;
  Result := Self;
end;

function TRecList.Find(const AMyRec: TMyRec; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0; H := FCount - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := FCompare(FRecArray[I], AMyRec);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        L := I;
      end;
    end;
  end;
  Index := L;
end;

function TRecList.Get(Index: Integer): TMyRec;
begin
  if (Index<0)or(Index>=FCount) then TList.Error(SListIndexError, Index);
  Result := FRecArray[Index];
end;

procedure TRecList.Grow;
begin
  SetCapacity(FCapacity + GrowSize);
end;

procedure TRecList.Insert(Index: Integer; const Item: TMyRec);
begin
  if Sorted then TList.Error(SSortedListError, 0);
  if (Index<0)or(Index>FCount) then TList.Error(SListIndexError, Index);
  InsertItem(Index, Item);
end;

procedure TRecList.InsertItem(Index: Integer; const Item: TMyRec);
begin
  if FCount = FCapacity then Grow;
  if Index < FCount then
    System.Move(FRecArray[Index], FRecArray[Index + 1],
      (FCount - Index) * SizeOf(TMyRec));
  FRecArray[Index] := Item;
  Inc(FCount);
end;

procedure TRecList.LoadFromFile(const FileName: string);
var
  FFile:TFileStream;
  Len: integer;
begin
//  if FileExists(FileName) then TList.Error(FileName +' が見つかりません', 
0);
  FFile := TFileStream.Create(FileName, fmOpenRead);
  try
    Len := FFile.Size div SizeOf(TMyRec);
    SetCount(Len);
    FFile.Read(FRecArray[0], SizeOf(TMyRec) * Len);
    if FSorted then Sort(FCompare);
  finally
    FFile.Free;
  end;
end;

procedure TRecList.Move(CurIndex, NewIndex: Integer);
var
  Item: TMyRec;
begin
  if CurIndex <> NewIndex then
  begin
    if Sorted then TList.Error(SSortedListError, 0);
    if (NewIndex < 0) or (NewIndex >= FCount) then
      TList.Error(SListIndexError, NewIndex);
    Item := Get(CurIndex);
    Delete(CurIndex, 1);
    InsertItem(NewIndex, Item);
  end;
end;

procedure TRecList.Put(Index: Integer; Item: TMyRec);
begin
  if Sorted then TList.Error(SSortedListError, 0);
  if (Index<0)or(Index>=FCount) then TList.Error(SListIndexError, Index);
  FRecArray[Index] := Item;
end;

procedure TRecList.SaveToFile(const FileName: string);
var
  FFile:TFileStream;
  Len: integer;
begin
  FFile := TFileStream.Create(FileName, fmCreate);
  try
    Len := SizeOf(TMyRec) * FCount;
    FFile.Write(FRecArray[0], Len);
  finally
    FFile.Free;
  end;
end;

procedure TRecList.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
    TList.Error(SListCapacityError, NewCapacity);
  if NewCapacity <> FCapacity then
  begin
    SetLength(FRecArray, NewCapacity);
    FCapacity := NewCapacity;
  end;
end;

procedure TRecList.SetCount(NewCount: Integer);
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    TList.Error(SListCountError, NewCount);
  if NewCount > FCapacity then SetCapacity(NewCount);
  FCount := NewCount;
end;

procedure TRecList.SetSorted(Value: Boolean);
begin
  if Value <> FSorted then
  begin
    FSorted := Value;
    if FSorted then Sort(FCompare);
  end;
end;

procedure TRecList.SetSortCompare(ACompare: TArraySortCompare);
begin
  if (@FCompare <> @ACompare) then
  begin
    FCompare := ACompare;
    if FSorted then Sort(FCompare);
  end;
end;

procedure QuickSort(SorTArray: TMyRecArray; L, R: Integer;
  SCompare: TArraySortCompare);
var
  I, J: Integer;
  P, T: TMyRec;
begin
  repeat
    I := L;
    J := R;
    P := SorTArray[(L + R) shr 1];
    repeat
      while SCompare(SorTArray[I], P) < 0 do Inc(I);
      while SCompare(SorTArray[J], P) > 0 do Dec(J);
      if I <= J then
      begin
        T := SorTArray[I];
        SorTArray[I] := SorTArray[J];
        SorTArray[J] := T;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then QuickSort(SorTArray, L, J, SCompare);
    L := I;
  until I >= R;
end;

procedure TRecList.Sort(Compare: TArraySortCompare);
begin
  if Assigned(Compare) and (FRecArray <> nil) and (Count > 0) then
    QuickSort(FRecArray, 0, Count - 1, Compare);
end;

end.

                                     01/10/09(火) 12:35 HATENA(GFC03235)
 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 01/10/14 -

Original document by HATENA          氏 ID:(GFC03235)

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