ezrtree.pas

很管用的GIS控件

// Insert object o with mbr r into rtree

Function TRTree.Insert( Const r: TRect_rt; o: Longint ): integer;
Var
  //ol: TOList;
  L: TRTNode;
  retCode: integer;
  IdxInfo: TRTCatalog;
  newo: Longint;
  //i: integer;
  //r: TRect_rt;
Begin

  {r:= wr;
  if CompareMem(@r.x1, @r.x2, SizeOf(Integer)*2) then
  begin
    r.x1:= r.x1 - 100;
    r.y1:= r.y1 - 100;
    r.x2:= r.x2 + 100;
    r.y2:= r.y2 + 100;
  end; }

  //if not IsOpened then begin result := TREE_ERROR; exit; end;
  levFlags := 0;

  L := chooseLeaf( r );
{$IFDEF FALSE}
  If TreeType = ttRStar Then
  Begin // R*-tree
    ol := TOList.Create;
    newo := -1;
    retCode := TRSTNode( L ).Insert( r, o, 0, ol, levFlags, newo );
    If retcode = TREE_ERROR Then
    Begin
      L.free;
      ol.free;
      result := TREE_ERROR;
      exit;
    End;

    ol.Rewind;
    While Not ol.isEmpty Do
      IntInsert( ol );
    ol.Zap;
    ol.free;
  End
  Else
  Begin // RTree
{$ENDIF}
    newo := -1;
    retCode := L.Insert( r, o, newo );
    If retcode = TREE_ERROR Then
    Begin
      L.free;
      result := TREE_ERROR;
      exit;
    End;
{$IFDEF FALSE}
  End;
{$ENDIF}
  L.free;

  If retCode = ROOT_CHANGED Then
  Begin
    Inc( Depth ); // Grow tree taller
    RootNode.Read( RootId ); // Read the old root
    RootId := RootNode.Data.Parent; // Take its parent id

    // Update the catalog entry
    ReadCatalog( IdxInfo );
    IdxInfo.RootNode := RootId;
    IdxInfo.Depth := Depth;
    WriteCatalog( IdxInfo );
  End;

  result := OK;
End;

// Insert internal node

Function TRTRee.IntInsert( Const r: TRect_rt; o, lev: Integer ): integer;
Var
  L: TRTNode;
  newo, retCode: integer;
  IdxInfo: TRTCatalog;
Begin

  //  RootNode.Read(&RootId);
  L := chooseNode( r, lev );

  newo := -1;
{$IFDEF FALSE}
  If TreeType = ttRTree Then
{$ENDIF}
    retCode := L.Insert( r, o, newo );
{$IFDEF FALSE}
  Else
    retCode := TRSTNode( L ).Insert( r, o, lev, ol, levFlags, newo );
{$ENDIF}

    L.free;

    If retCode = TREE_ERROR Then
    Begin
      result := TREE_ERROR;
      exit;
    End;

    If retCode = ROOT_CHANGED Then
    Begin
      Inc( Depth );
      RootNode.Read( RootId ); // Read the old root
      RootId := RootNode.Data.Parent; // Take its parent id

      //    RootNode.Read(RootId);             // Read the new root

      // Read the catalog entry
      ReadCatalog( IdxInfo );

      // Assign the new values
      IdxInfo.RootNode := RootId;
      IdxInfo.Depth := Depth;

      // Update it
      WriteCatalog( IdxInfo );
    End;

    result := OK;
End;

// Delete the object o from the rtree

Function TRTree.Delete( Const r: TRect_rt; o: Longint ): integer;
Var
  L: TRTNode;
  rl: TOList;
  rc, il: integer;
  IdxInfo: TRTCatalog;
  rr: TRect_rt;
  ro: Longint;
Begin

  L := CreateNewNode;

  rl := TOList.Create;

  L.Read( RootId );
  If L.findLeaf( r, o ) = TREE_ERROR Then
  Begin
    result := TREE_ERROR;
    exit;
  End;

  rc := L.Delete( o, 0, rl );

  If rc = TREE_ERROR Then
  Begin
    result := TREE_ERROR;
    exit;
  End;

  If rc = ROOT_CHANGED Then
  Begin
    Dec( Depth );
    RootNode.Read( RootId ); // Read the old root
    RootId := RootNode.Data.Entries[0].Child; // Take the new root id
    RootNode.DeleteNodeFromFile;

    RootNode.Read( RootId ); // Read the new root

    // Update the catalog entry
    ReadCatalog( IdxInfo );

    IdxInfo.RootNode := RootId;
    IdxInfo.Depth := Depth;

    WriteCatalog( IdxInfo );
  End;

  While Not rl.isEmpty Do
  Begin
    rl.FetchORL( ro, rr, il );
    If il = 0 Then
      Insert( rr, ro ) // leaf level
    Else
      IntInsert( rr, ro, il ); // internal
  End;

  rl.Zap;

  L.free;
  rl.free;

  result := OK;
End;

Function TRTree.Update( Const r: TRect_rt; o: Longint; Const newr: TRect_rt ): integer;
Begin
  result := Delete( r, o );
  If Not ( result = OK ) Then
  Begin
    exit;
  End;
  result := Insert( newr, o );
End;

// Choose the best place to create the new internal node

Function TRTree.chooseNode( Const r: TRect_rt; lev: integer ): TRTNode;
Var
  best: Longint;
  l: integer;
Begin

  result := CreateNewNode;

  result.Read( RootId ); // Read the root node into work space

  l := Depth;
  While l > lev Do
  Begin
    best := result.bestEntry( r );
    result.Read( best );
    Dec( l );
  End;

End;

// Choose the best leaf node to insert the new rect r.

Function TRTree.chooseLeaf( Const r: TRect_rt ): TRTNode;
Var
  best: Longint;
Begin

  result := CreateNewNode;

  result.Read( RootId ); // Read the root node into work space

  While Not result.isLeaf Do
  Begin
    best := result.bestEntry( r );
    result.Read( best );
  End;
End;

// Look up rectangle r with search type s

Procedure TRTree.CheckSearchCanceled;
Begin
  // nothing to do here: only for descendants
End;

Procedure TRTree.StartSearch;
Begin
  // nothing o do here: only for descendants
End;

Procedure TRTree.Search( s: TSearchType; Const r: TRect_rt; ol: TIntegerList;
  RecordCount: Integer );
Var
  sl: TSearchList;
  I: Integer;
Begin
  //if not IsOpened then exit;
  StartSearch;

  ol.clear;
  sl := TSearchList.Create( RecordCount );
  RootNode.Read( RootId );
  FSearchCanceled:= False;
  Case s Of
    stEnclosure: RootNode.enclosureSearch( r, sl );
    stOverlap: RootNode.overlapSearch( r, sl );
    stEquality: RootNode.equalitySearch( r, sl );
    stExist: RootNode.existSearch( r, sl );
  End;
  If sl.ReferenceCount = 0 Then
  Begin
    sl.free;
    exit;
  End;
  ol.Capacity := sl.ReferenceCount;
  For I := sl.MinRecno To sl.MaxRecno Do
    If sl.b[I] Then ol.Add( I );
  sl.free;
End;

Procedure TRTree.GetAllNodes( ol: TIntegerList );
Begin
  ol.clear;
  RootNode.Read( RootID );
  RootNode.GetAllNodes( ol );
End;

Function TRTree.RootExtent: TRect_rt;
Var
  i: integer;
Begin
  RootNode.Read( RootID );
  result := RootNode.Data.Entries[0].R;
  For i := 1 To RootNode.Data.FullEntries - 1 Do
    result := Extent_rect( result, RootNode.Data.Entries[i].R );
End;

Procedure TRTree.FindArea( Compare: TCompareOperator; Area1, Area2: Integer; ol: TList );
Begin
  RootNode.Read( RootID );
  RootNode.FindArea( Compare, Area1, Area2, ol );
End;

Function TRTree.FillFactor( Var NodeCount, Entries: Integer ): Double;
Begin
  RootNode.Read( RootID );
  NodeCount := 0;
  Entries := 0;
  RootNode.FillFactor( NodeCount, Entries );
  Result := Entries / NodeCount;
End;

{ TRTNode class implementation }

Constructor TRTNode.Create( rtree: TRTree );
Begin
  Inherited Create;
  rt := rtree;
End;

Procedure TRTNode.FillFactor( Var NodeCount, Entries: Integer );
Var
  i, me: Integer;
  TmpDiskPage: TDiskPage;
Begin
  If Not Data.Leaf Then
  Begin
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      TmpDiskPage := Data;
      me := oid;
      Read( Data.Entries[i].Child );
      FillFactor( NodeCount, Entries );
      oid := me;
      Data := TmpDiskPage;
    End;
  End;
  If Data.Leaf Then
  Begin
    Inc( Entries, Data.FullEntries );
    Inc( NodeCount );
  End;
End;

Procedure TRTNode.FindArea( Compare: TCompareOperator;
  Const Area1, Area2: double; ol: TList );
Var
  i, me: Integer;
  tmpArea: double;
  rslt: Boolean;
  TmpDiskPage: TDiskPage;
Begin
  If Data.Leaf Then
  Begin
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      tmpArea := Area_rect( Data.Entries[i].R );
      Case Compare Of
        coBT: rslt := ( tmpArea >= Area1 ) And ( tmpArea <= Area2 );
        coEQ: rslt := tmpArea = Area1;
        coGT: rslt := tmpArea > Area1;
        coGE: rslt := tmpArea >= Area1;
        coLT: rslt := tmpArea < Area1;
        coLE: rslt := tmpArea <= Area1;
      Else
        rslt := false;
      End;
      If rslt Then
        ol.Add( Pointer( Data.Entries[i].Child ) );
    End
  End
  Else
  Begin
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      tmpArea := Area_rect( Data.Entries[i].R );
      If tmpArea >= Area1 Then
      Begin
        me := oid;
        TmpDiskPage := Data;
        Read( Data.Entries[i].Child );
        FindArea( Compare, Area1, Area2, ol );
        //Read(me);                        // Refresh
        oid := me;
        Data := TmpDiskPage;
      End;
    End;
  End;
End;

// Locate the smallest entry in which r fits

Function TRTNode.bestEntry( Const r: TRect_rt ): Longint;
Var
  i, mini: integer;
  mina, mind, delta: double;
Begin
  mini := 0;

  mina := area_rect( Data.Entries[0].R );
  mind := delta_rect( Data.Entries[0].R, r );

  For i := 1 To Data.FullEntries - 1 Do
  Begin
    delta := delta_rect( Data.Entries[i].R, r );
    If ( delta < mind ) Or ( ( delta = mind ) And ( mina > area_rect( Data.Entries[i].R ) ) ) Then
    Begin
      mini := i;
      mina := area_rect( Data.Entries[i].R );
      mind := delta;
    End;
  End;

  result := Data.Entries[mini].Child;
End;

Procedure TRTNode.GetAllNodes( ol: TIntegerList );
Var
  I, me: integer;
  TmpDiskPage: TDiskPage;
Begin
  If Data.Leaf Then
  Begin
    For i := 0 To Data.FullEntries - 1 Do
      ol.Add( Data.Entries[i].Child );
  End Else
  Begin
    For i := 0 To Data.FullEntries - 1 Do
      Begin
        me := oid;
        TmpDiskPage := Data;
        Read( Data.Entries[i].Child );
        GetAllNodes( ol );
        Data := TmpDiskPage;
        oid := me;
      End;
  End;
end;

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

Procedure TRTNode.enclosureSearch( Const r: TRect_rt; ol: TSearchList );
Var
  I, me: integer;
  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 Contains_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 );
        enclosureSearch( r, ol );
        Data := TmpDiskPage;
        oid := me;
        //Read(me); // Refresh
      End;
End;

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

Procedure TRTNode.overlapSearch( Const r: TRect_rt; ol: TSearchList );
Var
  i: integer;
  me: Longint;
  TmpDiskPage: TDiskPage;

  Function WasCanceled: Boolean;
  begin
    Result:=False;
    If rt.FCheckCancelSearch Then
    begin
      rt.CheckSearchCanceled;
      Result:= rt.FSearchCanceled;
    End;
  end;

Begin
  If WasCanceled then Exit;
  If Data.Leaf Then
  Begin
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      If Overlaps_rect( r, Data.Entries[i].R ) Then
        ol.Add( Data.Entries[i].Child );
    End
  End
  Else
  Begin
    For i := 0 To Data.FullEntries - 1 Do
    Begin
      If Overlaps_rect( r, Data.Entries[i].R ) Then
      Begin
        me := oid;
        TmpDiskPage := Data;
        Read( Data.Entries[i].Child );
        overlapSearch( r, ol );
        Data := TmpDiskPage;
        oid := me;
        //Read(me);                        // Refresh
        If WasCanceled Then Exit;
      End;
    End;
  End;
End;

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

Procedure TRTNode.equalitySearch( Const r: TRect_rt; ol: TSearchList );