ezrtree.pas

很管用的GIS控件

Var
  i: integer;
  me: Longint;
  TmpDiskPage: TDiskPage;
Begin
  If rt.FCheckCancelSearch Then
  begin
    rt.CheckSearchCanceled;
    If rt.FSearchCanceled Then Exit;
  End;
  If Data.Leaf Then
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      If Equals_rect( r, Data.Entries[i].R ) Then
        ol.Add( Data.Entries[i].Child );
    End
  Else
    For i := 0 To Data.FullEntries - 1 Do
      If Overlaps_rect( r, Data.Entries[i].R ) Then
      Begin
        me := oid;
        TmpDiskPage := Data;
        Read( Data.Entries[i].Child );
        equalitySearch( r, ol );
        //Read(me);                        // Refresh
        oid := me;
        Data := TmpDiskPage;
      End;

End;

// Add all objects containing r to ol, and return it.

Procedure TRTNode.existSearch( Const r: TRect_rt; ol: TSearchList );
Var
  i: Integer;
  me: Longint;
  TmpDiskPage: TDiskPage;
Begin
  rt.CheckSearchCanceled;
  If rt.FSearchCanceled Then Exit;
  If Data.Leaf Then
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      If Contains_rect( Data.Entries[i].R, r ) Then
        ol.Add( Data.Entries[i].Child );
    End
  Else
    For i := 0 To Data.FullEntries - 1 Do
      If Overlaps_rect( r, Data.Entries[i].R ) Then
      Begin
        me := oid;
        TmpDiskPage := Data;
        Read( Data.Entries[i].Child );
        existSearch( r, ol );
        Data := TmpDiskPage;
        oid := me;
        //Read(me);                        // Refresh
      End;
End;

// Find the pair of entries in r which have the largest distance

Procedure PickSeed( Var r: Array Of TRTEntry; n: integer );
Var
  i, j, im, jm: integer;
  dmax, d: double;
Begin

  im := 0;
  jm := 1;
  dmax := Area_rect( Extent_rect( r[0].R, r[1].R ) );
  dmax := dmax - ( Area_rect( r[0].R ) + Area_rect( r[1].R ) );
  For i := 1 To n - 2 Do
    For j := i + 1 To n - 1 Do
    Begin
      d := Area_rect( Extent_rect( r[i].R, r[j].R ) ) - ( Area_rect( r[i].R ) + Area_rect( r[j].R ) );
      If d > dmax Then
      Begin
        im := i;
        jm := j;
        dmax := d;
      End;
    End;

  memswap( r[im], r[n - 2], SizeOf( TRTEntry ) );
  memswap( r[jm], r[n - 1], SizeOf( TRTEntry ) );

End;

Function PickNext( Var r: Array Of TRTEntry; n: integer; Const mbr0, mbr1: TRect_rt ): integer;
Var
  i, im, mm: integer;
  d0, d1, dmin: double;
Begin
  im := 0;

  d0 := Delta_rect( r[0].R, mbr0 );
  d1 := Delta_rect( r[0].R, mbr1 );

  If d0 < d1 Then
  Begin
    dmin := d0;
    mm := 0;
  End
  Else
  Begin
    dmin := d1;
    mm := 1;
  End;

  For i := 1 To n - 1 Do
  Begin
    d0 := Delta_rect( r[i].R, mbr0 );
    d1 := Delta_rect( r[i].R, mbr1 );
    If ezlib.dmin( d0, d1 ) < dmin Then
    Begin
      im := i;
      If d0 < d1 Then
      Begin
        dmin := d0;
        mm := 0;
      End
      Else
      Begin
        dmin := d1;
        mm := 1;
      End;
    End;
  End;
  memswap( r[n - 1], r[im], SizeOf( TRTEntry ) );
  result := mm;
End;

Procedure TRTNode.propagate( n: integer );
Var
  me: integer;
  MyOid, Par: Longint;
  r: TRect_rt;
  //oldData: TDiskPage;
Begin

  If isRoot Then
    exit;

  MyOid := oid;
  Par := Data.Parent;

  r := Data.Entries[n].R;

  Read( Par );

  me := Locate( MyOid );
  If me = NOTFOUND Then
    EzGISError( 'propagate' );

  //oldData := Data;

  Data.Entries[me].R := Extent_rect( Data.Entries[me].R, r );
  Write;
  //Data := oldData;

  propagate( me );
End;

// Insert r into this. Make all arrangements like splitting.
// Return ROOT_CHANGED if it changes.

Function TRTNode.Insert( Const r: TRect_rt; o: Longint; Var newo: Longint ): integer;
Var
  s1, s2, node, m, n, na, nb, me, ric, ret: integer;
  newNode, newRoot, parNode, childNode: TRTNode;
  temp: Array[0..BUCKETSIZE] Of TRTEntry;
  MBRa, MBRb: TRect_rt;
  MyOid, parNewo: Longint;
Begin
  ric := OK;
  na := 0;
  nb := 0;

  If Data.FullEntries < BUCKETSIZE Then // Trivial case.
  Begin
    Data.Entries[Data.FullEntries].R := r; // Put it at the end
    Data.Entries[Data.FullEntries].Child := o;
    Inc( Data.FullEntries );
    Write;

    If Not Data.Leaf Then
    Begin
      childNode := rt.CreateNewNode;
      childNode.Read( Data.Entries[Data.FullEntries - 1].Child );
      childNode.Data.Parent := oid;
      childNode.Write;
      childNode.free;
    End;

    MyOid := oid;
    propagate( Data.FullEntries - 1 );
    Read( MyOid );

    result := OK;
    exit;
  End;

  // This node is full. It needs to be splitted.

  If isRoot Then // If this is the root
  Begin
    newRoot := rt.CreateNewNode;
    newRoot.Data.Parent := -1; // invalidate the parent
    newRoot.Data.Leaf := False;
    newRoot.Data.FullEntries := 1; // One entry.

    // First son of the new root is the old root
    newRoot.Data.Entries[0].Child := oid;

    newRoot.AddNodeToFile;

    Data.Parent := newRoot.oid; // The same parent
    ric := ROOT_CHANGED; // Mark root is changed
    newRoot.free;
  End;

  newNode := rt.CreateNewNode;
  parNode := rt.CreateNewNode;
  Try

    newNode.Data.Leaf := Data.Leaf; // Initialize the new node
    newNode.Data.FullEntries := 0; // It's empty yet
    newNode.Data.Parent := Data.Parent; // The same parent
    newNode.AddNodeToFile; // Create it on disk
    newo := newNode.oid;

    parNode.Read( Data.Parent );

    me := parNode.Locate( oid ); // Which entry is pointing to me?
    If me = NOTFOUND Then
      EzGISError( 'Insert' );

    parNode.Data.Entries[me].R := NULL_RECT; // Replace the old mbr with
    // Nil rect
    parNode.Write;

    // Insert the new node into the parent

    parNewo := -1;
    ret := parNode.Insert( NULL_RECT, newNode.oid, parNewo );
    If ret = TREE_ERROR Then
    Begin
      result := TREE_ERROR;
      exit;
    End;
    If parNewo >= 0 Then
    Begin
      If parNode.Locate( oid ) = NOTFOUND Then
      Begin
        Data.Parent := parNewO;
        Write;
      End;
      If parNode.Locate( newNode.oid ) = NOTFOUND Then
      Begin
        newNode.Data.Parent := parNewO;
        newNode.Write;
      End;
    End;
    If ret = ROOT_CHANGED Then
      ric := ret;

    Move( Data.Entries[0], temp[0], SizeOf( TRTEntry ) * BUCKETSIZE );

    temp[BUCKETSIZE].R := r; // The entry to be inserted is placed
    temp[BUCKETSIZE].Child := o; // ...at the last position in the temp

    Data.FullEntries := 0; // Empty the node

    // Select the first pair of entries and move to the last 2 positions
    PickSeed( temp, BUCKETSIZE + 1 );

    s1 := BUCKETSIZE - 1;
    s2 := BUCKETSIZE; // Initialize the MBRs
    MBRa := temp[s1].R;
    MBRb := temp[s2].R; // of the nodes

    // Insert the first into this, and the second into the new node
       {parNewo := -1;} ret := Insert( MBRa, temp[s1].Child, parNewo );
    If ret = ROOT_CHANGED Then
      ric := ret;
    {parNewo := -1;} ret := newNode.Insert( MBRb, temp[s2].Child, parNewo );
    If ret = ROOT_CHANGED Then
      ric := ret;

    n := BUCKETSIZE - 1;
    m := HALF_BUCKET;

    While n <> 0 Do
    Begin
      If na = m Then
        node := 1 // node A is full, pick B
      Else If nb = m Then
        node := 0 // node B is full, pick A
      Else
        node := PickNext( temp, n, MBRa, MBRb ); // pick the next node

      If node <> 0 Then
      Begin
        {parNewo := -1;} ret := newNode.Insert( temp[n - 1].R, temp[n - 1].Child, parNewo );
        If ret = ROOT_CHANGED Then
          ric := ret;
        MBRb := Extent_rect( MBRb, temp[n - 1].R );
        inc( nb );
      End
      Else
      Begin
        {parNewo := -1;} ret := Insert( temp[n - 1].R, temp[n - 1].Child, parNewo );
        If ret = ROOT_CHANGED Then
          ric := ret;
        MBRa := Extent_rect( MBRa, temp[n - 1].R );
        Inc( na );
      End;
      Dec( n );
    End;

  Finally
    newNode.free;
    parNode.free;
  End;

  result := ric;

End;

Function TRTNode.IsRoot: boolean;
Begin
  result := ( Data.Parent = -1 );
End;

Procedure TRTNode.Compact;
Var
  r: TRect_rt;
  i, me: integer;
  MyOid, Par: Longint;
Begin

  If isRoot Then
    exit; // cannot compact root...

  MyOid := oid;
  Par := Data.Parent;

  r := Data.Entries[0].R;
  For i := 1 To Data.FullEntries - 1 Do
    r := Extent_rect( r, Data.Entries[i].R );

  Read( Par );

  me := Locate( MyOid );
  If me = NOTFOUND Then
    EzGISError( 'Compact' );

  Data.Entries[me].R := r;
  Write;

  Compact;
End;

// Delete r from this. Make all arrangements like condensing the tree
// Return Root if it changes.

Function TRTNode.Delete( o: Longint; l: integer; rl: TOList ): integer;
Var
  n, i: integer;
  child, parent: TRTNode;
  choid: Longint;
  retCode: integer;
Begin
  parent := rt.CreateNewNode;
  Try

    retcode := OK;

    n := Locate( o ); // Find the entry for this obj.

    If n = NOTFOUND Then
      EzGISError( 'Unrecoverable error! Aborting.' );

    If Not Data.Leaf Then
    Begin
      child := rt.CreateNewNode;
      child.Read( Data.Entries[n].Child );
      child.DeleteNodeFromFile; // Destroy the deleted node
      child.free;
    End;

    // Replace the entry with the last entry and decrement Full Entries
    Dec( Data.FullEntries );
    Data.Entries[n] := Data.Entries[Data.FullEntries];
    Write;

    If Data.FullEntries < LOWERBOUND Then // Condense
    Begin
      If isRoot Then // if this is the root
      Begin
        If Data.FullEntries <> 1 Then
        Begin
          result := OK;
          exit;
        End;
        If Not Data.Leaf Then
        Begin
          choid := Data.Entries[0].Child;
          child := rt.CreateNewNode;
          child.Read( choid );
          child.Data.Parent := -1;
          child.Write;
          child.free;
          result := ROOT_CHANGED;
          exit;
        End;
        result := OK;
        exit;
      End;

      For i := 0 To Data.FullEntries - 1 Do // copy rest of the entries into temp
        rl.Insertl( Data.Entries[i].Child, Data.Entries[i].R, l );

      parent.Read( Data.Parent );
      retCode := parent.Delete( oid, l + 1, rl ); // Delete this node from parent
    End
    Else
      Compact;

    result := retCode;
  Finally
    parent.free;
  End;
End;

// Return the index of the entry in this TRTNode which points to o.

Function TRTNode.Locate( o: Longint ): integer;
Var
  i: integer;
Begin
  result := NOTFOUND;
  For i := 0 To Data.FullEntries - 1 Do
    If Data.Entries[i].Child = o Then
    Begin
      result := i;
      exit;
    End;
End;

Function TRTNode.findLeaf( const r: TRect_rt; o: Longint ): integer;
Var
  i: integer;
  me: Longint;
Begin
  If Data.Leaf Then
  Begin
    If Locate( o ) = NOTFOUND Then
    Begin
      result := TREE_ERROR;
      exit;
    End
    Else
    Begin
      result := OK;
      exit;
    End; // it is here!
  End
  Else
    For i := 0 To Data.FullEntries - 1 Do
      If Contains_rect( Data.Entries[i].R, r ) Then
      Begin
        me := oid;
        Read( Data.Entries[i].Child );
        If findLeaf( r, o ) = OK Then
        Begin
          result := OK;
          exit;
        End;
        Read( me );
      End;

  result := TREE_ERROR;
End;

Function TRTNode.isLeaf: boolean;
Begin
  result := Data.Leaf;
End;

{$IFDEF FALSE}
// TRSTNode class implementation R*-tree

Function TRSTNode.fReinsert( Const r: TRect_rt; o: Longint; lev: integer; ril: TOList ): word;
Var
  sl: TSortList;
  reorg: TOlist; // reinsert & reorganize lists.
  ro: Longint;
  rr: TRect_rt;
  i, j, dist: integer;
  minx, maxx, miny, maxy, crx, cry, cx, cy: integer;
Begin

  reorg := TOlist.Create;
  sl := TSortList.Create( BUCKETSIZE + 1 );

  minx := r.x1;
  maxx := r.x2;
  miny := r.y1;
  maxy := r.y2;
  crx := ( minx + maxx ) Div 2;
  cry := ( miny + maxy ) Div 2;

  For i := 0 To BUCKETSIZE - 1 Do
  Begin
    If Data.Entries[i].R.x1 < minx Then
      minx := Data.Entries[i].R.x1;
    If Data.Entries[i].R.x2 > maxx Then
      maxx := Data.Entries[i].R.x2;
    If Data.Entries[i].R.y1 < miny Then
      miny := Data.Entries[i].R.y1;
    If Data.Entries[i].R.y2 > maxy Then
      maxy := Data.Entries[i].R.y2;
  End;

  cx := ( minx + maxx ) Div 2;
  cy := ( miny + maxy ) Div 2;