ezrtree.pas

很管用的GIS控件

  sl.Insert( trunc( PDIST( cx, cy, crx, cry ) ), BUCKETSIZE );

  For i := 0 To BUCKETSIZE - 1 Do
  Begin
    crx := ( Data.Entries[i].R.x1 + Data.Entries[i].R.x2 ) Div 2;
    cry := ( Data.Entries[i].R.y1 + Data.Entries[i].R.y2 ) Div 2;
    dist := trunc( PDIST( cx, cy, crx, cry ) );
    sl.Insert( dist, i );
  End;

  sl.Sort;

  For i := 0 To BUCKETSIZE Do
  Begin
    j := sl.valAt( i );
    If i < HALF_BUCKET Then
    Begin
      If j = BUCKETSIZE Then
        reorg.Insertl( o, r, lev )
      Else
        reorg.Insertl( Data.Entries[j].Child, Data.Entries[j].R, lev );
    End
    Else
    Begin
      If j = BUCKETSIZE Then
        ril.Insertl( o, r, lev )
      Else
        ril.Insertl( Data.Entries[j].Child, Data.Entries[j].R, lev );
    End;
  End;

  For i := 0 To HALF_BUCKET - 1 Do
  Begin
    reorg.FetchOR( ro, rr );
    Data.Entries[i].R := rr;
    Data.Entries[i].Child := ro;
  End;
  Data.FullEntries := HALF_BUCKET;

  Write;
  Compact;

  reorg.free;
  sl.free;

  result := OK;
End;

Function first( f, l: integer ): boolean;
Begin
  result := ( ( 1 Shl l ) And f ) = 0;
  //  (!((1<<l)&f))
End;

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

Function TRSTNode.Insert( Const r: TRect_rt; o: Longint; lev: integer;
  ol: TOList; Var lflags: byte; Var newo: Longint ): integer;
Var
  s1, s2, node, m, n, na, nb, i, me, ric, ret: integer;
  newNode, newRoot, parNode, childNode: TRSTNode;
  temp: Array[0..BUCKETSIZE] Of TRTEntry;
  MBRa, MBRb: TRect_rt;
  MyOid, parNewo: Longint;
  slx, sly, sl: TSortList;
  xDist: Array[0..DSIZE - 1] Of TDistribution;
  yDist: Array[0..DSIZE - 1] Of TDistribution;
  axis, cut, indx: integer;
  tmp: double;
  Iamroot: boolean;
Begin
  newNode := TRSTNode.Create( rt );
  newRoot := TRSTNode.Create( rt );
  parNode := TRSTNode.Create( rt );
  childNode := TRSTNode.Create( rt );
  slx := TSortList.Create( BUCKETSIZE + 1 );
  sly := TSortList.Create( BUCKETSIZE + 1 );
  Try
    ric := OK;

    If Data.FullEntries < BUCKETSIZE Then
    Begin // Trivial case.

      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.Read( Data.Entries[Data.FullEntries - 1].Child );
        childNode.Data.Parent := oid;
        childNode.Write;
      End;

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

      result := OK;
      exit;
    End;

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

    Iamroot := isRoot;
    If Iamroot Then
    Begin // If this is the root

      newRoot.Data.Parent := -1;
      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;
      Write;

      ric := ROOT_CHANGED; // Mark root is changed

    End
    Else If Not Iamroot And first( lflags, lev ) Then
    Begin
      lflags := lflags Or ( 1 Shl lev ); // Set the level flag
      result := fReinsert( r, o, lev, ol ); // Forced re-insertion
      exit;
    End;

    // Split this node -- there has been a previous forced reinsertion
    // at this level or this is the root node

    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 NULL
    // rectangle
    parNode.Write;

    // Insert the new node into the parent
    parNewo := -1;
    ret := parNode.Insert( NULL_RECT, newNode.oid, lev + 1, ol, lflags, 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;

    slx.Insert( compose( r.x1, r.x2 ), BUCKETSIZE );
    For i := 0 To BUCKETSIZE - 1 Do
      slx.Insert( compose( Data.Entries[i].R.x1, Data.Entries[i].R.x2 ), i );

    slx.Sort;

    sly.Insert( compose( r.y1, r.y2 ), BUCKETSIZE );
    For i := 0 To BUCKETSIZE - 1 Do
      sly.Insert( compose( Data.Entries[i].R.y1, Data.Entries[i].R.y2 ), i );

    sly.Sort;

    evalMargin( xDist, slx, r );
    evalMargin( yDist, sly, r );

    tmp := xDist[0].margin;
    axis := XAXIS;
    For i := 0 To DSIZE - 1 Do
    Begin
      If xDist[i].margin < tmp Then
      Begin
        tmp := xDist[i].margin;
        axis := XAXIS;
      End;
      If yDist[i].margin < tmp Then
      Begin
        tmp := yDist[i].margin;
        axis := YAXIS;
      End;
    End;

    If axis = XAXIS Then
    Begin
      cut := evalOverlap( xDist );
      sl := slx;
    End
    Else
    Begin
      cut := evalOverlap( yDist );
      sl := sly;
    End;

    // Distribute the entries in the sortlist between 0 - LOWERBOUND+cut-1 to
    //  the first, and the ones between LOWERBOUND+cut - BUCKETSIZE to 2nd node

    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

    // Insert the first into this, and the second into the new node
    For i := 0 To LOWERBOUND + cut - 2 Do
    Begin
      indx := sl.valAt( i );
      ret := Insert( temp[indx].R, temp[indx].Child, lev, ol, lflags, newo );
      If ret = ROOT_CHANGED Then
        ric := ret;
    End;

    While i < BUCKETSIZE + 1 Do
    Begin
      indx := sl.valAt( i );
      ret := newNode.Insert( temp[indx].R, temp[indx].Child, lev, ol, lflags, newo );
      If ret = ROOT_CHANGED Then
        ric := ret;

      inc( i );
    End;

    result := ric;
  Finally
    newNode.free;
    newRoot.free;
    parNode.free;
    childNode.free;
    slx.free;
    sly.free;
  End;
End;

Procedure TRSTNode.evalMargin( Var dTab: Array Of TDistribution; sl: TSortList;
  Const newRect: TRect_rt );
Var
  tr1, tr2, r: TRect_rt;
  i, indx, Ix1, Ix2: integer;
Begin

  tr1 := NULL_RECT;
  tr2 := NULL_RECT;
  For i := 0 To LOWERBOUND - 1 Do
  Begin
    indx := sl.valAt( i );
    If indx = BUCKETSIZE Then
      tr1 := Extent_rect( tr1, newRect )
    Else
      tr1 := Extent_rect( tr1, Data.Entries[indx].R );

    indx := sl.valAt( BUCKETSIZE - i );
    If indx = BUCKETSIZE Then
      tr2 := Extent_rect( tr2, newRect )
    Else
      tr2 := Extent_rect( tr2, Data.Entries[indx].R );
  End;

  dTab[0].mbr1 := tr1;
  dTab[DSIZE - 1].mbr2 := tr2;
  Ix1 := 1;
  Ix2 := DSIZE - 2;

  For i := LOWERBOUND To DSIZE + LOWERBOUND - 2 Do
  Begin

    indx := sl.valAt( i );
    If indx = BUCKETSIZE Then
      r := newRect
    Else
      r := Data.Entries[indx].R;
    dTab[Ix1].mbr1 := Extent_rect( dTab[Ix1 - 1].mbr1, r );

    indx := sl.valAt( BUCKETSIZE - i );
    If indx = BUCKETSIZE Then
      r := newRect
    Else
      r := Data.Entries[indx].R;
    dTab[Ix2].mbr2 := Extent_rect( dTab[Ix2 + 1].mbr2, r );

    inc( Ix1 );
    dec( Ix2 );

  End;

  i := 0;
  Ix1 := 0;
  While i < DSIZE Do
  Begin
    dTab[Ix1].margin := Margin_rect( dTab[Ix1].mbr1 ) + Margin_rect( dTab[Ix1].mbr2 );
    inc( Ix1 );
    inc( i );
  End;
End;

Function TRSTNode.evalOverlap( Var dTab: Array Of TDistribution ): integer;
Var
  i, min: integer;
  mino, mina: double;
Begin

  For i := 0 To DSIZE - 1 Do
  Begin
    dTab[i].overlap := Area_rect( Intersect_rect( dTab[i].mbr1, dTab[i].mbr2 ) );
    dTab[i].area := Area_rect( Extent_rect( dTab[i].mbr1, dTab[i].mbr2 ) );
  End;

  min := 0;
  mino := dTab[0].overlap;
  mina := dTab[0].area;
  For i := 1 To DSIZE - 1 Do
    If ( dTab[i].overlap < mino ) Or ( dTab[i].overlap = mino ) And ( dTab[i].area < mina ) Then
    Begin
      min := i;
      mino := dTab[i].overlap;
      mina := dTab[i].area;
    End;

  result := min;
End;
{$ENDIF}

// TOList - class implementation

Constructor TOList.Create;
Begin
  Inherited Create;
  Curr := Nil;
  Head := Nil;
  Tail := Nil;
End;

Destructor TOList.destroy;
Begin
  Zap;
  Inherited Destroy;
End;

// Destroy the elements currently in the list.

Procedure TOList.Zap;
Var
  p: POLstElem;
Begin

  While Head <> Nil Do
  Begin
    p := Head;
    Head := Head.Next;
    dispose( p );
  End;
  Tail := Nil;
  Curr := Nil;
End;

// Reposition the current pointer at the Head;

Procedure TOList.Rewind;
Begin
  Curr := Head;
End;

// Insert to tail

Function TOList.Insert( o: Longint; Const r: TRect_rt ): integer;
Var
  p: POLstElem;
Begin
  New( p );

  p.obj := o;
  p.r := r;
  p.lev := 0;
  p.Next := Nil;

  If Tail <> Nil Then
    Tail.Next := p;
  If Head = Nil Then
    Head := p;
  Tail := p;

  Rewind;

  result := OK;
End;

Function TOList.Insertl( o: Longint; Const r: TRect_rt; l: integer ): integer;
Var
  p: POLstElem;
Begin
  new( p );

  p.obj := o;
  p.r := r;
  p.lev := l;
  p.Next := Nil;

  If Tail <> Nil Then
    Tail.Next := p;
  If Head = Nil Then
    Head := p;
  Tail := p;

  Rewind;

  result := OK;
End;

// Fetch from head.

Function TOList.FetchORL( Var o: Longint; Var r: TRect_rt; Var l: integer ): integer;
Begin
  If Curr = Nil Then
  Begin
    result := TREE_ERROR;
    exit;
  End;

  o := Curr.obj;
  r := Curr.r;
  l := Curr.lev;
  Curr := Curr.Next;

  result := OK;
End;

// Fetch from head.

Function TOList.FetchOR( Var o: Longint; Var r: TRect_rt ): integer;
Begin
  If Curr = Nil Then
  Begin
    result := TREE_ERROR;
    exit;
  End;

  o := Curr.obj;
  r := Curr.r;
  Curr := Curr.Next;

  result := OK;
End;

// Delete from Head, return the OID

Function TOList.FetchO: Longint;
Var
  o: Longint;
Begin
  If Curr = Nil Then
  Begin
    result := TREE_ERROR;
    exit;
  End;

  o := Curr.obj;
  Curr := Curr.Next;

  result := o;
End;

// Delete from Head, return the rect

Function TOList.FetchR: TRect_rt;
Begin

  result := Curr.r;
  Curr := Curr.Next;

End;

Function TOList.isEmpty: boolean;
Begin
  result := ( Curr = Nil );
End;

{ TSearchList }

Constructor TSearchList.Create( RecCount: Integer );
Begin
  Inherited Create;
  b := TBits.Create;
  b.Size := RecCount + 1;
  MinRecno := RecCount;
  MaxRecno := 0;
End;

Destructor TSearchList.Destroy;
Begin
  b.free;
  Inherited Destroy;
End;

Procedure TSearchList.Add( Recno: Integer );
Begin
  b[Recno] := true;
  Inc( ReferenceCount );
  If Recno < MinRecno Then
    MinRecno := Recno;
  If Recno > MaxRecno Then
    MaxRecno := Recno;
End;

End.