ezrtree.pas

很管用的GIS控件

Unit EzRtree;

{***********************************************************}
{     EzGIS/CAD Components                                  }
{   (c) 2003 EzSoft Engineering                             }
{         All Rights Reserved                               }
{***********************************************************}

{$I EZ_FLAG.PAS}
Interface

Uses
  Classes, SysUtils, EzLib;

Const
  RTCEXT = '.RTC';
  RTXEXT = '.RTX';

  // Internal message codes
  TREE_VERSION = 1001;
  TREE_ERROR = -1;
  OK = 0;
  ROOT_CHANGED = 1;

  // Configuration parameters
  BUCKETSIZE = 50; // before can be as much as 140, must be set to 100
  LOWERBOUND = 20;
  NOTFOUND = -1;
  HALF_BUCKET = BUCKETSIZE Div 2;

  DSIZE = BUCKETSIZE + 2 - 2 * LOWERBOUND; // Size of the distribution table
  XAXIS = 0;
  YAXIS = 1;
  MININT = Low( Integer );
  DEG_MULTIPLIER = 1000000;

Type
  // Rectangle class declaration
  TRect_rt = Record
    x1, y1, x2, y2: integer; // corner coordinates
  End;

  PIntegerArray = ^TIntegerArray;
  TIntegerArray = Array[0..1000000] Of Integer;

  // Sort List class declaration
  TSortList = Class( TObject )
  Private
    dist: PIntegerArray; // Value array to be sorted
    indx: PIntegerArray; // Initial indices of the sorted values
    size, len: integer; // Size of the list, and # of values inserted

  Public

    Constructor Create( l: integer );
    Destructor Destroy; Override;

    Procedure Insert( d, i: integer );
    Procedure Sort;
    Function valAt( p: integer ): integer;
    Function Length: integer;
  End;

  // Structure of an object list element
  POLstElem = ^TOLstElem;
  TOLstElem = Record
    obj: Longint; // disk address of the spatial object
    r: TRect_rt; // MBR of the object
    lev: integer; // level of the object in the tree
    Next: POLstElem; // Next element in the list
  End;

  // Object list class declaration
  TOList = Class
  Private
    Head, Tail, Curr: POLstElem;
  Public
    Constructor Create;
    Destructor Destroy; Override;
    Function isEmpty: boolean;
    Function Insert( o: Longint; Const r: TRect_rt ): integer;
    Function Insertl( o: Longint; Const r: TRect_rt; l: integer ): integer;
    Function FetchORL( Var o: Longint; Var r: TRect_rt; Var l: integer ): integer;
    Function FetchOR( Var o: Longint; Var r: TRect_rt ): integer;
    Function FetchO: Longint;
    Function FetchR: TRect_rt;
    Procedure Zap;
    Procedure Rewind;
  End;

  TSearchList = Class
  Private
    b: TBits;
    MinRecno: Integer;
    MaxRecno: Integer;
    ReferenceCount: Integer;
  Public
    Constructor Create( RecCount: Integer );
    Destructor Destroy; Override;
    Procedure Add( Recno: Integer );
  End;

  TSearchType = ( stEnclosure, stOverlap, stEquality, stExist );
  TTreeType = ( ttRTree, ttRStar );

  { - xxx.rtx the table index (the node pages)
    - xxx.rtc the catalog for the index
      the catalog will have a header as follows, and
      followed by a list of free page number in file .rtx resulting from
      deleted nodes
  }

  TRTCatalog = Packed Record
    RootNode: Integer; // Address of root node
    Depth: Integer; // depth of the tree
    PageCount: Integer; // number of occupied pages on disk
    FreePageCount: Integer; // the count of free pages in this same file
    Implementor: longint; // Luis = #1, Garry = #2
    FileType: byte;
    PageSize: byte; // in k
    TreeType: TTreeType;
    Version: longint;
    Multiplier: integer;
    BucketSize: Integer; // number of entries per node
    LowerBound: Integer; // minimum no. of entries per node
    LastUpdate: TDateTime; // last updated
    Reserved: Array[0..32] Of char; // for future use
  End;

  TCompareOperator = ( coBT, coEQ, coGT, coGE, coLT, coLE );
  TRTNode = Class;

  TRTree = Class
  Private
    FOpenMode: Word; // fmOpenReadWrite or fmShareDenyNone or other
    levFlags: byte; // Used for rstar trees only.
    FCheckCancelSearch: Boolean;
    FSearchCanceled: Boolean;

    Function chooseLeaf( Const r: TRect_rt ): TRTNode;
    Function chooseNode( Const r: TRect_rt; lev: integer ): TRTNode;
    Function IntInsert( Const r: TRect_rt; o, lev: Integer ): integer;
  Public
    FLayer: TObject; { the layer that created this r-tree}
    TreeType: TTreeType; // The type of this tree
    RootNode: TRTNode; // The root object
    Depth: Word; // The depth of the rtree
    RootId: Longint; // Root object disk address
    FName: String;

    Constructor Create( Layer: TObject; t: TTreeType; Mode: Word ); Virtual;
    Constructor CreateName( Layer: TObject; t: TTreeType; Const Name: String; Mode: Word );
    Destructor Destroy; Override;
    Function CreateNewNode: TRTNode; Virtual; Abstract;
    Function CreateIndex( Const Name: String; Multiplier: Integer ): integer; Virtual; Abstract;
    Procedure DropIndex; Virtual; Abstract;
    Function Open( Const Name: String; Mode: Word ): integer; Virtual; Abstract;
    Procedure Close; Virtual; Abstract;
    Procedure ReadCatalog( Var IdxInfo: TRTCatalog ); Virtual; Abstract;
    Procedure WriteCatalog( Const IdxInfo: TRTCatalog ); Virtual; Abstract;
    Function Insert( Const r: TRect_rt; o: Longint ): integer;
    Function Delete( Const r: TRect_rt; o: Longint ): integer;
    Function Update( Const r: TRect_rt; o: Longint; Const newr: TRect_rt ): integer;
    Procedure Search( s: TSearchType; Const r: TRect_rt; ol: TIntegerList;
      RecordCount: Integer );
    Procedure CheckSearchCanceled; Virtual;
    Procedure StartSearch; Virtual;
    Procedure GetAllNodes( ol: TIntegerList );
    Function RootExtent: TRect_rt;
    Function FillFactor( Var NodeCount, Entries: Integer ): Double;
    Procedure FlushFiles; Virtual; Abstract;
    Procedure FindArea( Compare: TCompareOperator; Area1, Area2: Integer; ol: TList );

    Property OpenMode: Word Read FOpenMode Write FOpenMode;
    Property Layer: TObject Read FLayer Write FLayer;
    Property CheckCancelSearch: Boolean read FCheckCancelSearch write FCheckCancelSearch;
    Property SearchCanceled: Boolean read FSearchCanceled write FSearchCanceled;

  End;

  // Data structure of an R(*)tree entry
  TRTEntry = Packed Record
    R: TRect_rt; // The MBR and ...
    Child: Integer; // ... disk address of the child object or record number in .ENX file
  End;

  // Structure of a node disk image
  PDiskPage = ^TDiskPage;
  TDiskPage = Packed Record
    Parent: Longint; // Parent node object disk address
    FullEntries: Word; // # of entries in use
    Leaf: Boolean; // The leaf flag
    Dum: Char;
    Entries: Array[0..BUCKETSIZE - 1] Of TRTEntry; // Entries
    Dummy: Array[0..15] Of byte; // every disk node page is of 1024 bytes
  End;

  // Class declaration of an R-tree node
  TRTNode = Class
  Private
    Function bestEntry( Const r: TRect_rt ): Longint;
    Function findLeaf( const r: TRect_rt; o: Longint ): integer;
    Procedure enclosureSearch( Const r: TRect_rt; ol: TSearchList );
    Procedure overlapSearch( Const r: TRect_rt; ol: TSearchList );
    Procedure equalitySearch( Const r: TRect_rt; ol: TSearchList );
    Procedure existSearch( Const r: TRect_rt; ol: TSearchList );
    Procedure FillFactor( Var NodeCount, Entries: Integer );
    Procedure FindArea( Compare: TCompareOperator; Const Area1, Area2: double; ol: TList );
    Procedure GetAllNodes( ol: TIntegerList );
  Protected
    rt: TRTree; // the tree that this node belongs to
    oid: Longint; // disk address of the node object
    Data: TDiskPage; // Pointer into a copy of the info. Used in updates.
  Public
    Constructor Create( rtree: TRTree );
    Function isLeaf: boolean;
    Function isRoot: boolean;
    Procedure Read( NId: Integer ); Virtual; Abstract;
    Procedure Write; Virtual; Abstract;
    Procedure AddNodeToFile; Virtual; Abstract;
    Procedure DeleteNodeFromFile; Virtual; Abstract;
    Function Delete( o: Longint; l: integer; rl: TOList ): integer;
    Function Insert( Const r: TRect_rt; o: Longint; Var newo: longint ): integer;
    Function Locate( o: Longint ): integer;
    Procedure Compact;
    Procedure propagate( n: integer );
  End;

{$IFDEF FALSE}
  TDistribution = Record
    margin, overlap, area: double;
    mbr1, mbr2: TRect_rt;
  End;

  // R*tree node class declaration
  TRSTNode = Class( TRTNode )
  Public
    Function Insert( Const r: TRect_rt; o: Longint; lev: integer;
      ol: TOList; Var lflags: byte; Var newo: Longint ): integer;
  Private
    Function fReinsert( Const r: TRect_rt; o: Longint; lev: integer; ril: TOList ): word;
    Procedure evalMargin( Var dTab: Array Of TDistribution; sl: TSortList;
      Const newRect: TRect_rt );
    Function evalOverlap( Var dTab: Array Of tDistribution ): integer;
  End;
{$ENDIF}

  // utilities
Function Contains_rect( Const r1, r2: TRect_rt ): boolean;
//Function Overlaps_rect( Const r1, r2: TRect_rt ): boolean;

Implementation

Uses
  EzSystem;

Const
  NULL_RECT: TRect_rt = ( x1: MININT; y1: MININT; x2: MININT; y2: MININT );

Function max( a, b: integer ): integer;
Begin
  If a > b Then
    result := a
  Else
    result := b;
End;

Function min( a, b: integer ): integer;
Begin
  If a < b Then
    result := a
  Else
    result := b;
End;

Procedure memswap( Var Source, Dest; Size: Integer );
Var
  tmp: Pointer;
Begin
  GetMem( tmp, Size );
  Move( Source, tmp^, size );
  Move( Dest, Source, size );
  Move( tmp^, Dest, size );
  FreeMem( tmp, Size );
End;

Function PDIST( Const x1, y1, x2, y2: double ): double;
Begin
  If x1 = MININT Then
    result := 0
  Else
    result := sqrt( sqr( x1 - x2 ) + sqr( y1 - y2 ) );
End;

// Return the intersection rectangle (if any) of this and r

Function Intersect_rect( Const r1, r2: TRect_rt ): TRect_rt;
Begin

  result.x1 := max( r1.x1, r2.x1 );
  result.y1 := max( r1.y1, r2.y1 );
  result.x2 := min( r1.x2, r2.x2 );
  result.y2 := min( r1.y2, r2.y2 );

  If ( result.x1 > result.x2 ) Or ( result.y1 > result.y2 ) Then
    result.x1 := MININT; // no intersection

End;

// Return the mbr of r1 and r2

Function Extent_rect( Const r1, r2: TRect_rt ): TRect_rt;
Begin
  result := r1;
  {result.x1 := r1.x1; result.y1 := r1.y1;
  result.x2 := r1.x2; result.y2 := r1.y2; }
  If r1.x1 = MININT Then
    result := r2
  Else If Not ( r2.x1 = MININT ) Then
  Begin
    result.x1 := min( r1.x1, r2.x1 );
    result.y1 := min( r1.y1, r2.y1 );
    result.x2 := max( r1.x2, r2.x2 );
    result.y2 := max( r1.y2, r2.y2 );
  End;
End;

// Return the area of this

Function Area_rect( Const r: TRect_rt ): double;
Var
  dx, dy: double;
Begin
  If r.x1 = MININT Then
    result := 0
  Else
  Begin
    dx := ( r.x2 - r.x1 );
    dy := ( r.y2 - r.y1 );
    result := abs( dx * dy );
  End;
End;

// Return the margin of this

Function Margin_rect( Const r: TRect_rt ): integer;
Begin
  If r.x1 = MININT Then
    result := 0
  Else
    result := 2 * ( abs( r.x2 - r.x1 ) + abs( r.y2 - r.y1 ) );
End;

// Return delta(Area) if this is extended with a rect r.

Function Delta_rect( Const r1, r2: TRect_rt ): double;
Begin
  result := Area_rect( Extent_rect( r1, r2 ) ) - Area_rect( r1 );
End;

// Return whether r1 contains r2

Function Contains_rect( Const r1, r2: TRect_rt ): boolean;
Begin
  result := ( ( r2.x1 >= r1.x1 ) And ( r2.x1 <= r1.x2 ) And
    ( r2.x2 >= r1.x1 ) And ( r2.x2 <= r1.x2 ) And
    ( r2.y1 >= r1.y1 ) And ( r2.y1 <= r1.y2 ) And
    ( r2.y2 >= r1.y1 ) And ( r2.y2 <= r1.y2 ) );
End;

// Return whether this and r overlaps

Function Overlaps_rect( Const r1, r2: TRect_rt ): boolean;
Begin
  If max( r2.x1, r1.x1 ) > min( r2.x2, r1.x2 ) Then
  Begin
    result := false;
    exit;
  End;
  If max( r2.y1, r1.y1 ) > min( r2.y2, r1.y2 ) Then
  Begin
    result := false;
    exit;
  End;
  result := true;
End;

// Return whether r equals this

Function Equals_rect( Const r1, r2: TRect_rt ): boolean;
Begin
  result := CompareMem( @r1, @r2, sizeof( TRect_rt ) );
  //(r2.x1=r1.x1) and (r2.x2=r1.x2) and
  //         (r2.y1=r1.y1) and (r2.y2=r1.y2);
End;

{$IFDEF FALSE}
// The following is used to obtain a single value from two integers A&B.

Function compose( A, B: integer ): integer;
Begin
  result := ( ( A And $0000FFFF ) Shl 16 ) Or ( B And $0000FFFF );
  //#define compose(A,B)   ((uint)((((A)&0x0000FFFF)<<16) | ((B)&0x0000FFFF)))
End;
{$ENDIF}

// TSortList class implementation

Constructor TSortList.Create( l: integer );
Begin
  Inherited Create;
  GetMem( dist, l * sizeof( integer ) );
  GetMem( indx, l * sizeof( integer ) );

  size := l;
  len := 0;
End;

Destructor TSortList.Destroy;
Begin
  FreeMem( dist, size * sizeof( integer ) );
  FreeMem( indx, size * sizeof( integer ) );
  Inherited Destroy;
End;

Procedure TSortList.Insert( d, i: integer );
Begin
  dist[len] := d;
  indx[len] := i;
  inc( len );
End;

// Quick sort algorithm; Sort len numbers at the address dist.

Procedure TSortList.Sort;
{var
  i, j: integer; }

  Procedure QuickSort( L, R: Integer );
  Var
    I, J, P, T: Integer;
  Begin
    Repeat
      I := L;
      J := R;
      P := dist[( L + R ) Shr 1];
      Repeat
        While dist[I] < P Do
          Inc( I );
        While dist[J] > P Do
          Dec( J );
        If I <= J Then
        Begin
          //swap(dist[i], dist[j]);
          T := dist[I];
          dist[I] := dist[J];
          dist[J] := T;
          //swap(indx[i], indx[j]);
          T := indx[I];
          indx[I] := indx[J];
          indx[J] := T;
          Inc( I );
          Dec( J );
        End;
      Until I > J;
      If L < J Then
        QuickSort( L, J );
      L := I;
    Until I >= R;
  End;

Begin

  If len > 0 Then
    QuickSort( 0, len - 1 );

  {for i := 1 to len-1 do              // For each position in the array
   if dist[i] < dist[i-1] then
   begin      // If this number is out of seq
     j := i-1;                        // j points to one step back
     while dist[j]>dist[j+1] do begin   // until our number finds its position
       swap(dist[j],dist[j+1]);    // swap it with its left neighbor
       swap(indx[j],indx[j+1]);
       if j=0 then break;            // and go one more step left
       dec(j);
     end;
   end; }
End;

Function TSortList.valAt( p: integer ): integer;
Begin
  If p >= len Then
  Begin
    result := -1;
  End
  Else
    result := indx[p];
End;

Function TSortList.Length: integer;
Begin
  result := len;
End;

// TRTree class implementation

Constructor TRTree.Create( Layer: TObject; t: TTreeType; Mode: Word );
Begin
  Inherited Create;
  FLayer := Layer;
  TreeType := t;
  RootNode := CreateNewNode;
  RootId := -1;
  FOpenMode := Mode;
End;

Constructor TRTree.CreateName( Layer: TObject; t: TTreeType; Const Name: String; Mode: Word );
Begin
  Create( Layer, t, Mode );
  Open( Name, Mode );
End;

Destructor TRTree.Destroy;
Begin
  {if IsOpened then} Close;
  RootNode.Free;
  Inherited Destroy;
End;