OLD | NEW |
| (Empty) |
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 } | |
OLD | NEW |