# 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