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
30proc rtree_depth {db zTab} {
31  $db one "SELECT rtreedepth(data) FROM ${zTab}_node WHERE nodeno=1"
32}
33
34proc 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#
49proc 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#
55proc 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
73proc 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#
82proc 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
108proc 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
166proc 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
176proc 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
189proc rtree_treedump {db zTab} {
190  set d [rtree_depth $db $zTab]
191  rtree_nodetreedump $db $zTab "" $d 1
192}
193