mmptlist.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  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: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMPtList;

{$I COMPILER.INC}

interface

uses          
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinProcs,
  WinTypes,
{$ENDIF}
  SysUtils,
  Classes,
  MMObj,
  MMMuldiv,
  MMUtils;


type
  PMMPoint = ^TMMPoint;
  TMMPoint = record
    X: Longint;
    Y: Longint;
  end;

const
  { Maximum List size }
  MaxListSize   = Maxint div (sizeOf(TMMPoint)*sizeOf(TMMPoint));

type
  PMMPointArray = ^TMMPointArray;
  TMMPointArray = array[0..MaxListSize-1] of TMMPoint;

  TMMPointList = class(TMMObject)
  private
    FList     : PMMPointArray;
    FCount    : Integer;
    FCapacity : Integer;

  protected
    procedure Error; virtual;
    procedure Grow; virtual;
    function  Get(Index: Integer): PMMPoint;
    procedure Put(Index: Integer; Point: PMMPoint);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure  Clear; virtual;
    procedure  Assign(Source: TPersistent);

    function   Add(Point: TMMPoint): Integer;
    procedure  Insert(Index: Integer; Point: TMMPoint);
    procedure  Exchange(Index1, Index2: Integer);
    procedure  Move(CurIndex, NewIndex: Integer);
    function   Remove(Point: PMMPoint): Integer;
    procedure  Delete(Index: Integer);
    function   IndexOf(Point: PMMPoint): Integer;

    function   LocatePointX(X: Longint): integer;
    function   LocatePointY(Y: Longint): integer;
    function   CalcX(Y: Longint): Longint;
    function   CalcY(X: Longint): Longint;

    procedure  SortByX;
    procedure  SortByY;

    function   First: PMMPoint;
    function   Last: PMMPoint;
    function   Expand: TMMPointList;
    property   Capacity: Integer read FCapacity write SetCapacity;
    property   Count: Integer read FCount write SetCount;
    property   Points[Index: Integer]: PMMPoint read Get write Put; default;
    property   List: PMMPointArray read FList;
  end;

function  ComparePoints(Point1,Point2: PMMPoint): Boolean;
function  LocateX(Points: PMMPointArray; NumPoints: integer; X: Longint): integer;
function  LocateY(Points: PMMPointArray; NumPoints: integer; Y: Longint): integer;
procedure SortX(Points: PMMPointArray; NumPoints: integer);
procedure SortY(Points: PMMPointArray; NumPoints: integer);

implementation

uses consts;

{------------------------------------------------------------------------}
procedure ListError(Ident: Integer);
begin
   raise EListError.CreateRes(Ident);
end;

{------------------------------------------------------------------------}
procedure ListIndexError;
begin
   ListError(SListIndexError);
end;

{------------------------------------------------------------------------}
function ComparePoints(Point1,Point2: PMMPoint): Boolean;
begin
   Result := (Point1^.X = Point2^.X) and (Point1^.Y = Point2^.Y);
end;

{------------------------------------------------------------------------}
function LocateX(Points: PMMPointArray; NumPoints: integer; X: Longint): integer;
var

   L, H : integer;

begin
   if (NumPoints = 0) then
   begin
      Result := -1;
   end
   else
   begin
      if Points^[NumPoints-1].X <= X then
      begin
         Result := NumPoints;
      end
      else
      begin
         L := 0;
         H := NumPoints-1;
         Result := H shr 1;
         while L < H do
         begin
            if Points^[Result].X <= X then
               L := Result+1
            else
               H := Result;
            Result := (L + H) shr 1;
         end;
      end;
   end;
end;

{------------------------------------------------------------------------}
function LocateY(Points: PMMPointArray; NumPoints: integer; Y: Longint): integer;
var

   L, H : integer;

begin
   if (NumPoints = 0) then
   begin
      Result := -1;
   end
   else
   begin
      if Points^[NumPoints-1].Y <= Y then
      begin
         Result := NumPoints;
      end
      else
      begin
         L := 0;
         H := NumPoints-1;
         Result := H shr 1;
         while L < H do
         begin
            if Points^[Result].Y <= Y then
               L := Result+1
            else
               H := Result;
            Result := (L + H) shr 1;
         end;
      end;
   end;
end;

{------------------------------------------------------------------------}
procedure SortX(Points: PMMPointArray; NumPoints: integer);
var
   i,j,h: integer;
   p: TMMPoint;

begin          // Start Shell-Sort
   h := 1;
   while h <= NumPoints div 9 do h := h*3 + 1;
   while h > 0 do
   begin
      for i := h to NumPoints-1 do
      begin
         p := Points^[i];
         j := i;
         while ( j >= h ) and (Points^[j-h].X > p.X) do
         begin
            Points^[j] := Points^[j-h];
            dec(j, h);
         end;
         Points^[j] := p;
      end;
      h := h div 3;
   end;
end;

{------------------------------------------------------------------------}
procedure SortY(Points: PMMPointArray; NumPoints: integer);
var
   i,j,h: integer;
   p: TMMPoint;

begin          // Start Shell-Sort
   h := 1;
   while h <= NumPoints div 9 do h := h*3 + 1;
   while h > 0 do
   begin
      for i := h to NumPoints-1 do
      begin
         p := Points^[i];
         j := i;
         while ( j >= h ) and (Points^[j-h].Y > p.Y) do
         begin
            Points^[j] := Points^[j-h];
            dec(j, h);
         end;
         Points^[j] := p;
      end;
      h := h div 3;
   end;
end;

{== TMMPointList ========================================================}
constructor TMMPointList.Create;
begin
   inherited Create;

end;

{-- TMMPointList --------------------------------------------------------}
destructor TMMPointList.Destroy;
begin
   Clear;

   inherited Destroy;
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Error;
begin
   ListIndexError;
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.Add(Point: TMMPoint): Integer;
begin
   Result := FCount;
   if Result = FCapacity then Grow;
   FList^[Result] := Point;
   Inc(FCount);
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Clear;
begin
   SetCount(0);
   SetCapacity(0);
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Delete(Index: Integer);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Dec(FCount);
   if Index < FCount then
     System.Move(FList^[Index + 1], FList^[Index],
                 (FCount - Index) * SizeOf(TMMPoint));
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Exchange(Index1, Index2: Integer);
var
  Point: TMMPoint;
begin
   if (Index1 < 0) or (Index1 >= FCount) or
      (Index2 < 0) or (Index2 >= FCount) then Error;
   Point := FList^[Index1];
   FList^[Index1] := FList^[Index2];
   FList^[Index2] := Point;
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.Expand: TMMPointList;
begin
   if FCount = FCapacity then Grow;
   Result := Self;
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.First: PMMPoint;
begin
   Result := Get(0);
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.Get(Index: Integer): PMMPoint;
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Result := @FList^[Index];
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.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;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.IndexOf(Point: PMMPoint): Integer;
begin
   Result := 0;
   while (Result < FCount) and not ComparePoints(@FList^[Result],Point) do Inc(Result);
   if Result = FCount then Result := -1;
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Insert(Index: Integer; Point: TMMPoint);
begin
   if (Index < 0) or (Index > FCount) then Error;
   if FCount = FCapacity then Grow;
   if Index < FCount then
      System.Move(FList^[Index], FList^[Index + 1],
                 (FCount - Index) * SizeOf(TMMPoint));
   FList^[Index] := Point;
   Inc(FCount);
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.Last: PMMPoint;
begin
   Result := Get(FCount-1);
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Move(CurIndex, NewIndex: Integer);
var
  Point: TMMPoint;
begin
   if CurIndex <> NewIndex then
   begin
      if (NewIndex < 0) or (NewIndex >= FCount) then Error;
      Point := Get(CurIndex)^;
      Delete(CurIndex);
      Insert(NewIndex, Point);
   end;
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Put(Index: Integer; Point: PMMPoint);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   FList^[Index] := Point^;
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.Remove(Point: PMMPoint): Integer;
begin
   Result := IndexOf(Point);
   if Result <> -1 then Delete(Result);
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.SetCapacity(NewCapacity: Integer);
begin
   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error;
   if NewCapacity <> FCapacity then
   begin
     ReallocMem(FList, NewCapacity * SizeOf(TMMPoint));
     FCapacity := NewCapacity;
   end;
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.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(TMMPoint), 0);
   FCount := NewCount;
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.Assign(Source: TPersistent);
var
   i: integer;
   p: TMMPoint;

begin
   if (Source is TMMPointList) or (Source = nil) then
   begin
      Clear;
      if (Source <> nil) then
      begin
         for i := 0 to TMMPointList(Source).Count-1 do
         begin
            p := TMMPointList(Source).Points[i]^;
            Add(p);
         end;
         SortByX;
      end;
   end
   else inherited assign(Source);
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.CalcX(Y: Longint): Longint;
var
   i: integer;
begin
   // TODO : exception
   { liste must be sorted }
   i := LocatePointY(Y);
   if (i > 0) then
   begin
      i := Min(i,Count-1);
      Result := RangeScale(Y,Points[i-1].Y,Points[i].Y,Points[i-1].X,Points[i].X);
   end
   else Result := 0;
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.CalcY(X: Longint): Longint;
var
   i: integer;
begin
   // TODO : exception
   { liste must be sorted }
   i := LocatePointX(X);
   if (i > 0) then
   begin
      i := Min(i,Count-1);
      Result := RangeScale(X,Points[i-1].X,Points[i].X,Points[i-1].Y,Points[i].Y);
   end
   else Result := 0;
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.LocatePointX(X: Longint): integer;
{ LocatePoint returns the Index of the first point, which lies right   }
{ from X. Is the list empty -1, is there no other element Count(!)     }
begin
   // TODO : exception
   { liste must be sorted }
   Result := LocateX(List,Count,X);
end;

{-- TMMPointList --------------------------------------------------------}
function TMMPointList.LocatePointY(Y: Longint): integer;
{ LocatePoint returns the Index of the first point, which lies above   }
{ from Y. Is the list empty -1, is there no other element Count(!)     }
begin
   Result := LocateY(List,Count,Y);
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.SortByX;
begin
   SortX(List,Count);
end;

{-- TMMPointList --------------------------------------------------------}
procedure TMMPointList.SortByY;
begin
   SortY(List,Count);
end;

end.