Delphi控件源码

开发平台：
Delphi

MMMrkLst.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49 (0)351-8037944              =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 01.07.98 - 16:42:02 $                                        =}
{========================================================================}
unit MMMrkLst;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinProcs,
  WinTypes,
{$ENDIF}
  SysUtils,
  Classes,
  MMObj,
  MMMuldiv,
  MMUtils;
type
  PMMMarker = ^TMMMarker;
  TMMMarker = packed record
    ID     : Longint;
    NextID : Longint;
    Offset : Longint;
    Name   : string[80];
    Comment: string[255];
    Fixed  : Boolean;
    Visible: Boolean;
    Color  : Longint;
    User   : Longint;
    Flags  : Longint;
  end;
const
  { Maximum List size }
  {$IFDEF WIN32}
  MaxMrkListSize = Maxint div (sizeOf(TMMMarker));
  {$ELSE}
  MaxMrkListSize = 65520 div sizeOf(TMMMarker);
  {$ENDIF}
type
  PMMMarkerArray = ^TMMMarkerArray;
  TMMMarkerArray = array[0..MaxMrkListSize-1] of TMMMarker;
  TMMMarkerList = class(TMMObject)
  private
    FList       : PMMMarkerArray;
    FCount      : Integer;
    FCapacity   : Integer;
  protected
    procedure Error; virtual;
    procedure Grow; virtual;
    function  Add(Marker: TMMMarker): Integer;
    function  Get(Index: Integer): PMMMarker;
    procedure Put(Index: Integer; Marker: PMMMarker);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    constructor Create; virtual;
    destructor  Destroy; override;
    procedure  Clear; virtual;
    procedure  Assign(Source: TPersistent); override;
    procedure  AddMarker(Marker: TMMMarker);
    procedure  Insert(Index: Integer; Marker: TMMMarker);
    procedure  Exchange(Index1, Index2: Integer);
    procedure  Move(CurIndex, NewIndex: Integer);
    function   Remove(Marker: PMMMarker): Integer;
    procedure  Delete(Index: Integer);
    function   IndexOf(Marker: PMMMarker): Integer;
    function   FindFreeID: Longint;
    function   LocateMarker(Offset: Longint): integer;
    function   FindMarker(Offset: Longint): integer;
    function   FindConnectedMarker(Index: integer): integer;
    function   QueryMarker(Offset: Longint): Boolean;
    procedure  Sort;
    function   First: PMMMarker;
    function   Last: PMMMarker;
    function   Expand: TMMMarkerList;
    procedure  SetOffset(Index: integer; Offset: Longint);
    procedure  SetColor(Index: integer; Color: Longint);
    property   OnChange;
    property   OnChanging;
    property   Capacity: Integer read FCapacity write SetCapacity;
    property   Count: Integer read FCount write SetCount;
    property   Markers[Index: Integer]: PMMMarker read Get write Put; default;
    property   List: PMMMarkerArray read FList;
  end;
function  CompareMarkers(Marker1,Marker2: PMMMarker): Boolean;
implementation
uses
    Consts
    {$IFDEF DELPHI6}
    ,RTLConsts
    {$ENDIF}
    ;
{------------------------------------------------------------------------}
function CompareMarkers(Marker1,Marker2: PMMMarker): Boolean;
begin
   Result := (Marker1^.Offset = Marker2^.Offset);
end;
{------------------------------------------------------------------------}
{$IFDEF DELPHI3}
procedure ListError(const Ident: string);
begin
   raise EListError.Create(Ident);
end;
{$ELSE}
procedure ListError(Ident: Word);
begin
   raise EListError.CreateRes(Ident);
end;
{$ENDIF}
{------------------------------------------------------------------------}
procedure ListIndexError;
begin
   ListError(SListIndexError);
end;
{== TMMMarkerList ========================================================}
constructor TMMMarkerList.Create;
begin
   inherited Create;
   FList := nil;
end;
{-- TMMMarkerList --------------------------------------------------------}
destructor TMMMarkerList.Destroy;
begin
   OnChange   := nil;
   OnChanging := nil;
   Clear;
   inherited Destroy;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Error;
begin
   ListIndexError;
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.Add(Marker: TMMMarker): Integer;
begin
   Changing;
   Result := FCount;
   if Result = FCapacity then Grow;
   FList^[Result] := Marker;
   Inc(FCount);
   Changed;
end;
{-- TMMMarkerList --------------------------------------------------------}
{ AddMarker f黦t einen Punkt in die Liste ein }
procedure TMMMarkerList.AddMarker(Marker: TMMMarker);
var
  i: integer;
begin
   i := LocateMarker(Marker.Offset);
   if (i < 0) or (i >= Count) then
      Add(Marker)
   else
      Insert(i, Marker);
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Clear;
begin
   Changing;
   SetCount(0);
   SetCapacity(0);
   Changed;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Delete(Index: Integer);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Changing;
   Dec(FCount);
   if Index < FCount then
     System.Move(FList^[Index + 1], FList^[Index],
                 (FCount - Index) * SizeOf(TMMMarker));
   Changed;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Exchange(Index1, Index2: Integer);
var
  Marker: TMMMarker;
begin
   if (Index1 < 0) or (Index1 >= FCount) then Error;
   if (Index2 < 0) or (Index2 >= FCount) then Error;
   Changing;
   Marker := FList^[Index1];
   FList^[Index1] := FList^[Index2];
   FList^[Index2] := Marker;
   Changed;
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.Expand: TMMMarkerList;
begin
   if FCount = FCapacity then Grow;
   Result := Self;
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.First: PMMMarker;
begin
   Result := Get(0);
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.Get(Index: Integer): PMMMarker;
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Result := @FList^[Index];
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Grow;
var
  Delta: Integer;
begin
   if FCapacity > 8 then
      Delta := 16
   else if FCapacity > 4 then
      Delta := 8
   else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.IndexOf(Marker: PMMMarker): Integer;
begin
   Result := 0;
   while (Result < FCount) and not CompareMarkers(@FList^[Result],Marker) do Inc(Result);
   if Result = FCount then Result := -1;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Insert(Index: Integer; Marker: TMMMarker);
begin
   if (Index < 0) or (Index > FCount) then Error;
   Changing;
   if FCount = FCapacity then Grow;
   if Index < FCount then
      System.Move(FList^[Index], FList^[Index + 1],
                 (FCount - Index) * SizeOf(TMMMarker));
   FList^[Index] := Marker;
   Inc(FCount);
   Changed;
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.Last: PMMMarker;
begin
   Result := Get(FCount-1);
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Move(CurIndex, NewIndex: Integer);
var
  Marker: TMMMarker;
begin
   if CurIndex <> NewIndex then
   begin
      if (NewIndex < 0) or (NewIndex >= FCount) then Error;
      Marker := Get(CurIndex)^;
      Delete(CurIndex);
      Insert(NewIndex, Marker);
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Put(Index: Integer; Marker: PMMMarker);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Changing;
   FList^[Index] := Marker^;
   Changed;
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.Remove(Marker: PMMMarker): Integer;
begin
   Result := IndexOf(Marker);
   if Result <> -1 then Delete(Result);
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.SetCapacity(NewCapacity: Integer);
begin
   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error;
   if NewCapacity <> FCapacity then
   begin
     {$IFDEF WIN32}
     ReallocMem(FList, NewCapacity * SizeOf(TMMMarker));
     {$ELSE}
     if NewCapacity = 0 then
     begin
        GlobalFreeMem(FList);
        FList := nil;
     end
     else
     begin
        if FCapacity = 0 then
           FList := GlobalAllocPtr(HeapAllocFlags, NewCapacity*sizeOf(TMMMarker))
        else
           FList := GlobalReallocPtr(FList, NewCapacity*sizeOf(TMMMarker), HeapAllocFlags);
        if FList = nil then
           raise EStreamError.Create(LoadStr(SMemoryStreamError));
     end;
     {$ENDIF}
     FCapacity := NewCapacity;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.SetCount(NewCount: Integer);
begin
   if (NewCount < 0) or (NewCount > MaxListSize) then Error;
   if NewCount > FCapacity then SetCapacity(NewCount);
   if NewCount > FCount then
      FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(TMMMarker), 0);
   FCount := NewCount;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.SetOffset(Index: integer; Offset: Longint);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   BeginUpdate;
   try
      Markers[Index]^.Offset := Offset;
      Sort;
   finally
      EndUpdate;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.SetColor(Index: integer; Color: Longint);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   if (Color <> Markers[Index]^.Color) then
   begin
      Changing;
      Markers[Index]^.Color := Color;
      Changed;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Assign(Source: TPersistent);
var
   i: integer;
   p: TMMMarker;
begin
   if (Source is TMMMarkerList) or (Source = nil) then
   begin
      if (Source <> Self) then
      begin
         BeginUpdate;
         try
            Clear;
            if (Source <> nil) then
            begin
               for i := 0 to TMMMarkerList(Source).Count-1 do
               begin
                  p := TMMMarkerList(Source).Markers[i]^;
                  Add(p);
               end;
               Sort;
            end;
         finally
            EndUpdate;
         end;
      end;
   end
   else inherited assign(Source);
end;
{-- TMMMarkerList --------------------------------------------------------}
function TMMMarkerList.FindFreeID: Longint;
Label Again;
var
   i: integer;
begin
   Randomize;
Again:
   {$IFDEF WIN32}
   Result := Random(MaxLongint);
   {$ELSE}
   Result := Random(65535);
   {$ENDIF}
   for i := 0 to Count-1 do
   begin
      if (Result <= 0) or (Markers[i]^.ID = Result) then
         goto Again;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
{ LocatePoint gibt den Index des ersten Markers, der rechts von Offset liegt,
  zurueck. Ist die Liste leer: -1 , gibt es kein rechtes Element mehr: Count(!) }
function TMMMarkerList.LocateMarker(Offset: Longint): integer;
var
   L, H : integer;
begin
   if (Count = 0) then
   begin
      Result := -1;
   end
   else
   begin
      if Markers[Count-1]^.Offset <= Offset then
      begin
         Result := Count;
      end
      else
      begin
         L := 0;
         H := Count-1;
         Result := H shr 1;
         while L < H do
         begin
            if (Markers[Result]^.Offset <= Offset) then
               L := Result+1
            else
               H := Result;
            Result := (L + H) shr 1;
         end;
      end;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
{ QueryPoint returns true if a new marker is allowed at "Offset"          }
function TMMMarkerList.QueryMarker(Offset: Longint): Boolean;
begin
   Result := Findmarker(Offset) = -1;
end;
{-- TMMMarkerList --------------------------------------------------------}
{ FindMarker gibt genau den Index des Markers zurueck, oder -1 }
function TMMMarkerList.FindMarker(Offset: Longint): integer;
var
  i : integer;
begin
   Result := -1;
   i := LocateMarker(Offset);
   if (i > 0) and (i <= Count) then
   begin
      if Offset = Markers[i-1]^.Offset then
      begin
         Result := i-1;
      end;
   end
   else if (i = 0) and (Count > 0) then
   begin
      if Offset = Markers[i]^.Offset then
      begin
         Result := i;
      end;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
{ FindConnectedMarker gibt den Index eines zugeh鰎igen  Markers zurueck }
function TMMMarkerList.FindConnectedMarker(index: integer): integer;
var
  i : integer;
begin
   Result := -1;
   if (Index < 0) or (Index >= FCount) then Error;
   
   if (Markers[Index]^.NextID > 0) then
   begin
      for i := 0 to Count-1 do
      begin
         if (Markers[i]^.ID = Markers[Index]^.NextID) then
         begin
            Result := i;
            exit;
         end;
      end;
   end;
end;
{-- TMMMarkerList --------------------------------------------------------}
procedure TMMMarkerList.Sort;
var
   i,j,h: integer;
   m: TMMMarker;
begin          { Start Shell-Sort }
   h := 1;
   while h <= Count div 9 do h := h*3 + 1;
   while h > 0 do
   begin
      for i := h to Count-1 do
      begin
         m := Markers[i]^;
         j := i;
         while (j >= h) and (Markers[j-h]^.Offset > m.Offset) do
         begin
            Markers[j]^ := Markers[j-h]^;
            dec(j, h);
         end;
         Markers[j]^ := m;
      end;
      h := h div 3;
   end;
end;
end.

						