ext/rtree/rtreedoc3.test

   1 # 2021 September 13
   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 # The focus of this file is testing the r-tree extension.
  13 #
  14
  15 if {![info exists testdir]} {
  16   set testdir [file join [file dirname [info script]] .. .. test]
  17 }
  18 source [file join [file dirname [info script]] rtree_util.tcl]
  19 source $testdir/tester.tcl
  20 set testprefix rtreedoc3
  21
  22 ifcapable !rtree {
  23   finish_test
  24   return
  25 }
  26
  27
  28 # This command assumes that the argument is a node blob for a 2 dimensional
  29 # i32 r-tree table. It decodes and returns a list of cells from the node
  30 # as a list. Each cell is itself a list of the following form:
  31 #
  32 #    {$rowid $minX $maxX $minY $maxY}
  33 #
  34 # For internal (non-leaf) nodes, the rowid is replaced by the child node
  35 # number.
  36 #
  37 proc rnode_cells {aData} {
  38   set nDim 2
  39
  40   set nData [string length $aData]
  41   set nBytePerCell [expr (8 + 2*$nDim*4)]
  42   binary scan [string range $aData 2 3] S nCell
  43
  44   set res [list]
  45   for {set i 0} {$i < $nCell} {incr i} {
  46     set iOff [expr $i*$nBytePerCell+4]
  47     set cell [string range $aData $iOff [expr $iOff+$nBytePerCell-1]]
  48     binary scan $cell WIIII rowid x1 x2 y1 y2
  49     lappend res [list $rowid $x1 $x2 $y1 $y2]
  50   }
  51
  52   return $res
  53 }
  54
  55 # Interpret the first two bytes of the blob passed as the only parameter
  56 # as a 16-bit big-endian integer and return the value. If this blob is
  57 # the root node of an r-tree, this value is the height of the tree.
  58 #
  59 proc rnode_height {aData} {
  60   binary scan [string range $aData 0 1] S nHeight
  61   return $nHeight
  62 }
  63
  64 # Return a blob containing node iNode of r-tree "rt".
  65 #
  66 proc rt_node_get {iNode} {
  67   db one { SELECT data FROM rt_node WHERE nodeno=$iNode }
  68 }
  69
  70
  71 #--------------------------------------------------------------
  72 # API:
  73 #
  74 #    pq_init
  75 #      Initialize a new test.
  76 #
  77 #    pq_test_callback
  78 #      Invoked each time the xQueryCallback function is called. This Tcl
  79 #      command checks that the arguments that SQLite passed to xQueryCallback
  80 #      are as expected.
  81 #
  82 #    pq_test_row
  83 #      Invoked each time a row is returned. Checks that the row returned
  84 #      was predicted by the documentation.
  85 #
  86 # DATA STRUCTURE:
  87 #    The priority queue is stored as a Tcl list. The order of elements in
  88 #    the list is unimportant - it is just used as a set here. Each element
  89 #    in the priority queue is itself a list. The first element is the
  90 #    priority value for the entry (a real). Following this is a list of
  91 #    key-value pairs that make up the entries fields.
  92 #
  93 proc pq_init {} {
  94   global Q
  95   set Q(pri_queue)  [list]
  96
  97   set nHeight [rnode_height [rt_node_get 1]]
  98   set nCell [llength [rnode_cells [rt_node_get 1]]]
  99
 100   # EVIDENCE-OF: R-54708-13595 An R*Tree query is initialized by making
 101   # the root node the only entry in a priority queue sorted by rScore.
 102   lappend Q(pri_queue) [list 0.0 [list \
 103     iLevel [expr $nHeight+1] \
 104     iChild 1                 \
 105     iCurrent   0             \
 106   ]]
 107 }
 108
 109 proc pq_extract {} {
 110   global Q
 111   if {[llength $Q(pri_queue)]==0} {
 112     error "priority queue is empty!"
 113   }
 114
 115   # Find the priority queue entry with the lowest score.
 116   #
 117   # EVIDENCE-OF: R-47257-47871 Smaller scores are processed first.
 118   set iBest 0
 119   set rBestScore [lindex $Q(pri_queue) 0 0]
 120   for {set ii 1} {$ii < [llength $Q(pri_queue)]} {incr ii} {
 121     set rScore [expr [lindex $Q(pri_queue) $ii 0]]
 122     if {$rScore<$rBestScore} {
 123       set rBestScore $rScore
 124       set iBest $ii
 125     }
 126   }
 127
 128   # Extract the entry with the lowest score from the queue and return it.
 129   #
 130   # EVIDENCE-OF: R-60002-49798 The query proceeds by extracting the entry
 131   # from the priority queue that has the lowest score.
 132   set ret [lindex $Q(pri_queue) $iBest]
 133   set Q(pri_queue) [lreplace $Q(pri_queue) $iBest $iBest]
 134
 135   return $ret
 136 }
 137
 138 proc pq_new_entry {rScore iLevel cell} {
 139   global Q
 140
 141   set rowid_name "iChild"
 142   if {$iLevel==0} { set rowid_name "iRowid" }
 143
 144   set kv [list]
 145   lappend kv aCoord [lrange $cell 1 end]
 146   lappend kv iLevel $iLevel
 147
 148   if {$iLevel==0} {
 149     lappend kv iRowid [lindex $cell 0]
 150   } else {
 151     lappend kv iChild [lindex $cell 0]
 152     lappend kv iCurrent 0
 153   }
 154
 155   lappend Q(pri_queue) [list $rScore $kv]
 156 }
 157
 158 proc pq_test_callback {L res} {
 159   #pq_debug "pq_test_callback $L -> $res"
 160   global Q
 161
 162   array set G $L    ;# "Got" - as in stuff passed to xQuery
 163
 164   # EVIDENCE-OF: R-65127-42665 If the extracted priority queue entry is a
 165   # node (a subtree), then the next child of that node is passed to the
 166   # xQueryFunc callback.
 167   #
 168   # If it had been a leaf, the row should have been returned, instead of
 169   # xQueryCallback being called on a child - as is happening here.
 170   foreach {rParentScore parent} [pq_extract] {}
 171   array set P $parent ;# "Parent" - as in parent of expected cell
 172   if {$P(iLevel)==0} { error "query callback mismatch (1)" }
 173   set child_node [rnode_cells [rt_node_get $P(iChild)]]
 174   set expected_cell [lindex $child_node $P(iCurrent)]
 175   set expected_coords [lrange $expected_cell 1 end]
 176   if {[llength $expected_coords] != [llength $G(aCoord)]} {
 177   puts [array get P]
 178   puts "E: $expected_coords  G: $G(aCoord)"
 179     error "coordinate mismatch in query callback (1)"
 180   }
 181   foreach a [lrange $expected_cell 1 end] b $G(aCoord) {
 182     if {$a!=$b} { error "coordinate mismatch in query callback (2)" }
 183   }
 184
 185   # Check level is as expected
 186   #
 187   if {$G(iLevel) != $P(iLevel)-1} {
 188     error "iLevel mismatch in query callback (1)"
 189   }
 190
 191   # Unless the callback returned NOT_WITHIN, add the entry to the priority
 192   # queue.
 193   #
 194   # EVIDENCE-OF: R-28754-35153 Those subelements for which the xQueryFunc
 195   # callback sets eWithin to PARTLY_WITHIN or FULLY_WITHIN are added to
 196   # the priority queue using the score supplied by the callback.
 197   #
 198   # EVIDENCE-OF: R-08681-45277 Subelements that return NOT_WITHIN are
 199   # discarded.
 200   set r [lindex $res 0]
 201   set rScore [lindex $res 1]
 202   if {$r!="fully" && $r!="partly" && $r!="not"} {
 203     error "unknown result: $r - expected \"fully\", \"partly\" or \"not\""
 204   }
 205   if {$r!="not"} {
 206     pq_new_entry $rScore [expr $P(iLevel)-1] $expected_cell
 207   }
 208
 209   # EVIDENCE-OF: R-07194-63805 If the node has more children then it is
 210   # returned to the priority queue. Otherwise it is discarded.
 211   incr P(iCurrent)
 212   if {$P(iCurrent)<[llength $child_node]} {
 213     lappend Q(pri_queue) [list $rParentScore [array get P]]
 214   }
 215 }
 216
 217 proc pq_test_result {id x1 x2 y1 y2} {
 218   #pq_debug "pq_test_result $id $x1 $x2 $y1 $y2"
 219   foreach {rScore next} [pq_extract] {}
 220
 221   # The extracted entry must be a leaf (otherwise, xQueryCallback would
 222   # have been called on the extracted entries children instead of just
 223   # returning the data).
 224   #
 225   # EVIDENCE-OF: R-13214-54017 If that entry is a leaf (meaning that it is
 226   # an actual R*Tree entry and not a subtree) then that entry is returned
 227   # as one row of the query result.
 228   array set N $next
 229   if {$N(iLevel)!=0} { error "result row mismatch (1)" }
 230
 231   if {$x1!=[lindex $N(aCoord) 0] || $x2!=[lindex $N(aCoord) 1]
 232    || $y1!=[lindex $N(aCoord) 2] || $y2!=[lindex $N(aCoord) 3]
 233   } {
 234     if {$N(iLevel)!=0} { error "result row mismatch (2)" }
 235   }
 236
 237   if {$id!=$N(iRowid)} { error "result row mismatch (3)" }
 238 }
 239
 240 proc pq_done {} {
 241   global Q
 242   # EVIDENCE-OF: R-57438-45968 The query runs until the priority queue is
 243   # empty.
 244   if {[llength $Q(pri_queue)]>0} {
 245     error "priority queue is not empty!"
 246   }
 247 }
 248
 249 proc pq_debug {caption} {
 250   global Q
 251
 252   puts "**** $caption ****"
 253   set i 0
 254   foreach q [lsort -real -index 0 $Q(pri_queue)] {
 255     puts "PQ $i: $q"
 256     incr i
 257   }
 258 }
 259
 260 #--------------------------------------------------------------
 261
 262 proc box_query {a} {
 263   set res [list fully [expr rand()]]
 264   pq_test_callback $a $res
 265   return $res
 266 }
 267
 268 register_box_query db box_query
 269
 270 do_execsql_test 1.0 {
 271   CREATE VIRTUAL TABLE rt USING rtree_i32(id,  x1,x2,  y1,y2);
 272   WITH s(i) AS (
 273     SELECT 0 UNION ALL SELECT i+1 FROM s WHERE i<64
 274   )
 275   INSERT INTO rt SELECT NULL, a.i, a.i+1, b.i, b.i+1 FROM s a, s b;
 276 }
 277
 278 proc box_query {a} {
 279   set res [list fully [expr rand()]]
 280   pq_test_callback $a $res
 281   return $res
 282 }
 283
 284 pq_init
 285 db eval { SELECT id, x1,x2, y1,y2 FROM rt WHERE id MATCH qbox() } {
 286   pq_test_result $id $x1 $x2 $y1 $y2
 287 }
 288 pq_done
 289
 290 finish_test
 291
 292