# 2008 Feb 19 # # The author disclaims copyright to this source code. In place of # a legal notice, here is a blessing: # # May you do good and not evil. # May you find forgiveness for yourself and forgive others. # May you share freely, never taking more than you give. # #*********************************************************************** # # This file contains Tcl code that may be useful for testing or # analyzing r-tree structures created with this module. It is # used by both test procedures and the r-tree viewer application. # #-------------------------------------------------------------------------- # PUBLIC API: # # rtree_depth # rtree_ndim # rtree_node # rtree_mincells # rtree_check # rtree_dump # rtree_treedump # proc rtree_depth {db zTab} { $db one "SELECT rtreedepth(data) FROM ${zTab}_node WHERE nodeno=1" } proc rtree_nodedepth {db zTab iNode} { set iDepth [rtree_depth $db $zTab] set ii $iNode while {$ii != 1} { set sql "SELECT parentnode FROM ${zTab}_parent WHERE nodeno = $ii" set ii [db one $sql] incr iDepth -1 } return $iDepth } # Return the number of dimensions of the rtree. # proc rtree_ndim {db zTab} { set nDim [expr {(([llength [$db eval "pragma table_info($zTab)"]]/6)-1)/2}] } # Return the contents of rtree node $iNode. # proc rtree_node {db zTab iNode {iPrec 6}} { set nDim [rtree_ndim $db $zTab] set sql " SELECT rtreenode($nDim, data) FROM ${zTab}_node WHERE nodeno = $iNode " set node [db one $sql] set nCell [llength $node] set nCoord [expr $nDim*2] for {set ii 0} {$ii < $nCell} {incr ii} { for {set jj 1} {$jj <= $nCoord} {incr jj} { set newval [format "%.${iPrec}f" [lindex $node $ii $jj]] lset node $ii $jj $newval } } set node } proc rtree_mincells {db zTab} { set n [$db one "select length(data) FROM ${zTab}_node LIMIT 1"] set nMax [expr {int(($n-4)/(8+[rtree_ndim $db $zTab]*2*4))}] return [expr {int($nMax/3)}] } # An integrity check for the rtree $zTab accessible via database # connection $db. # proc rtree_check {db zTab} { array unset ::checked # Check each r-tree node. set rc [catch { rtree_node_check $db $zTab 1 [rtree_depth $db $zTab] } msg] if {$rc && $msg ne ""} { error $msg } # Check that the _rowid and _parent tables have the right # number of entries. set nNode [$db one "SELECT count(*) FROM ${zTab}_node"] set nRow [$db one "SELECT count(*) FROM ${zTab}"] set nRowid [$db one "SELECT count(*) FROM ${zTab}_rowid"] set nParent [$db one "SELECT count(*) FROM ${zTab}_parent"] if {$nNode != ($nParent+1)} { error "Wrong number of entries in ${zTab}_parent" } if {$nRow != $nRowid} { error "Wrong number of entries in ${zTab}_rowid" } return $rc } proc rtree_node_check {db zTab iNode iDepth} { if {[info exists ::checked($iNode)]} { error "Second ref to $iNode" } set ::checked($iNode) 1 set node [rtree_node $db $zTab $iNode] if {$iNode!=1 && [llength $node]==0} { error "No such node: $iNode" } if {$iNode != 1 && [llength $node]<[rtree_mincells $db $zTab]} { puts "Node $iNode: Has only [llength $node] cells" error "" } if {$iNode == 1 && [llength $node]==1 && [rtree_depth $db $zTab]>0} { set depth [rtree_depth $db $zTab] puts "Node $iNode: Has only 1 child (tree depth is $depth)" error "" } set nDim [expr {([llength [lindex $node 0]]-1)/2}] if {$iDepth > 0} { set d [expr $iDepth-1] foreach cell $node { set shouldbe [rtree_node_check $db $zTab [lindex $cell 0] $d] if {$cell ne $shouldbe} { puts "Node $iNode: Cell is: {$cell}, should be {$shouldbe}" error "" } } } set mapping_table "${zTab}_parent" set mapping_sql "SELECT parentnode FROM $mapping_table WHERE rowid = \$rowid" if {$iDepth==0} { set mapping_table "${zTab}_rowid" set mapping_sql "SELECT nodeno FROM $mapping_table WHERE rowid = \$rowid" } foreach cell $node { set rowid [lindex $cell 0] set mapping [db one $mapping_sql] if {$mapping != $iNode} { puts "Node $iNode: $mapping_table entry for cell $rowid is $mapping" error "" } } set ret [list $iNode] for {set ii 1} {$ii <= $nDim*2} {incr ii} { set f [lindex $node 0 $ii] foreach cell $node { set f2 [lindex $cell $ii] if {($ii%2)==1 && $f2<$f} {set f $f2} if {($ii%2)==0 && $f2>$f} {set f $f2} } lappend ret $f } return $ret } proc rtree_dump {db zTab} { set zRet "" set nDim [expr {(([llength [$db eval "pragma table_info($zTab)"]]/6)-1)/2}] set sql "SELECT nodeno, rtreenode($nDim, data) AS node FROM ${zTab}_node" $db eval $sql { append zRet [format "% -10s %s\n" $nodeno $node] } set zRet } proc rtree_nodetreedump {db zTab zIndent iDepth iNode} { set ret "" set node [rtree_node $db $zTab $iNode 1] append ret [format "%-3d %s%s\n" $iNode $zIndent $node] if {$iDepth>0} { foreach cell $node { set i [lindex $cell 0] append ret [rtree_nodetreedump $db $zTab "$zIndent " [expr $iDepth-1] $i] } } set ret } proc rtree_treedump {db zTab} { set d [rtree_depth $db $zTab] rtree_nodetreedump $db $zTab "" $d 1 } proc do_rtree_integrity_test {tn tbl} { uplevel [list do_execsql_test $tn "SELECT rtreecheck('$tbl')" ok] }