ext/rtree/rtree_util.tcl

   1 # 2008 Feb 19
   2 #
   3 # The author disclaims copyright to this source code.  In place of
   4 # a legal notice, here is a blessing:
   5 #
   6 #    May you do good and not evil.
   7 #    May you find forgiveness for yourself and forgive others.
   8 #    May you share freely, never taking more than you give.
   9 #
  10 #***********************************************************************
  11 #
  12 # This file contains Tcl code that may be useful for testing or
  13 # analyzing r-tree structures created with this module. It is
  14 # used by both test procedures and the r-tree viewer application.
  15 #
  16
  17
  18 #--------------------------------------------------------------------------
  19 # PUBLIC API:
  20 #
  21 #   rtree_depth
  22 #   rtree_ndim
  23 #   rtree_node
  24 #   rtree_mincells
  25 #   rtree_check
  26 #   rtree_dump
  27 #   rtree_treedump
  28 #
  29
  30 proc rtree_depth {db zTab} {
  31   $db one "SELECT rtreedepth(data) FROM ${zTab}_node WHERE nodeno=1"
  32 }
  33
  34 proc rtree_nodedepth {db zTab iNode} {
  35   set iDepth [rtree_depth $db $zTab]
  36
  37   set ii $iNode
  38   while {$ii != 1} {
  39     set sql "SELECT parentnode FROM ${zTab}_parent WHERE nodeno = $ii"
  40     set ii [db one $sql]
  41     incr iDepth -1
  42   }
  43
  44   return $iDepth
  45 }
  46
  47 # Return the number of dimensions of the rtree.
  48 #
  49 proc rtree_ndim {db zTab} {
  50   set nDim [expr {(([llength [$db eval "pragma table_info($zTab)"]]/6)-1)/2}]
  51 }
  52
  53 # Return the contents of rtree node $iNode.
  54 #
  55 proc rtree_node {db zTab iNode {iPrec 6}} {
  56   set nDim [rtree_ndim $db $zTab]
  57   set sql "
  58     SELECT rtreenode($nDim, data) FROM ${zTab}_node WHERE nodeno = $iNode
  59   "
  60   set node [db one $sql]
  61
  62   set nCell [llength $node]
  63   set nCoord [expr $nDim*2]
  64   for {set ii 0} {$ii < $nCell} {incr ii} {
  65     for {set jj 1} {$jj <= $nCoord} {incr jj} {
  66       set newval [format "%.${iPrec}f" [lindex $node $ii $jj]]
  67       lset node $ii $jj $newval
  68     }
  69   }
  70   set node
  71 }
  72
  73 proc rtree_mincells {db zTab} {
  74   set n [$db one "select length(data) FROM ${zTab}_node LIMIT 1"]
  75   set nMax [expr {int(($n-4)/(8+[rtree_ndim $db $zTab]*2*4))}]
  76   return [expr {int($nMax/3)}]
  77 }
  78
  79 # An integrity check for the rtree $zTab accessible via database
  80 # connection $db.
  81 #
  82 proc rtree_check {db zTab} {
  83   array unset ::checked
  84
  85   # Check each r-tree node.
  86   set rc [catch {
  87     rtree_node_check $db $zTab 1 [rtree_depth $db $zTab]
  88   } msg]
  89   if {$rc && $msg ne ""} { error $msg }
  90
  91   # Check that the _rowid and _parent tables have the right
  92   # number of entries.
  93   set nNode   [$db one "SELECT count(*) FROM ${zTab}_node"]
  94   set nRow    [$db one "SELECT count(*) FROM ${zTab}"]
  95   set nRowid  [$db one "SELECT count(*) FROM ${zTab}_rowid"]
  96   set nParent [$db one "SELECT count(*) FROM ${zTab}_parent"]
  97
  98   if {$nNode != ($nParent+1)} {
  99     error "Wrong number of entries in ${zTab}_parent"
 100   }
 101   if {$nRow != $nRowid} {
 102     error "Wrong number of entries in ${zTab}_rowid"
 103   }
 104
 105   return $rc
 106 }
 107
 108 proc rtree_node_check {db zTab iNode iDepth} {
 109   if {[info exists ::checked($iNode)]} { error "Second ref to $iNode" }
 110   set ::checked($iNode) 1
 111
 112   set node [rtree_node $db $zTab $iNode]
 113   if {$iNode!=1 && [llength $node]==0} { error "No such node: $iNode" }
 114
 115   if {$iNode != 1 && [llength $node]<[rtree_mincells $db $zTab]} {
 116     puts "Node $iNode: Has only [llength $node] cells"
 117     error ""
 118   }
 119   if {$iNode == 1 && [llength $node]==1 && [rtree_depth $db $zTab]>0} {
 120     set depth [rtree_depth $db $zTab]
 121     puts "Node $iNode: Has only 1 child (tree depth is $depth)"
 122     error ""
 123   }
 124
 125   set nDim [expr {([llength [lindex $node 0]]-1)/2}]
 126
 127   if {$iDepth > 0} {
 128     set d [expr $iDepth-1]
 129     foreach cell $node {
 130       set shouldbe [rtree_node_check $db $zTab [lindex $cell 0] $d]
 131       if {$cell ne $shouldbe} {
 132         puts "Node $iNode: Cell is: {$cell}, should be {$shouldbe}"
 133         error ""
 134       }
 135     }
 136   }
 137
 138   set mapping_table "${zTab}_parent"
 139   set mapping_sql "SELECT parentnode FROM $mapping_table WHERE rowid = \$rowid"
 140   if {$iDepth==0} {
 141     set mapping_table "${zTab}_rowid"
 142     set mapping_sql "SELECT nodeno FROM $mapping_table WHERE rowid = \$rowid"
 143   }
 144   foreach cell $node {
 145     set rowid [lindex $cell 0]
 146     set mapping [db one $mapping_sql]
 147     if {$mapping != $iNode} {
 148       puts "Node $iNode: $mapping_table entry for cell $rowid is $mapping"
 149       error ""
 150     }
 151   }
 152
 153   set ret [list $iNode]
 154   for {set ii 1} {$ii <= $nDim*2} {incr ii} {
 155     set f [lindex $node 0 $ii]
 156     foreach cell $node {
 157       set f2 [lindex $cell $ii]
 158       if {($ii%2)==1 && $f2<$f} {set f $f2}
 159       if {($ii%2)==0 && $f2>$f} {set f $f2}
 160     }
 161     lappend ret $f
 162   }
 163   return $ret
 164 }
 165
 166 proc rtree_dump {db zTab} {
 167   set zRet ""
 168   set nDim [expr {(([llength [$db eval "pragma table_info($zTab)"]]/6)-1)/2}]
 169   set sql "SELECT nodeno, rtreenode($nDim, data) AS node FROM ${zTab}_node"
 170   $db eval $sql {
 171     append zRet [format "% -10s %s\n" $nodeno $node]
 172   }
 173   set zRet
 174 }
 175
 176 proc rtree_nodetreedump {db zTab zIndent iDepth iNode} {
 177   set ret ""
 178   set node [rtree_node $db $zTab $iNode 1]
 179   append ret [format "%-3d %s%s\n" $iNode $zIndent $node]
 180   if {$iDepth>0} {
 181     foreach cell $node {
 182       set i [lindex $cell 0]
 183       append ret [rtree_nodetreedump $db $zTab "$zIndent  " [expr $iDepth-1] $i]
 184     }
 185   }
 186   set ret
 187 }
 188
 189 proc rtree_treedump {db zTab} {
 190   set d [rtree_depth $db $zTab]
 191   rtree_nodetreedump $db $zTab "" $d 1
 192 }
 193
 194 proc do_rtree_integrity_test {tn tbl} {
 195   uplevel [list do_execsql_test $tn.1 "SELECT rtreecheck('$tbl')" ok]
 196   uplevel [list do_execsql_test $tn.2 "PRAGMA integrity_check" ok]
 197 }