# 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.
#
# $Id: rtree_util.tcl,v 1.1 2008/05/26 18:41:54 danielk1977 Exp $
#
#--------------------------------------------------------------------------
# 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
}