diff options
Diffstat (limited to 'ext/rtree/rtreedoc3.test')
| -rw-r--r-- | ext/rtree/rtreedoc3.test | 292 |
1 files changed, 292 insertions, 0 deletions
diff --git a/ext/rtree/rtreedoc3.test b/ext/rtree/rtreedoc3.test new file mode 100644 index 0000000..0403409 --- /dev/null +++ b/ext/rtree/rtreedoc3.test @@ -0,0 +1,292 @@ +# 2021 September 13 +# +# 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. +# +#*********************************************************************** +# +# The focus of this file is testing the r-tree extension. +# + +if {![info exists testdir]} { + set testdir [file join [file dirname [info script]] .. .. test] +} +source [file join [file dirname [info script]] rtree_util.tcl] +source $testdir/tester.tcl +set testprefix rtreedoc3 + +ifcapable !rtree { + finish_test + return +} + + +# This command assumes that the argument is a node blob for a 2 dimensional +# i32 r-tree table. It decodes and returns a list of cells from the node +# as a list. Each cell is itself a list of the following form: +# +# {$rowid $minX $maxX $minY $maxY} +# +# For internal (non-leaf) nodes, the rowid is replaced by the child node +# number. +# +proc rnode_cells {aData} { + set nDim 2 + + set nData [string length $aData] + set nBytePerCell [expr (8 + 2*$nDim*4)] + binary scan [string range $aData 2 3] S nCell + + set res [list] + for {set i 0} {$i < $nCell} {incr i} { + set iOff [expr $i*$nBytePerCell+4] + set cell [string range $aData $iOff [expr $iOff+$nBytePerCell-1]] + binary scan $cell WIIII rowid x1 x2 y1 y2 + lappend res [list $rowid $x1 $x2 $y1 $y2] + } + + return $res +} + +# Interpret the first two bytes of the blob passed as the only parameter +# as a 16-bit big-endian integer and return the value. If this blob is +# the root node of an r-tree, this value is the height of the tree. +# +proc rnode_height {aData} { + binary scan [string range $aData 0 1] S nHeight + return $nHeight +} + +# Return a blob containing node iNode of r-tree "rt". +# +proc rt_node_get {iNode} { + db one { SELECT data FROM rt_node WHERE nodeno=$iNode } +} + + +#-------------------------------------------------------------- +# API: +# +# pq_init +# Initialize a new test. +# +# pq_test_callback +# Invoked each time the xQueryCallback function is called. This Tcl +# command checks that the arguments that SQLite passed to xQueryCallback +# are as expected. +# +# pq_test_row +# Invoked each time a row is returned. Checks that the row returned +# was predicted by the documentation. +# +# DATA STRUCTURE: +# The priority queue is stored as a Tcl list. The order of elements in +# the list is unimportant - it is just used as a set here. Each element +# in the priority queue is itself a list. The first element is the +# priority value for the entry (a real). Following this is a list of +# key-value pairs that make up the entries fields. +# +proc pq_init {} { + global Q + set Q(pri_queue) [list] + + set nHeight [rnode_height [rt_node_get 1]] + set nCell [llength [rnode_cells [rt_node_get 1]]] + + # EVIDENCE-OF: R-54708-13595 An R*Tree query is initialized by making + # the root node the only entry in a priority queue sorted by rScore. + lappend Q(pri_queue) [list 0.0 [list \ + iLevel [expr $nHeight+1] \ + iChild 1 \ + iCurrent 0 \ + ]] +} + +proc pq_extract {} { + global Q + if {[llength $Q(pri_queue)]==0} { + error "priority queue is empty!" + } + + # Find the priority queue entry with the lowest score. + # + # EVIDENCE-OF: R-47257-47871 Smaller scores are processed first. + set iBest 0 + set rBestScore [lindex $Q(pri_queue) 0 0] + for {set ii 1} {$ii < [llength $Q(pri_queue)]} {incr ii} { + set rScore [expr [lindex $Q(pri_queue) $ii 0]] + if {$rScore<$rBestScore} { + set rBestScore $rScore + set iBest $ii + } + } + + # Extract the entry with the lowest score from the queue and return it. + # + # EVIDENCE-OF: R-60002-49798 The query proceeds by extracting the entry + # from the priority queue that has the lowest score. + set ret [lindex $Q(pri_queue) $iBest] + set Q(pri_queue) [lreplace $Q(pri_queue) $iBest $iBest] + + return $ret +} + +proc pq_new_entry {rScore iLevel cell} { + global Q + + set rowid_name "iChild" + if {$iLevel==0} { set rowid_name "iRowid" } + + set kv [list] + lappend kv aCoord [lrange $cell 1 end] + lappend kv iLevel $iLevel + + if {$iLevel==0} { + lappend kv iRowid [lindex $cell 0] + } else { + lappend kv iChild [lindex $cell 0] + lappend kv iCurrent 0 + } + + lappend Q(pri_queue) [list $rScore $kv] +} + +proc pq_test_callback {L res} { + #pq_debug "pq_test_callback $L -> $res" + global Q + + array set G $L ;# "Got" - as in stuff passed to xQuery + + # EVIDENCE-OF: R-65127-42665 If the extracted priority queue entry is a + # node (a subtree), then the next child of that node is passed to the + # xQueryFunc callback. + # + # If it had been a leaf, the row should have been returned, instead of + # xQueryCallback being called on a child - as is happening here. + foreach {rParentScore parent} [pq_extract] {} + array set P $parent ;# "Parent" - as in parent of expected cell + if {$P(iLevel)==0} { error "query callback mismatch (1)" } + set child_node [rnode_cells [rt_node_get $P(iChild)]] + set expected_cell [lindex $child_node $P(iCurrent)] + set expected_coords [lrange $expected_cell 1 end] + if {[llength $expected_coords] != [llength $G(aCoord)]} { + puts [array get P] + puts "E: $expected_coords G: $G(aCoord)" + error "coordinate mismatch in query callback (1)" + } + foreach a [lrange $expected_cell 1 end] b $G(aCoord) { + if {$a!=$b} { error "coordinate mismatch in query callback (2)" } + } + + # Check level is as expected + # + if {$G(iLevel) != $P(iLevel)-1} { + error "iLevel mismatch in query callback (1)" + } + + # Unless the callback returned NOT_WITHIN, add the entry to the priority + # queue. + # + # EVIDENCE-OF: R-28754-35153 Those subelements for which the xQueryFunc + # callback sets eWithin to PARTLY_WITHIN or FULLY_WITHIN are added to + # the priority queue using the score supplied by the callback. + # + # EVIDENCE-OF: R-08681-45277 Subelements that return NOT_WITHIN are + # discarded. + set r [lindex $res 0] + set rScore [lindex $res 1] + if {$r!="fully" && $r!="partly" && $r!="not"} { + error "unknown result: $r - expected \"fully\", \"partly\" or \"not\"" + } + if {$r!="not"} { + pq_new_entry $rScore [expr $P(iLevel)-1] $expected_cell + } + + # EVIDENCE-OF: R-07194-63805 If the node has more children then it is + # returned to the priority queue. Otherwise it is discarded. + incr P(iCurrent) + if {$P(iCurrent)<[llength $child_node]} { + lappend Q(pri_queue) [list $rParentScore [array get P]] + } +} + +proc pq_test_result {id x1 x2 y1 y2} { + #pq_debug "pq_test_result $id $x1 $x2 $y1 $y2" + foreach {rScore next} [pq_extract] {} + + # The extracted entry must be a leaf (otherwise, xQueryCallback would + # have been called on the extracted entries children instead of just + # returning the data). + # + # EVIDENCE-OF: R-13214-54017 If that entry is a leaf (meaning that it is + # an actual R*Tree entry and not a subtree) then that entry is returned + # as one row of the query result. + array set N $next + if {$N(iLevel)!=0} { error "result row mismatch (1)" } + + if {$x1!=[lindex $N(aCoord) 0] || $x2!=[lindex $N(aCoord) 1] + || $y1!=[lindex $N(aCoord) 2] || $y2!=[lindex $N(aCoord) 3] + } { + if {$N(iLevel)!=0} { error "result row mismatch (2)" } + } + + if {$id!=$N(iRowid)} { error "result row mismatch (3)" } +} + +proc pq_done {} { + global Q + # EVIDENCE-OF: R-57438-45968 The query runs until the priority queue is + # empty. + if {[llength $Q(pri_queue)]>0} { + error "priority queue is not empty!" + } +} + +proc pq_debug {caption} { + global Q + + puts "**** $caption ****" + set i 0 + foreach q [lsort -real -index 0 $Q(pri_queue)] { + puts "PQ $i: $q" + incr i + } +} + +#-------------------------------------------------------------- + +proc box_query {a} { + set res [list fully [expr rand()]] + pq_test_callback $a $res + return $res +} + +register_box_query db box_query + +do_execsql_test 1.0 { + CREATE VIRTUAL TABLE rt USING rtree_i32(id, x1,x2, y1,y2); + WITH s(i) AS ( + SELECT 0 UNION ALL SELECT i+1 FROM s WHERE i<64 + ) + INSERT INTO rt SELECT NULL, a.i, a.i+1, b.i, b.i+1 FROM s a, s b; +} + +proc box_query {a} { + set res [list fully [expr rand()]] + pq_test_callback $a $res + return $res +} + +pq_init +db eval { SELECT id, x1,x2, y1,y2 FROM rt WHERE id MATCH qbox() } { + pq_test_result $id $x1 $x2 $y1 $y2 +} +pq_done + +finish_test + + |