Artifact 62da66346bd2d1ae2bc5b4f752f02d1afd94fcc6:
- File
packages/struct/lib/tree/tree.tcl
— part of check-in
[1c252a3cd0]
at
2020-06-22 00:31:53
on branch trunk
— chan
new routines
carve
interpolate
keep
further development
best working version so far
notes
new routines
absorb addrspaceex
"eval" option to [ls]
"message" design for interactive output
add zip processing to [fin]
sqlite
lossless
work in progress
add test
string
printable
new interface
tree
much faster [last] and [pivot] routines
(user: pooryorick size: 101929)
#! /usr/bin/env tclsh package require {ycl proc} [yclprefix] proc alias alias [yclprefix] proc alias alias aliases [yclprefix] proc aliases aliases { {ycl list} { pop take } {ycl list deep} {ycl proc} { optswitch } {ycl db sqlite util} { explain_pretty idquote lossless makereport minpagesize } } package require {ycl sugar} namespace import [yclprefix]::sugar::block namespace import [yclprefix]::sugar::lambda variable doc { description a persistent tree data type in each tree node 0 is the system node where a command takes a node as an argument the node is a list where the first item is a node identifer any additional items are a list of nodes to pivot to some commands treat nodes objects where each subnode is an attribute the last subnode of the subnode is the value of the attribute a node has a node id internal use only may change track a node by linking to it, not by recording its node id if node id is ever updated the system also updates all links a value operations node add add a new node dest obtain the destintion of the node link make the node a reference to another node list obtain the list of nodes in a node path obtain the path to the node ref obtain the node this node references remove remove the node val get/set the value of the node view transform the node in some way relation resolve references system notify observe to do implement some mechanism to express the existence and value of a node in terms of other nodes this is similar to XSLT except that with XSLT document A is applied to document B to produce document C in the current system system existing sections of the document are applied to other sections of the document to produce the content of those sections } ::apply [list {} { set forgevariant iterpivot ### preprocessing start ### set givenscript { set arglen [llength $args] if {$arglen} { if {$arglen % 2} { set given {} set script [lindex $args end] set args [lreplace $args[set args {}] end end] } else { lassign [lrange $args end-1 end] given script set args [lreplace $args[set args {}] end-1 end] } } else { set given {} } if {[llength $given] > 1} { try { dict size $given } on error {tres topts} { if {[llength $given] > 1} { error [list {wrong # args} $given] } } set key $given } else { set key {} } } set nodepivot { if {[llength $node] > 1} { set node [$_ node pivot {*}$node] } else { lassign $node[set node {}] node } } foreach suffix {{} emptyerror} eval { { $_ db eval $query } { set res [$_ db eval $query] if {![llength $res]} { error [list {no results}] } return $res } } { try [string map [list @suffix@ $suffix @eval@ $eval] { if 0 { a script evaluation could have arbitrary effects on the database so it is treated as a transaction } set queryscript@suffix@ { if {[info exists script]} { if {![info exists qvals]} { set qvals {} } set ns [uplevel 1 {namespace current}] if {[llength $given] == 1} { # to do # add the transaction back when sqlite fixes the # segmentation fault issue # # see https://sqlite.org/forum/forumpost/4638e41470 #$_ db transaction { tailcall apply [list {_ node query qvals given script} { $_[unset _] db eval -withoutnulls $query $given $script[ dict with qvals {}] } $ns] $_ $node $query $qvals $given $script #} } else { #$_ db transaction { tailcall apply [list {_ node query qvals script} { $_[unset _] db eval -withoutnulls $query $script[ dict with qvals {}] } $ns] $_ $node $query $qvals $script #} } } else { @eval@ } } }] } ### preprocessing end ### try [string map [list @forgevariant@ $forgevariant @givenscript@ $givenscript \ @nodepivot@ $nodepivot @queryscript@ $queryscript] { package require sqlite3 package require {ycl cache cache} namespace import [yclprefix]::cache::cache package require {ycl string expand} namespace import [yclprefix]::string::expand package require {ycl parser interp} namespace import [yclprefix]::parser::interp::parse namespace import [yclprefix]::proc::lambda namespace import [yclprefix]::proc::lambdacurry package require {ycl db sqlite util} [yclprefix] proc import dbget [yclprefix]::db::sqlite::util::get [yclprefix] proc import strquote [yclprefix]::db::sqlite::util::gen::strquote [yclprefix] proc import table [yclprefix]::db::sqlite::util::table namespace eval doc::node {} proc pmap {p1 p2 cache spec argparse body} { if {$argparse eq {}} { set argparse { if {[llength $args]} { error [list {wrong # args}] } } } set pmap [string map [list \ @p1@ [list $p1] \ @p2@ [list $p2] \ @cache@ [list $cache] \ @spec@ [list $spec] \ @argparse@ $argparse ] { set query_node $@p1@ set query_top $@p2@ @givenscript@ @argparse@ set query [$_ @cache@ get [ list [expr {[llength $node] == 0}] [ expr {[llength $given] == 1}] $key] { if {[llength $node]} { set query $query_node } else { set query $query_top } if {[llength $given] == 1} { string map [makereport @spec@ {}] $query } else { string map [makereport @spec@ $given] $query } }] }] set body "\$_ .vars [list $p1] [list $p2]\n$body" set body [string map [list @pmap@ $pmap] $body] return $body } proc .init {. _ args} { variable q_templates $_ .vars dbitemprefix set dbitemprefix {} set dbcreate 0 foreach {opt val} $args { switch $opt { dbconn { if {[info exists dbname]} { error [list {both db connection and db name were provided}] } set dbconn [uplevel 1 [list [namespace which lambdacurry] {*}$val]] } dbname { if {[info exists dbconn]} { error [list {both db connection and db name were provided}] } set dbname $val } dbcreate { set dbcreate $val } dbitemprefix { set dbitemprefix $val } default { error [list {unknown option} $opt] } } } set myns [$_ .namespace] foreach name { convergecache convergevaluecache deeprefsunderothercache descendantsrefscache drothercache drupothercache excache findeq&cache findglob&cache findlike&cache findmatch&cache findregexp&cache forgecache ipath&cache leavescache leavesvaluecache leavesvaluecache linkscache lsandcache lscache lsemptycache lseq&cache lsfullcache lsglob&cache lslikecache lslike&cache lsnext&cache lsregexp&cache nodeappearscache nodrothercache nodelastcache nodelast&cache pathcache path&cache pathrefscache pivotcache refscache refsunderothercache tailcache traversecache underlinksfindeq&cache walkcache } { cache .new ${myns}::$name $_ .eval [list $_ .routine $name] $_ $name .init } if {[info exist dbconn]} { uplevel 1 [list $_ .routine db {*}$dbconn] } else { if {![info exists dbname]} { set dbname :memory: } set cmd [list sqlite3 [$_ .namespace]::db $dbname] if {!$dbcreate} { lappend cmd -create false } {*}$cmd $_ .eval [list $_ .routine db] } $_ db cache size 0 try [string map [list @@ $dbitemprefix] $q_templates] namespace ensemble create -prefixes 0 -command [$_ .namespace]::inode \ -parameters {. _} -map { path& inode_path& } $_ .eval [list $_ .method inode] namespace ensemble create -prefixes 0 -command [$_ .namespace]::descendants \ -parameters {. _} -map { refs descendants_refs referenced? descendants_referenced? } $_ .eval [list $_ .method descendants] namespace ensemble create -prefixes 0 -command [$_ .namespace]::node \ -parameters {. _} -map { appears& node_appears& back node_back back& node_back& clear node_clear clone node_clone converge node_converge converge& node_converge& count node_count cp node_cp ddict node_ddict deeprefsunder node_deeprefsunder dr node_dr drcount node_drcount depth node_depth dest node_dest down node_down down& node_down& downtoref node_downtoref edit node_edit editlink node_editlink examine node_examine empty? node_empty? exists node_exists findeq& node_findeq& findglob& node_findglob& findlike& node_findlike& findmatch& node_findmatch& findregexp& node_findregexp& forge node_forge id node_id idgt& node_idgt& islink node_islink islost node_islost last node_last last& node_last& last&? node_last&? leaves node_leaves leaves& node_leaves& link node_link links node_links linkval node_linkval ls node_ls ls& node_ls& lseq& node_lseq& lsglob& node_lsglob& lslike node_lslike lslike& node_lslike& lsempty& node_lsempty& lsfull& node_lsfull& lspart& node_lspart& lsregexp& node_lsregexp& move node_move new node_new next& node_next& forth node_forth forth& node_forth& highestid node_highestid nodr node_nodr path node_path path& node_path& pivot node_pivot pivot? node_pivot? pretty node_pretty read_deep node_readdeep referenced? node_referenced? refs node_refs refsunder node_refsunder repoint node_repoint rm node_rm rm? node_rm? route node_route pathrefs node_pathrefs set node_set setd node_setd target node_target traverse node_traverse tree node_tree tail& node_tail& under node_under under_links_findeq& node_under_links_findeq& up node_up up& node_up& val node_val valueid node_valueid walk node_walk } $_ .eval [list $_ .method node] namespace ensemble create -prefixes 0 -command [$_ .namespace]::value \ -parameters {. _} -map { get value_get } $_ .eval [list $_ .method value] namespace ensemble create -prefixes 0 -command [$_ .namespace]::values \ -parameters {. _} -map { count values_count } $_ .eval [list $_ .method values] $_ setupdb return $_ } .my .method .init proc accelerate {} { try { package require critcl } on error {tres topts} { puts stderr [list [namespace current] \ [dict get $topts -errorinfo] ] return 0 } critcl cproc [namespace current]::node_forge_c {Tcl_Interp* interp object __ object _ char* up list path} object { Tcl_Obj *res; res = Tcl_NewListObj(0 ,NULL); Tcl_ListObjAppendElement(interp ,res ,Tcl_NewObj()); Tcl_ListObjAppendElement(interp ,res ,Tcl_NewIntObj(1)); Tcl_IncrRefCount(res); return res; } .my .method node_forge_c try { critcl load } on error {tres topts} { puts stderr [list [namespace current] \ {could not accelerate} [dict get $topts -errorinfo] ] return 0 } return 1 } proc checkvalue {. _ node value {depth 0}} { $_ .vars q_check_value q_node_link_node if {$depth > 4096} { return [list {} 1] } $_ db eval $q_node_link_node { tailcall $_ checkvalue $ref $value [incr depth] } list [$_ db onecolumn $q_check_value] 0 } .my .method checkvalue proc db_createsysinfo {. _} { variable magicb $_ .vars sysnode lassign [$_ node forge {} .] sysnode $_ node set $sysnode magic $magicb $_ node forge $sysnode version major 0 $_ node forge $sysnode version minor 1 $_ node forge $sysnode version patch 0 return } .my .method db_createsysinfo proc dbitemprefix {. _} { $_ .vars dbitemprefix return $dbitemprefix } .my .method dbitemprefix variable doc::descendants_refs { description { finds all nodes that reference a descendant of the given node } } proc descendants_refs {. _ node args} { $_ .vars q_refs_descendants @nodepivot@ @givenscript@ set query [$_ descendantsrefscache get $key { string map [makereport node $given] $q_refs_descendants }] @queryscript@ } .my .method descendants_refs variable doc::descendants_refs? { description { returns true if there are any references to any descendant nodes } } proc descendants_referenced? {. _ node args} { $_ .vars q_refs_descendants? @nodepivot@ $_ db exists ${q_refs_descendants?} } .my .method descendants_referenced? proc inode_path& {. _ node args} { $_ .vars q_node_path_node @givenscript@ set query [$_ ipath&cache get $key { string map [makereport node $given] $q_node_path_node }] @queryscript@ } .my .method inode_path& proc node_clear {. _ args} { $_ .vars q_tree_delete_node_children q_tree_delete_node_top set node $args @nodepivot@ if {[llength $node]} { $_ db eval $q_tree_delete_node_children } else { $_ db eval $q_tree_delete_node_top } return } .my .method node_clear proc node_converge {. _ node other args} { $_ .vars q_node_converge_value @nodepivot@ @givenscript@ set query [$_ convergevaluecache get $key { string map [makereport value $given] $q_node_converge_value }] lappend qvals other $other @queryscript@ } .my .method node_converge proc node_converge& {. _ node other args} { $_ .vars q_node_converge @nodepivot@ @givenscript@ set query [$_ convergecache get $key { string map [makereport node $given] $q_node_converge }] lappend qvals other $other @queryscript@ } .my .method node_converge variable doc::node_cp { description { create a copy of a node and place it in another node if a copied link references a node that is also copied during this operation the link is adjusted to point to the new copy of the referenced node } } proc node_cp {. _ node to} { $_ .vars s_node_cp q_node_last_node_node \ q_treenodenext_noalias_node_up_node @nodepivot@ if {[llength $to]} { set to [$_ node pivot {*}$to] } else { lassign $to[set node {}] to } if {![llength $to]} { set to [$_ node new {} {}] } if {[llength $node]} { # to do # this is poorly tested # # particularly the calculation of new "up" and "link" values $_ db transaction { # for $q_node_last_node_node set orignode $node set node $to set last [$_ db eval $q_node_last_node_node] set node $orignode $_ db eval $s_node_cp set limit 1 set node $last set res [$_ db eval $q_treenodenext_noalias_node_up_node] } } else { error [list finish this] # {to do} finish this } return $res } .my .method node_cp proc lost {. _ args} { $_ .vars q_lost $_ db eval $q_lost { set lambda [uplevel 1 [ list [namespace which lambda] node {*}$args $node]] uplevel 1 $lambda } } .my .method lost proc node_appears& {. _ node other args} { $_ .vars q_node_appears @nodepivot@ @givenscript@ set query [$_ nodeappearscache get $key { string map [makereport {node level indirects} $given] $q_node_appears }] dict set qvals other $other @queryscript@ } .my .method node_appears& if 0 { # didn't work because incrblob can't write channels of arbitrary size proc node_chan {. _} { $_ .vars dbitemprefix sql_link_delete sql_readchan_tmptable $_ db eval $sql_link_delete set id [$_ db onecolumn $sql_readchan_tmptable] set chan [$_ db incrblob ${dbitemprefix}readchan_value value $id] list $id $chan } .my .method node_chan proc node_close {. _ node name id chan newnode} { $_ .vars sql_readchan_insert sql_readchan_delete sql_readchan_queryvalues #close $chan @nodepivot@ set res [$_ db onecolumn $sql_readchan_queryvalues] if {$res ne {}} { try { $_ db onecolumn $sql_readchan_insert } finally { $_ db eval $sql_readchan_delete } } else { $db eval $sql_readchan_delete } return $newnode } .my .method node_close } proc node_clone {. _ node} { $_ db transaction { if 0 { to do write tests for this } set up [$_ node up& $node] set new [$_ node new $up] set target [$_ node target $node] if {$target eq {}} { $_ node val $new [$_ node val $node] } else { $_ node editlink $new $target } } return $new } .my .method node_clone variable doc::node_dr { description { deep references } } proc node_dr {. _ node other args} { $_ .vars q_dr_other @nodepivot@ @givenscript@ set query [$_ drothercache get $key { string map [makereport {node up} $given] $q_dr_other }] # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $other lappend qvals other $other @queryscript@ } .my .method node_dr variable doc::node_drcount { description { deep references } } proc node_drcount {. _ node other} { $_ .vars q_dr_other_count @nodepivot@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $other $_ db onecolumn $q_dr_other_count } .my .method node_drcount proc node_depth {. _ node} { llength [$_ node path $node]] } .my .method node_depth variable doc::node_ddict { description { produce a deep list from a given node } } proc node_ddict {. _ node args} { set res {} lappend isdict 0 set myisdict 0 set nodeids 0 set path {} while {[llength $args]} { take args arg switch $arg { nodeids { take args nodeids } } } $_ node walk $node { upvar indices indices isdict isdict lastlevel lastlevel \ myisdict myisdict nodeids nodeids path path res res if {![info exists lastlevel]} { set lastlevel $level } if {$level != $lastlevel} { if {$level > $lastlevel} { set oldpath $path lappend path end # this is $mydict from the old level if {!$myisdict} { #convert to dictionary set d1 $res deep node d1 {*}$oldpath set d1 [concat {*}[lmap item $d1 { list $item {} }]] lset isdict $lastlevel 1 lset res {*}$oldpath $d1 #deep insert res $path {} } lappend isdict 0 } elseif {$level < $lastlevel} { if {![lindex $isdict $lastlevel]} { # quote level as a list of terminal node values set d1 $res deep node d1 {*}$path # [deep set] takes adds the needed quoting, so no need for # this #set d1 [list $d1[set d1 {}]] deep set res {*}$path $d1 } set isdict [lrange $isdict[set isdict {}] 0 $level] set path [lreplace $path[set path {}] end-[ expr {$lastlevel - $level -1}] end] } set myisdict [lindex $isdict $level] } set newpath $path lappend newpath end if {$nodeids} { set value [list $node $value[set value {}]] } if {$myisdict} { deep insert res $newpath $value {} } else { deep insert res $newpath $value } set lastlevel $level } return $res } .my .method node_ddict variable doc::node_dest { description return the targets of a link or the empty string if the node is not a link } proc node_dest {. _ node args} { $_ .vars q_node_dest @nodepivot@ $_ db onecolumn $q_node_dest } .my .method node_dest proc node_down {. _ node} { @nodepivot@ $_ node val [$_ node down& $node] } .my .method node_down proc node_down& {. _ node} { $_ .vars q_down& $_ db eval ${q_down&} } .my .method node_down& proc node_downtoref {. _ node ref args} { $_ .vars q_downtoref while {[llength $args]} { take args arg optswitch $arg { allowed { take args allowed } } } set res [$_ db eval $q_downtoref] if {[info exists allowed]} { if {[llength $res] > $allowed} { error [list {too many results} allowed $allowed count [ llength $res]] } } return $res } .my .method node_down& proc node_edit {. _ node value} {$_ db transaction { $_ .vars q_node_edit # strip any internal representation off $value to keep sqlite types # consistent # in particular # make sure that something like 0xfa that happens to have a numeric # internal representation is not converted to 250 # to do: what is the performance cost of this? # ensure a string representation so that SQLite creates a text value and # not a blob value encoding convertto utf-8 $value $_ db transaction { $_ db eval $q_node_edit } return }} .my .method node_edit proc node_editlink {. _ node reference} {$_ db transaction { $_ .vars q_tree_editlink $_ db eval $q_tree_editlink }} .my .method node_editlink proc node_examine {. _ node args} [pmap \ {} \ q_tree_examine_top \ excache \ {node up value nodetype uptype valuetype ref reftype} {} { @nodepivot@ @pmap@ @queryscript@ } ] .my .method node_examine proc node_empty? {. _ node args} { $_ .vars q_node_empty q_top_empty @nodepivot@ if {[llength $node]} { $_ db onecolumn $q_node_empty } else { $_ db onecolumn $q_top_empty } } .my .method node_empty? proc node_exists {. _ args} { expr {[$_ node pivot? {*}$args] != {}} } .my .method node_exists proc node_highestid {. _} { $_ .vars q_node_highest $_ db onecolumn $q_node_highest } .my .method node_highestid proc node_mustexist {. _ node} { if {![$_ node exists $node]} { error [list {no such node} $node] } } .my .method node_mustexist proc node_findeq& {. _ node value args} [pmap \ q_treevalseq_any_node \ q_treevalseq_any_top \ findeq&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_findeq& proc node_findglob& {. _ node value args} [pmap \ q_treevalsglob_any_node \ q_treevalsglob_any_top_node \ findglob&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_findglob& proc node_findlike& {. _ node value args} [pmap \ q_treevalslike_any_node \ q_treevalslike_any_top_node \ findlike&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_findlike& proc node_findmatch& {. _ node value args} [pmap \ q_treevalsmatch_any_node \ q_treevalsmatch_any_top_node \ findmatch&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_findmatch& proc node_findregexp& {. _ node value args} [pmap \ q_treevalsregexp_any_node \ q_treevalsregexp_any_top_node \ findregexp&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_findregexp& switch @forgevariant@ { sqltmptable { proc node_forge {. _ node args} { #$_ node_forge_c up args $_ .vars q_node_forge_up_node_0 q_node_forge_up_node_2 \ q_node_forge_up_node_1 q_node_forge_up_top set created 0 @nodepivot@ $_ db transaction { if {[llength $args]} { if {$node eq {}} { take args value # ensure a string representation so that SQLite creates # a text value and not a blob value encoding convertto utf-8 $value set query $q_node_forge_up_top set node [$_ db eval $query] if {$node eq {}} { set node [$_ node new {} $value] incr created } } set i 0 foreach value $args { encoding converto utf-8 $value set value_$i $value incr i } set query [$_ forgecache get [llength $args] { set i 0 set query $q_node_forge_up_node_0 foreach value $args { encoding convertto utf-8 $value append query [subst -nobackslashes -novariables [ string map [ list @value@ \$value_$i] $q_node_forge_up_node_1]] incr i } append query $q_node_forge_up_node_2 }] lassign [$_ db eval $query] node created2 incr created $created2 } } return [list $node $created] } .my .method node_forge } iterpivot { proc node_forge {. _ node args} { $_ .vars q_tree_select_node #$_ node_forge_c up args set created 0 $_ db transaction { @nodepivot@ if {[llength $args]} { if {$node eq {}} { take args arg set new [$_ node pivot? $node $arg] if {$new eq {}} { set node [$_ node new {} $arg] incr created } else { set node $new } } else { if {![llength [$_ db onecolumn $q_tree_select_node]]} { error [list {no such node} $node] } } foreach arg $args { set new [$_ node pivot? $node $arg] if {$new eq {}} { set node [$_ node new $node $arg] incr created } else { set node $new } } } } return [list $node $created] } .my .method node_forge } sqlpivot { proc node_forge {. _ node args} { #$_ node_forge_c up args $_ .vars q_node_forge_up_node q_node_forge_up_top set created 0 @nodepivot@ $_ db transaction { if {[llength $args]} { if {$node eq {}} { take args value # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set query $q_node_forge_up_top set node [$_ db eval $query] if {$node eq {}} { set node [$_ node new {} $value] incr created } } foreach value $args { # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set query $q_node_forge_up_node lassign [$_ db eval $query] new if {$new eq {}} { set node [$_ node new $node $value] incr created } else { set node $new } } } } return [list $node $created] } .my .method node_forge } } proc node_forth {. _ node args} { $_ .vars q_node_forth @nodepivot@ set pivot [$_ node_forth& {*}$node $args] if {$pivot ne {}} { return [$_ node val $pivot] } error [list {no node forth} node $node] } .my .method node_forth variable doc::node_forth& { description { return the node next node forth or the empty string if this is the last node } } proc node_forth& {. _ node args} { if 0 { to do test top and intermediate cases } $_ .vars q_node_forth if {[llength $args]} { set node [$_ node_pivot? $node {*}$args] } set res [$_ db onecolumn $q_node_forth] return $res } .my .method node_forth& proc node_id {. _ node new} { $_ .vars q_node_id @nodepivot@ $_ node_mustexist $node $_ db onecolumn $q_node_id } .my .method node_id proc node_idgt& {. _ node val} { $_ .vars q_node_idgt_up_node @nodepivot@ set res [$_ db onecolumn $q_node_idgt_up_node] } .my .method node_idgt& proc node_islink {. _ node} { $_ .vars q_node_link $_ db exists $q_node_link } .my .method node_islink proc node_islost {. _ node} { $_ .vars q_islost @nodepivot@ $_ node_mustexist $node expr {[llength [$_ db eval $q_islost]] != 0} } .my .method node_islost variable doc::node_last { returns the value of the last child of some node } proc node_last {. _ args} { set node $args $_ .vars q_node_last_root_value q_node_last_node_value @nodepivot@ @givenscript@ set query [$_ nodelastcache get [list $node $key] { if {[llength $node]} { set query $q_node_last_node_value } else { set query $q_node_last_root_value } lindex $query }] set res [$_ db eval $query] if {![llength $res]} { error [list {no results}] } return [lindex $res 0] } .my .method node_last variable doc::node_last& { returns the id of last child of some node } proc node_last& {. _ args} { set res [$_ node_last&? {*}$args] if {![llength $res]} { error [list {no results}] } return [lindex $res 0] } .my .method node_last& proc node_last&? {. _ args} { set node $args $_ .vars q_node_last_node_node q_node_last_root_node @nodepivot@ @givenscript@ set query [$_ nodelast&cache get [list $node $key] { if {[llength $node]} { set query $q_node_last_node_node } else { set query $q_node_last_root_node } lindex $query }] $_ db eval $query } .my .method node_last&? if 0 { to do add the ability to select breadth-first instead of depth-first } proc node_leaves {. _ node args} { $_ .vars q_node_leavesvalue @nodepivot@ @givenscript@ set query [$_ leavesvaluecache get $key { string map [makereport value $given] $q_node_leavesvalue }] @queryscript@ } .my .method node_leaves& proc node_leaves& {. _ node args} { $_ .vars q_node_leaves @nodepivot@ @givenscript@ set query [$_ leavescache get $key { string map [makereport node $given] $q_node_leaves }] @queryscript@ } .my .method node_leaves& proc node_link {. _ node args} { $_ .vars q_tree_select_node \ q_tree_insert_link_top \ q_tree_insert_link \ q_tree_forth @nodepivot@ foreach ref $args { $_ db transaction { if {![$_ node_exists $ref]} { error [list {no such node}] } set new [$_ db onecolumn $q_tree_forth] if {$node eq {}} { $_ db eval $q_tree_insert_link_top } else { if {![$_ db exists $q_tree_select_node]} { error [list {no such up} $node] } $_ db eval $q_tree_insert_link } } } return $new } variable doc::links { returns all direct links to a node } proc node_links {. _ node args} { $_ .vars q_node_links @nodepivot@ @givenscript@ set query [$_ linkscache get $key { string map [makereport node $given] $q_node_links }] @queryscript@ } .my .method node_links proc node_linkval {. _ node args} { $_ .vars q_node_linkval_set @nodepivot@ if {[llength $args] == 1} { lassign $args ref $_ db eval $q_node_linkval_set } elseif {[llength $args]} { error [list {wrong # args} [llength $args]] } $_ node val $node } .my .method node_linkval variable doc::node_ls { description lists the values of nodes one step down nodes with no values are omitted if a script is provided then foreach resulting value evaluates the script is its own local scope if a name specification is provided then otherwise the following variables are available value the value of the node otherwise returns the resulting list of values } proc node_ls {. _ node args} [pmap \ q_treevals_value_up_node \ q_treevals_up_top_value \ lscache \ value {} { @nodepivot@ @pmap@ @queryscript@ }] .my .method node_ls variable doc::node::ls& { description { lists all nodes one step down if a script is provided then for each resulting node evaluates the script in its own local scope under the level of the caller of ls& variables available in the evaluation level are node the resulting node currently the local scope the script is evaluated in contains some variables used to set up the evaluation, and also any row variables created by sqlite itself this makes the evaluation environment a little confusing this situation should be improved otherwise returns a list of resulting nodes } } proc node_ls& {. _ node args} [pmap \ q_treevals_node_up_node \ q_treevals_up_top_node \ lsandcache \ node { set order node while {[llength $args]} { take args arg optswitch $arg { order { take args order $_ .vars q_treevals_node_up_node_order_value set query_node $q_treevals_node_up_node_order_value } } } } { @nodepivot@ @pmap@ @queryscript@ }] .my .method node_ls& proc node_lsempty& {. _ node args} [pmap \ q_node_lsempty \ q_node_lsempty_top \ lsemptycache \ node {} { @nodepivot@ @pmap@ @queryscript@ }] .my .method node_lsempty& proc node_lseq& {. _ node value args} [pmap \ q_treevalseq_node_up_node \ q_treevalseq_up_top_node \ lseq&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_lseq& proc node_lsglob& {. _ node value args} [pmap \ q_treevalsglob_node_up_node \ q_treevalsglob_up_top_node \ lsglob&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_lsglob& proc node_lsfull& {. _ node args} [pmap \ q_node_lsfull \ q_node_lsfull_top \ lsfullcache \ node {} { @nodepivot@ @pmap@ @queryscript@ }] .my .method node_lsfull& proc node_lslike {. _ node like args} [pmap \ q_treevalslike_value_up_node \ q_treevalslike_up_top_value \ lslikecache \ value {} { @nodepivot@ @pmap@ lappend qvals like $like @queryscript@ }] .my .method node_lslike proc node_lspart& {. _ node offset limit args} [pmap \ q_treevalspart_node_up_node \ q_treevalspart_up_top_node \ lsandcache \ node {} { @nodepivot@ @pmap@ lappend qvals offset $offset limit $limit @queryscript@ }] .my .method node_lspart& if 0 { to do require sqlite icu extension for uniformity? } proc node_lslike& {. _ node value args} [pmap \ q_treevalslike_node_up_node \ q_treevalslike_up_top_node \ lslike&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_lslike& proc node_lsregexp& {. _ node value args} [pmap \ q_treevalsregexp_node_up_node \ q_treevalslike_up_top_node \ lsregexp&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_lsregexp& proc node_move {. _ node to} { $_ .vars s_move_to set path [$_ inode_path& $to] if {$node in [$_ inode_path& $to]} { if 0 { to do this guard needs some tests } error [list {can not move a node into its descendants}] } $_ db eval $s_move_to return } .my .method move variable doc::new { variable description { foreach $arg in $args insert into the specified existing node one new variable with a value of $arg } } proc node_new {. _ args} { $_ .vars q_tree_insert_value q_insert_values_value \ q_node_new_value_exists \ q_tree_forth \ q_tree_select_node \ q_select_values_node_from_value q_tree_insert_value_top if {[llength $args]} { take args node } else { set node {} } @nodepivot@ if {![llength $args]} { lappend args {} } if 0 { to do can foreach be moved into the transaction? } if 0 { to do have this routine return the first created node } foreach value $args { # ensure a string representation so that SQLite creates a text value and # not a blob value encoding convertto utf-8 $value $_ db transaction { if {![$_ db exists $q_node_new_value_exists]} { $_ db eval $q_insert_values_value } lassign [$_ db eval $q_select_values_node_from_value] \ ref value2 valuetype #if {$ref eq {} || $value2 ne $value} { # error [list {value would be corrupted in database}] #} set new [$_ db onecolumn $q_tree_forth] if {$node eq {}} { $_ db eval $q_tree_insert_value_top } else { #if {![$_ db exists $q_tree_select_node]} { # error [list {no such up} $node] #} $_ db eval $q_tree_insert_value } } } return $new } .my .method node_new proc node_next& {. _ node offset limit args} [pmap \ q_treenodenext_node_up_node \ q_treenodenext_up_top_node \ lsnext&cache \ node {} { @nodepivot@ @pmap@ lappend qvals limit $limit offset $offset @queryscript@ }] .my .method node_next& variable doc::node_nodr { description { finds nodes in one tree that are not referenced in another } } proc node_nodr {. _ node other args} { $_ .vars q_nodr_other @nodepivot@ @givenscript@ set query [$_ nodrothercache get $key { string map [makereport node $given] $q_nodr_other }] lappend qvals other $other @queryscript@ } .my .method node_nodr proc node_path {. _ node args} { $_ .vars q_node_path_value @nodepivot@ @givenscript@ set query [$_ pathcache get $key { string map [makereport value $given] $q_node_path_value }] @queryscript@ } .my .method node_path proc node_path& {. _ node args} { $_ .vars q_node_path_node @nodepivot@ @givenscript@ set query [$_ path&cache get $key { string map [makereport node $given] $q_node_path_node }] @queryscript@ } .my .method node_path& proc node_pivot {. _ node args} { set res [$_ node_pivot? $node {*}$args] if {![llength $res]} { error [list {no such path} node $node path $args] } lindex $res 0 } .my .method node_pivot switch 1 { 0 { proc node_pivot? {. _ node args} { lassign [$_ node_pivot_query $node {*}$args] params query dict with params {} set res [$_ db eval $query] if {[llength $res]} { return [lindex $res end] } return {} } .my .method node_pivot? } 1 { if 0 { this is much faster than method 2 } proc node_pivot? {. _ node args} { $_ .vars q_pivot_name q_node q_pivot_name_top $_ db transaction { if {$node eq {}} { take args value # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set node [$_ db onecolumn $q_pivot_name_top] set res $node } foreach value $args { # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set node [$_ db onecolumn $q_pivot_name] set res $node } if {![info exists res]} { set res [$_ db onecolumn $q_node] } } return $res } .my .method node_pivot? } 2 { proc node_pivot? {. _ node args} { $_ .vars q_check_value q_node q_node_link_top q_node_link_target \ q_pivot_simple q_pivot_name_simple q_pivot_top_simple q_valueid $_ db transaction { if {$node eq {}} { take args value # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set new [$_ db onecolumn $q_pivot_top_simple] if {$new eq {}} { set found {} $_ db eval $q_node_link_top { lassign [$_ checkvalue $target $value] checked toodeep if {$checked ne {}} { set found $node } } if {$found eq {}} { return {} } else { set node $found } } else { set node $new } set res $node } else { set arg_up $node } foreach value $args { # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set new [$_ db onecolumn $q_pivot_name_simple] #set valueid [$_ db onecolumn $q_valueid] #if {$valueid eq {}} { # set new {} #} else { # set new [$_ db onecolumn $q_pivot_simple] #} if {$new eq {}} { set found {} # find the last matching node # to do: find all matching nodes? $_ db eval $q_node_link_target { lassign [$_ checkvalue $target $value] checked toodeep if {$checked ne {}} { set found $node } } if {$found eq {}} { set node {} } else { set node $found } } else { set node $new } set res $node } if {![info exists res]} { set res [$_ db onecolumn $q_node] } } return $res } .my .method node_pivot? } } # this was too slow, and ran into sql stack and reference limits # slowness is possibly due to the cyclic link at the top level in the test # suite # {to do} diagnose and optimize proc node_pivot_query {. _ node args} { $_ .vars dbitemprefix q_pivot_roots \ q_pivot_node q_pivot_subquery q_with if {[llength $args]} { set key [list [expr {[llength $node] == 0}] [llength $args]] set i 0 if {[$_ pivotcache exists $key]} { set query [$_ pivotcache get $key] foreach arg $args { # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $arg dict set params arg_$i $arg incr i } } else { set query {with recursive} if {$node eq {}} { take args arg # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $arg dict set params arg_$i $arg set haverx 1 set excludetop {} append query [string map [ list r1 rl$i @where@ " where ${dbitemprefix}tree.node = ${dbitemprefix}tree.up " @joins@ {} @recurse@ {}] $q_with] append query " , rx$i\(node) as ( select node from r$i where case when cast(cast(\$arg_$i as numeric) as text) = cast(\$arg_$i as text) then cast(\$arg_$i as numeric) when cast(\$arg_$i as text) = \$arg_$i then cast(\$arg_$i as text) else cast(\$arg_$i as blob) end = case when r$i.value is null then ( select value from rl$i where rl$i.orignode = r$i.node and rl$i.value is not null ) else r$i.value end ) " } else { set excludetop \ "and ${dbitemprefix}tree.up != ${dbitemprefix}tree.node" append query [string map [ list r1 rl$i @where@ " where ${dbitemprefix}tree.node = \$node " @joins@ {} @recurse@ {}] $q_with] set haverx 0 } set ip $i incr i foreach arg $args { # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $arg dict set params arg_$i $arg if {$haverx} { set rx rx } else { set rx r } append query " ,[string map [ list r0 r$i r1 rl$i @where@ {} @joins@ " join $rx$ip on $rx$ip.node = ${dbitemprefix}tree.up $excludetop " @recurse@ {}] $q_with ] , rx$i\(node) as ( select node from r$i where case when cast(cast(\$arg_$i as numeric) as text) = cast(\$arg_$i as text) then cast(\$arg_$i as numeric) when cast(\$arg_$i as text) = \$arg_$i then cast(\$arg_$i as text) else cast(\$arg_$i as blob) end = case when r$i.value is null then ( select value from rl$i where rl$i.orignode = r$i.node and rl$i.value is not null ) else r$i.value end ) " set haverx 1 set excludetop \ "and ${dbitemprefix}tree.up != ${dbitemprefix}tree.node" set ip $i incr i # debugging if 0 { ::apply [list {_ params query} { puts stderr [list debug node_pivot_query] puts stderr $params puts stderr $query dict with params {} foreach key [dict keys $params] { puts stderr [list $key [set $key]] } puts stderr [list [$_ db eval $query]] puts stderr [$_ db eval {select * from tree1values}] } [namespace current]] $_ $params $query } } incr i -1 if {$haverx} { append query " select node from rx$i " } else { append query " select node from r$i " } $_ pivotcache set $key $query } return [list $params $query] } else { if {$node == {}} { return [list {} $q_pivot_roots] } else { dict set params arg_0 $node return [list $params $q_pivot_node] } } } .my .method node_pivot_query proc node_pretty {. _ node args} { $_ .vars dbitemprefix if 0 { to do if $chan is the empty string set up a channel produce output to that channel read the contents of the channel destroy the channel return the contens of the channel } set chan stdout set simple 0 while {[llength $args]} { set args [lassign $args[set args {}] arg val] switch $arg { chan { set chan $val } simple { set simple 1 } default { error [list {unknown option} $arg] } } } if {$simple} { set report {[string repeat \t $level] [list $value]} } else { set report {[string repeat \t $level] [list $node] [list $up] [list [ if {$link eq {}} { list $ref } else { list link $ref }]] [list $value]} } $_ node walk $node { upvar report report upvar chan chan puts $chan [subst $report] } return } .my .method node_pretty proc node_back {. _ node args} { $_ .vars q_node_back set pivot [$_ node back& $node {*}$args] if {$pivot ne {}} { return [$_ node val $pivot] } error [list {no back node} node $node] } .my .method node_back variable doc::node_back& { description { return the back node or the empty string if this is the first node } } proc node_back& {. _ node args} { $_ .vars q_node_back if {[llength $args]} { set node [$_ node_pivot? $node {*}$args] } $_ db onecolumn $q_node_back } .my .method node_back& proc node_readdeep {. _ node data} { foreach {key val} $data[set data {}] { lassign [$_ node forge $node $key] new if {[llength $val] == 1} { foreach item [lindex $val[set val {}] 0] { $_ node forge $new $item } } else { $_ node read_deep $new $val[set val {}] } } return } .my .method node_readdeep variable doc::refs { returns all direct and indirect links to a node } proc node_refs {. _ node args} { $_ .vars q_node_refs @nodepivot@ @givenscript@ set query [$_ refscache get $key { string map [makereport {node up} $given] $q_node_refs }] @queryscript@ } .my .method node_refs proc node_referenced? {. _ node} { $_ .vars q_node_refs? @nodepivot@ $_ db exists ${q_node_refs?} } variable doc::node_refsunder { description { finds within $in references to $node or any link to $node under $other node or any link to $other } } proc node_refsunder {. _ node other in args} { $_ .vars q_refsunder_other if 0 { to do is this routine the same as node_refs except that it inadvertently returns all links under any reference to $node? } @nodepivot@ @givenscript@ set query [$_ refsunderothercache get $key { string map [makereport {node up} $given] $q_refsunder_other }] # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $in encoding convertto utf-8 $other lappend qvals in $in other $other @queryscript@ } .my .method node_refsunder variable doc::node_deeprefsunder { description { finds within $in references to $node or any link to $node under $other node or any link to $other } } proc node_deeprefsunder {. _ node other in args} { $_ .vars q_deeprefsunder_other if 0 { to do is this routine the same as node_refs except that it inadvertently returns all links under any reference to $node? } @nodepivot@ @givenscript@ set query [$_ deeprefsunderothercache get $key { string map [makereport {node up} $given] $q_deeprefsunder_other }] # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $in encoding convertto utf-8 $other lappend qvals in $in other $other @queryscript@ } .my .method node_deeprefsunder proc node_repoint {. _ node target} { $_ .vars sql_repoint @nodepivot@ if {![$_ node islink $node]} { error [list {not a link}] } $_ db eval $sql_repoint return } .my .method node_repoint proc node_rm {. _ node args} { $_ .vars s_delete_node set node [list $node[ set node {}] {*}$args[set args {}]] @nodepivot@ if {[$_ node referenced? $node] || [$_ descendants referenced? $node]} { error [ list {there are references to the node or its descendants } $node] } $_ node ls& $node { upvar _ _ $_ node_rm $node } $_ db eval $s_delete_node return } .my .method node_rm proc node_route {. _ node other args} { @nodepivot@ error {to do} } .my .method node_route proc node_pathrefs {. _ node to args} [pmap \ q_node_up_pathrefs \ q_treevals_up_top_pathrefs \ pathrefscache \ node {} { @nodepivot@ @pmap@ lappend qvals to $to @queryscript@ } ] .my .method node_pathrefs variable doc::node_set { description modify the value of an attribute of $node add a new attribute if there is no attribute by the given name args node the node to operate on args 0 to last-2 pivot last-1 the name of the attribute if a name is not provided the node is considered to be the attribute node itself rather than the object node last the value of the attribute } proc node_set {. _ node args} { if {[llength $args] == 2} { pop args name val } elseif {[llength $args] == 1} { pop args val } if {[llength $args]} { set node [list {*}$node {*}$args] } @nodepivot@ if {[info exists name]} { set namenode [$_ node_pivot? $node $name] if {$namenode eq {}} { set namenode [$_ node new $node $name] } } else { set namenode $node } $_ node clear $namenode $_ node new $namenode $val } .my .method node_set proc node_setd {. _ node args} { foreach {key val} $args { $_ node set $node $key $val } return } .my .method node_setd proc node_count {. _ node} { $_ .vars q_node_count q_top_count if {[llength $node]} { $_ db onecolumn $q_node_count } else { $_ db onecolumn $q_top_count } } .my .method node_count variable doc::node_target { description return the targets of a link or the empty string if the node is not a link } proc node_target {. _ node args} { $_ .vars q_node_link @nodepivot@ $_ db eval $q_node_link } .my .method node_target variable doc::node::traverse { description visit every node from the top of the tree to the specified node } proc node_traverse {. _ node args} { @nodepivot@ $_ .vars q_node_traverse @givenscript@ set query [$_ traversecache get $key { string map [makereport {node up ref value level} $given] $q_node_traverse }] @queryscript@ } .my .method node_traverse proc node_tail& {. _ node limit args} [pmap \ q_treevals_node_up_node_tail \ q_treevals_up_top_node_tail \ tailcache \ node {} { @nodepivot@ @pmap@ lappend qvals limit $limit @queryscript@ }] .my .method node_tail& proc node_tree {. _ node args} { if {[llength $args] == 1} { set tree [lindex $args[set args {}] 0] } else { set tree $args[set args {}] } if {[llength $tree] == 0 || [llength $tree] % 2} { error [list {wrong # args}] } foreach {key values} $tree { set newnode [$_ node new $node $key] if {![info exists res]} { set res $newnode } if {[llength $values] == 1} { $_ node new $newnode [lindex $values 0] } else { if {[llength $values]} { $_ node tree $newnode $values } } } return } .my .method node_tree proc node_under {. _ node other} { $_ .vars q_node_under @nodepivot@ $_ db onecolumn $q_node_under } .my .method node_under variable doc::node_under_links_findeq& { description { finds nodes under a node that are links to a node having the given value to do shoulld this be renamed to node_appears_val? should the query be restructured to use q_node_appears? } } proc node_under_links_findeq& {. _ node value args} [pmap \ q_under_links_findeq_node \ q_under_links_findeq_top \ underlinksfindeq&cache \ node {} { @nodepivot@ @pmap@ # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value lappend qvals value $value @queryscript@ }] .my .method node_under_links_findeq& proc node_up {. _ node} { @nodepivot@ $_ node val [$_ node up& $node] } .my .method node_up proc node_up& {. _ node} { $_ .vars q_up& $_ db eval ${q_up&} } .my .method node_up& variable doc::node_val { description get or set the value of a node } proc node_val {. _ node args} { @nodepivot@ $_ .vars q_node_val q_node_val_set if {[llength $args] == 1} { lassign $args value # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value $_ db eval $q_node_val_set } elseif {[llength $args]} { error [list {wrong # args} [llength $args]] } dbget [list $_ db] $q_node_val } .my .method node_val variable doc::node_valueid { description returns the id of the value for the node useful for fast comparisons } proc node_valueid {. _ node} { $_ .vars q_node_valueid $_ db onecolumn $q_node_valueid } .my .method node_val proc node_walk {. _ node args} [pmap \ q_walk_node \ q_walk_root \ walkcache \ {node up ref value level} {} { @nodepivot@ @pmap@ @queryscript@ }] .my .method node_walk proc ondeleted {. _ node up value} { } .my .method ondeleted proc oninserted {. _ node up value} { } .my .method oninserted proc onupdated {. _ onode oup ovalue nnode nup nvalue} { } .my .method onupdated proc read {. _ data} { $_ .vars sql_create_table_readmap sql_delete_table_readmap \ sql_insert_table_readmap sql_select_table_readmap \ sql_select_tree_forth sql_table_tree_readmap set count 0 $_ db transaction { $_ db eval $sql_create_table_readmap parse $data ::apply [list {_ args} { upvar count count map map \ sql_insert_table_readmap sql_insert_table_readmap incr count $_ .vars s_insert_value s_insert_link if {[llength $args] == 0} { error [list {this is impossible}] } elseif {[llength $args] == 1} { set node [lindex $args 0] set up $node catch {unset value} } elseif {[llength $args] == 2} { lassign $args node up catch {unset value} } elseif {[llength $args] == 3} { lassign $args node up value } else { error [list {too many arguments} record $count $args] } # make sure we've got two numbers try {expr {$node + 0}} on error {tres topts} { error [list {node is not a number} $count $args] } try {expr {$up + 0}} on error {tres topts} { error [list {up is not a number} $count $args] } # NULL values are not allowed in the tree if {![info exists value]} { set value {} } if {$node % 2} { set value [expr {$value + 0}] set new [$_ db eval $s_insert_link] } else { # ensure a string representation so that SQLite creates a text # value and not a blob value encoding convertto utf-8 $value set new [$_ db eval $s_insert_value] } $_ db eval $sql_insert_table_readmap } [namespace current]] $_ $_ db eval $sql_table_tree_readmap #$_ db eval $sql_select_table_readmap { # puts [list readmap $old $new] #} $_ db eval $sql_delete_table_readmap } return } .my .method read proc setupdb {. _} { variable magicb $_ .vars dbitemprefix q_dbsetup q_dbsetup_query q_dbsetup_insert \ q_dbsetup_values_exist sysnode $_ db transaction { $_ db function ${dbitemprefix}ondeleted [list $_ ondeleted] $_ db function ${dbitemprefix}oninserted [list $_ oninserted] $_ db function ${dbitemprefix}onupdated [list $_ onupdated] } if { [table exists [list $_ db] ${dbitemprefix}tree] || [table exists [list $_ db] ${dbitemprefix}values] } { set valid 0 if {[table exists [list $_ db] ${dbitemprefix}values]} { if { [$_ node exists {} . magic] && [$_ node last {} . magic] == $magicb } { set valid 1 } elseif {[$_ db exists $q_dbsetup_query]} { # {to do} {delete this part after all old trees have been # converted} #convert this old tree into a newer one $_ db_createsysinfo set valid 1 } } if {$valid} { set sysnode [$_ node pivot {} .] } else { error [list {not a valid tree}] } } else { minpagesize [list $_ db] 8192 $_ db eval { pragma encoding = "utf-8" ; pragma cache_size = 10000 } $_ db transaction { $_ db eval $q_dbsetup if {![$_ db exists $q_dbsetup_values_exist]} { $_ db eval $q_dbsetup_insert } $_ db_createsysinfo } } } .my .method setupdb proc size {. _} { $_ .vars q_size $_ db onecolumn $q_size } .my .method size proc tree_roots {. _} { $_ db eval {select * from tree where node = up} } .my .method tree_roots proc value_get {. _ id} { $_ .vars sql_value_get $_ db onecolumn $sql_value_get } .my .method value_get proc values_count {. _} { $_ .vars sql_values_count $_ db onecolumn $sql_values_count } .my .method value_count .my .routine util variable magic 46d4dc3c35caf20ebb4df605730cda0652a99990592c20e87043001f3cb589ff variable magicb [binary format H* $magic] encoding convertto utf-8 $magicb ::apply [list {} { variable q_templates proc t_links {tablename source tree} { set query [string map [ list @tablename@ $tablename @source@ $source @tree@ $tree] { @tablename@(node ,target) as ( select @tree@.node ,@tree@.value from @tree@, @source@ where @tree@.node = @source@.node and @tree@.node in (select node from @@link) union select @tablename@.node ,@tree@.value from @tree@ ,@tablename@ where @tree@.node = @tablename@.target and @tree@.node in (select node from @@link) ) }] } proc t_query_compare {where op recurse} { return [subst -nobackslash -novariables [string map [ list @op@ $op @recurse@ [list $recurse]] { [t_with r0 r1 @@tree $where @recurse@] select node as @name0@ from ([t_with_select_nonames r0 r1 {}]) where value @op@ [lossless \$value] order by node }]] } proc t_query_compare_node {op recurse} { t_query_compare { where @@tree.up = $node and @@tree.node != @@tree.up } $op $recurse } proc t_query_compare_top {op recurse} { t_query_compare {where @@tree.node = @@tree.up} $op $recurse } if 0 { to do link resolution might be a bottleneck consider storing the resolved rowid of the value in tree.value and storing link information entirely in the link table in the first part of the query "where exists" is faster than "in" but in the second part of the query "in" is fater than "where exists" } proc t_query_resolvelink {t where} { string map [list @t@ $t @where@ $where] { @t@(orignode ,up ,node ,ref ,level) as ( select @@tree.node ,@@tree.up ,@@tree.node ,@@tree.value ,0 from @@tree where exists ( select node from @@link where @@link.node = @@tree.node ) @where@ union all select @t@.orignode ,@t@.up ,@@tree.node ,@@tree.value ,level+1 from @@tree join @t@ on @@tree.node = @t@.ref and @t@.node in (select node from @@link) and level < 512 ) } } proc t_q_treevals_node_up_node {} { return { select node as @name0@ from @@tree where up = $node and node != up } } proc t_r {where op value} { if {$value ne {}} { set value "and \"@@values\".value $op $value" } if {$where ne {}} { set where1 "and $where" } else { set where1 $where } if 0 { "not in" has been measured to be faster than "not exists" in this query } string map [list @r@ [t_query_resolvelink r $where1] @where@ $where @value@ $value] { @r@ select @@tree.node,@@tree.up ,null ,null ,"@@values".value from @@tree join "@@values" on @@tree.value = "@@values".node where @where@ and ( @@tree.node not in (select node from @@link) @value@ ) union all select r.orignode ,@@tree.up ,null ,null ,"@@values".value from @@tree join r on @@tree.node = r.node join "@@values" on r.ref = "@@values".node and r.node not in (select node from @@link) @value@ order by @@tree.node } } proc t_treevalquery {select where op value limit null} { if 0 { to do this query is slow because it is built on t_r which is slow minimize its use } if {$null} { set nullconstraint {} } else { set nullconstraint {where value is not null} } list [subst -nobackslash -novariables [string map [ list @select@ $select @limit@ $limit \ @nullconstraint@ $nullconstraint] { select @select@ from ( with recursive [t_r $where $op $value] ) @nullconstraint@ @limit@ }]] } proc t_with {r0 r1 tree where recurse args} { string map [list @where@ $where @recurse@ $recurse] [ t_with_raw $tree $r0 $r1 {*}$args] } proc t_with_raw {tree r0 r1 args} { # be careful when changing this. It has been carefully tuned to hurdle # performance landmines. # left joins are avoided even though it doesn't seem they were a # performance concern set tables {} while {[llength $args]} { take args arg switch $arg { table { take args table append tables " ,$table" } default { error [list {unknown option} $arg] } } } string map [list @r0@ $r0 @r1@ $r1 @tables@ $tables @tree@ $tree] { @r0@(node ,up ,link ,ref ,value ,level, top) as ( select @tree@.node ,@tree@.up , case when @tree@.node in (select node from @@link) then @tree@.node else null end ,@tree@.value , case when @tree@.node in (select node from @@link) then null else ( select value from "@@values" where @tree@.value = "@@values".node ) end ,0 ,@tree@.node from @tree@ @tables@ @where@ @recurse@ ) , @r1@(orignode ,up ,level ,link ,origref ,finalnode ,ref ,value ,indirects, top) as ( select node ,up ,level ,link ,ref ,node ,ref ,value ,0, top from @r0@ union all select @r1@.orignode , @r1@.up , level , case when t2.node in (select node from @@link) then t2.node else null end , origref , t2.node , t2.value , case when t2.node in (select node from @@link) then null else ( select value from "@@values" where t2.value = "@@values".node ) end ,@r1@.indirects+1 ,@r1@.top from @tree@ as t2 join @r1@ on @r1@.ref = t2.node and indirects < 512 where @r1@.link is not null ) } } proc t_with_value {} { string map [list @r@ [t_query_resolvelink r {}]] { (node ,value ,level) as ( with recursive @r@ select @@tree.node ,"@@values".value ,level from @@tree join r on @@tree.node == r.orignode join "@@values" on r.ref = "@@values".node where r.node not in (select node from @@link) union all select @@tree.node ,"@@values".value ,0 from @@tree join "@@values" on @@tree.value = "@@values".node where @@tree.node not in (select node from @@link) order by @@tree.node ) } } proc t_recurse_base {r0 join} { if {$join ne {}} { set join "on $join" } string map [list @r0@ $r0 @join@ $join] { union all select @@tree.node , @@tree.up , case when @@tree.node in (select node from @@link) then @@tree.node else null end , @@tree.value , case when @@tree.node in (select node from @@link) then null else ( select value from "@@values" where @@tree.value = "@@values".node ) end , level + 1 , @r0@.top from @@tree join @r0@ @join@ order by 6 desc, 1 } } proc t_recurse r0 { t_recurse_base $r0 [string map [list @r0@ $r0] { @@tree.up = @r0@.node and @@tree.node != @@tree.up }] } proc t_recurse r0 { t_recurse_base $r0 [string map [list @r0@ $r0] { @@tree.up = @r0@.node and @@tree.node != @@tree.up }] } proc t_recurse_up table { t_recurse_base $table [string map [list @table@ $table] { @@tree.node = @table@.up and @table@.node != @table@.up }] } apply [list {} { if 0 { maybe use "union" here instead of "union all" to prevent cycles but consider carefully maybe cycles shouldn't be prevented } set template { @t@(node ,up) as ( select @@tree.node ,@@tree.up from @@tree @tables@ where @@tree.@field@ @where@ and @@tree.node in ( select node from @@link ) union all select @t@2.node ,@t@2.up from @@tree as @t@2 ,@t@ where value = @t@.node and @t@2.node in ( select node from @@link ) ) } foreach field { value node } { set template2 [string map [list @field@ $field] $template] proc t_with_refs_where_$field {tablename where args} [ string map [list @template@ [list $template2]] { set tables {} while {[llength $args]} { take args arg switch $arg { table { take args table append tables ", [idquote $table]" } default { error [list {unknown options}] } } } string map [list @t@ $tablename @tables@ \ $tables @where@ $where] @template@ }] } } [namespace current]] proc t_subtree {tree where} { set res [string map [list @tree@ $tree @where@ $where] { (node, up ,value) as ( select node ,up ,value from @tree@ @where@ union all select @tree@.node ,@tree@.up ,@tree@.value from @tree@, t0 where @tree@.up = t0.node and @tree@.node != @tree@.up ) }] return $res } proc t_with_path {tablename nodevar} { string map [list @nodevar@ $nodevar @tablename@ $tablename] { @tablename@(node ,up ,level) as ( select node ,up ,0 from @@tree where @@tree.node = $@nodevar@ union all select @@tree.node ,@@tree.up ,@tablename@.level+1 from @@tree join @tablename@ on @@tree.node = @tablename@.up and @@tree.node != @tablename@.node ) } } proc t_with_select {r0 r1 where} { string map [list @r0@ $r0 @r1@ $r1 @where@ $where] { select @r0@.node as @name0@ , @r0@.up as @name1@ , @r0@.link , @r0@.ref as @name2@ , case when link is null then @r0@.value else ( select value from @r1@ where @r0@.node = @r1@.orignode and @r1@.link is null ) end as @name3@ ,@r0@.level as @name4@ ,@r0@.top from @r0@ @where@ } } proc t_with_select_raw r0 { string map [list @r0@ $r0] { select @r0@.node as @name0@ , @r0@.up as @name1@ , @r0@.link , @r0@.ref as @name2@ , @r0@.value ,@r0@.level as @name4@ ,@r0@.top from @r0@ } } proc t_with_select_nonames {r0 r1 where} { string map {@name0@ node @name1@ up @name2@ ref @name3@ value @name4@ level} [t_with_select $r0 $r1 $where] } proc t_with_select_raw_nonames r0 { string map {@name0@ node @name1@ up @name2@ ref @name3@ value @name4@ level} [t_with_select_raw $r0] } set q_templates [subst -nobackslash -novariables { $_ $ q_with [list [string map {@recurse@ {}} [t_with_raw @@tree r0 r1]]] $_ $ q_dbsetup_values_exist {select 1 from "@@values"} $_ $ q_dbsetup { -- autoincrement is needed in because insertion order is used in -- ordered operations, e.g. to sort nodes or determine last and first -- child create table if not exists @@forge ( node integer primary key , changes , created integer ) ; create table if not exists @@link ( node integer primary key ) ; create unique index if not exists @@link_idx_unique on @@link ( node ) -- the not null constraint was added on {2020 01 22} -- and tests were changed accordingly -- I strongly suspect that not allowing NULL is the right design ; create table if not exists @@tree ( node integer primary key autoincrement , up integer , value integer NOT NULL ) ; create index if not exists @@tree_idx_up on @@tree ( up ) ; create index if not exists @@tree_idx_value on @@tree ( value ) ; create trigger if not exists @@trigger_tree_inserted after insert on @@tree begin select @@oninserted(NEW.node ,NEW.up ,NEW.value) ; end ; create trigger if not exists @@trigger_tree_deleted after delete on @@tree begin select @@ondeleted(OLD.node ,OLD.up ,OLD.value) ; end ; create trigger if not exists @@trigger_value_updated after update on @@tree begin select @@onupdated(OLD.node ,OLD.up ,OLD.value , NEW.node ,NEW.up ,NEW.value) ; end ; create table if not exists "@@values" ( node integer primary key -- no affinity declaration so that sql scripts can cast as needed , value unique ) } $_ $ q_dbsetup_insert { insert into "@@values" values (null ,'') ; insert into "@@values" values (null ,$magicb) } $_ $ q_dbsetup_query { select 1 from "@@values" where node = 2 and value = $magicb } $_ $ q_down& { select node from @@tree where up = $node and node != $node order by node asc limit 1 } switch 0 { 0 { # this is 27x faster than the # and node in (select ...) # variant $_ $ q_downtoref { select node from @@tree where up = $node and value = $ref and exists ( select node from @@link where @@link.node = @@tree.node ) order by node asc limit 1 } } 1 { # this is 27x faster than the # and node in (select node from @@link) # subselect version $_ $ q_downtoref { select @@tree.node from @@tree join @@link on @@tree.node = @@link.node where up = $node and value = $ref order by @@tree.node asc limit 1 } } 2 { $_ $ q_downtoref { select node from @@tree where up = $node and value = $ref and node in (select node from @@link) order by node asc limit 1 } } } $_ $ q_lost { select node from @@tree where not exists ( select 1 from @@tree as tree2 where tree2.node = @@tree.up ) } $_ $ q_islost { select node from @@tree where node = $node and not exists ( select 1 from @@tree as tree2 where tree2.node = @@tree.up ) } $_ $ q_node_appears { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] select orignode as @name0@ ,r1.level as @name1@ ,r1.indirects as @name2@ from r1 where r1.ref = $other order by r1.level } $_ $ q_node_converge { with recursive [t_with_path t1 node] , [t_with_path t2 other] select node as @name0@ from t1 where node not in ( select node from t2 ) order by level desc } $_ $ q_node_converge_value { with recursive [t_with_path t1 node] , [t_with_path t2 other] , t3[t_with_value] select (select value from t3 where t3.node = t1a.node ) as @name0@ from t1 as t1a where not exists ( select node from t2 where t2.node = t1a.node ) order by level desc } $_ $ q_node_dest { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} {}] select finalnode from r1 where link is null and finalnode != $node } $_ $ q_node_up_pathrefs { with recursive [t_with_path t1 to] , [t_with r2 r3 @@tree {where @@tree.node = $node} [t_recurse r2]] select r3.orignode as @name0@ from r3 join t1 where r3.ref = t1.node } $_ $ q_treevals_up_top_pathrefs { error to do } $_ $ q_node_edit { insert or ignore into "@@values" values (null ,[lossless \$value]) ; update @@tree set value = ( select node from "@@values" where value = [lossless \$value]) where node = $node ; delete from @@link where node = $node } switch 1 { 0 { $_ $ q_node_id { update @@tree set node = $new where node = $node ; update @@tree set value = $new where node in ( select node from @@link ) and value = $node } } 1 { $_ $ q_node_id { update @@tree set node = $new where node = $node ; update @@tree set value = $new where exists ( select node from @@link where @@link.node = @@tree.node ) and value = $node } } } $_ $ q_node_idgt_up_node { select @@tree.node from @@tree where @@tree.up = $node and @@tree.node > $val order by @@tree.node limit 1 } #$_ $ q_node_link { # select @@tree.value as ref # from @@tree join @@link on @@tree.node = @@link.node # where @@tree.up = $node #} # this subselect variant is two orders of magnitude faster than a join # on @@link switch 1 { 0 { $_ $ q_node_link { select @@tree.value as ref from @@tree where @@tree.node = $node and @@tree.node in (select node from @@link) } } 1 { $_ $ q_node_link { select @@tree.value as ref from @@tree where @@tree.node = $node and exists ( select node from @@link where node = @@tree.node ) } } } #$_ $ q_node_link_top { # select @@tree.node ,@@tree.value as target # from @@tree join @@link on @@tree.node = @@link.node # where @@tree.node = @@tree.up #} # this subselect variant is two orders of magnitudefaster than a join # on @@link switch 1 { 0 { $_ $ q_node_link_top { select @@tree.node ,@@tree.value as target from @@tree where @@tree.node = @@tree.up and @@tree.node in ( select node from @@link ) } } 1 { $_ $ q_node_link_top { select @@tree.node ,@@tree.value as target from @@tree where @@tree.node = @@tree.up and exists ( select node from @@link where node = @@tree.node ) } } } #$_ $ q_node_link_node { # select @@tree.value as ref # from @@tree join @@link on @@tree.node = @@link.node # where @@tree.node = $node #} # this subselect variant is two orders of magnitude faster than a join on @@link switch 0 { 0 { $_ $ q_node_link_node { select @@tree.value as ref from @@tree where @@tree.node = $node and exists ( select node from @@link where node = @@tree.node ) } } 1 { $_ $ q_node_link_node { select @@tree.value as ref from @@tree where @@tree.node = $node and @@tree.node in (select node from @@link) } } } switch 0 { 0 { # this subselect variant is two orders of magnitue faster than # a join on @@link $_ $ q_node_link_target { select @@tree.node ,@@tree.value as target from @@tree where @@tree.up = $node and @@tree.node in (select node from @@link) } } 1 { # this subselect is much slower than the # @@tree.node in (select) # variant $_ $ q_node_link_target { select @@tree.node ,@@tree.value as target from @@tree where @@tree.up = $node and exists ( select 1 from @@link where node = @@tree.node limit 1 ) } } 2 { $_ $ q_node_link_target { select @@tree.node ,@@tree.value as target from @@tree left join @@link on @@tree.node = @@link.node where @@tree.up = $node and @@link.node is not null } } } switch 0 { 0 { $_ $ q_node_links { select node from @@tree where node in ( select node from @@link ) and value = $node } } 1 { # this is orders of magnitude slower than the # node in (select ...) # variant $_ $ q_node_links { select node from @@tree where exists ( select node from @@link where node = @@tree.node ) and value = $node } } } $_ $ q_node_refs { with recursive [t_with_refs_where_value t1 {= $node}] select node as @name0@ ,up as @name1@ from t1 } $_ $ q_refs_descendants { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] ,[t_with_refs_where_value t1 {in (select node from r0)}] select node as @name0@ from t1 } switch 0 { 0 { $_ $ q_refsunder_other { with recursive t0[t_subtree @@tree {where node = $in}] , [t_with_refs_where_value t1 { = $node}] , [t_with t2 t3 t0 {where t0.node = t1.node} [t_recurse_up t2] table t1] select t1.node as @name0@, t1.up as @name1@ from t1 where exists ( select 1 from t3 where t3.top = t1.node and t3.ref = $other limit 1 ) } } 1 { $_ $ q_refsunder_other { with recursive t0[t_subtree @@tree {where node = $in}] , [t_with r0 r1 t0 {where t0.node = $other} [t_recurse r0]] , [t_with_refs_where_value t1 {in (select node from r0)}] , [t_with r2 r3 @@tree {where @@tree.node = t1.node} [t_recurse r2] \ table t1] select orignode as @name0@, up as @name1@ from r3 where ref = $node } } 2 { $_ $ q_refsunder_other { with recursive t0[t_subtree @@tree {where node = $in}] , [t_with_refs_where_value t1 { = $node}] , [t_with t2 t3 t0 {where t0.node = t1.node} [t_recurse_up t2] table t1] select t3.top as @name0@, ( select up from @@tree where node = t3.top ) as @name1@ from t3 where t3.ref = $other } } } switch 0 { 0 { $_ $ q_deeprefsunder_other { with recursive [t_with t2 t3 @@tree {where @@tree.node = $node} [t_recurse t2]] , [t_with t4 t5 @@tree {where @@tree.node = $other} [t_recurse t4]] select t5.orignode as @name0@, t5.up as @name1@ from t3 ,t5 where t5.ref = t3.orignode } } 1 { $_ $ q_deeprefsunder_other { with recursive [t_with t2 t3 @@tree {where @@tree.node = $node} [t_recurse t2]] , [t_with t4 t5 @@tree {where @@tree.node = $other} [t_recurse t4]] select t5.orignode as @name0@, t5.up as @name1@ from t5 where t5.ref is not null and t5.ref in ( select orignode from t3 ) } } } $_ $ q_dr_other { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] ,[t_with_refs_where_value t1 {in (select node from r0)}] , [t_with r2 r3 @@tree {where @@tree.node = $other} [t_recurse r2]] select node as @name0@ ,up as @name1@ from t1 where node in ( select orignode from r3 ) } $_ $ q_dr_other_count { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] ,[t_with_refs_where_value t1 {in (select node from r0)}] , [t_with r2 r3 @@tree {where @@tree.node = $other} [t_recurse r2]] select count(node) from t1 where node in ( select orignode from r3 ) } $_ $ q_nodr_other { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] ,[t_with_refs_where_value t1 {in (select node from r0)}] , [t_with r2 r3 @@tree {where @@tree.node = $other} [t_recurse r2]] select orignode as @name0@ from r1 where not exists ( select orignode from r3 where orignode = r1.orignode ) } $_ $ q_refs_descendants? { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] ,[t_with_refs_where_value t1 {= $node}] select 1 from t1 limit 1 } $_ $ q_node_refs? { with recursive [t_with_refs_where_value t1 {= $node}] select 1 from t1 limit 1 } $_ $ q_size { select count(*) from @@tree } $_ $ q_node_last_root_node { select node from @@tree where up = node order by node desc limit 1 } switch @forgevariant@ { sqltmptable { $_ $ q_node_forge_up_node_0 { ; delete from @@forge ; insert into @@forge values ( $node, 0 ,0 ) } $_ $ q_node_forge_up_node_1 { ; insert or ignore into "@@values" values ( null ,[lossless @value@] ) ; update @@forge set changes = total_changes() + 1 ; insert into @@tree select coalesce(( select max(node) + 1 from @@tree ), 0) , (select node from @@forge) , (select node from "@@values" where value = [lossless @value@]) where not exists ( [join [t_treevalquery { node } { @@tree.up = (select node from @@forge) and @@tree.up != @@tree.node } = [lossless @value@] { order by node desc limit 1 } 0]] ) ; update @@forge set created = created + 1 where changes != total_changes() ; update @@forge set node = ( [join [t_treevalquery { node } { @@tree.up = (select node from @@forge) and @@tree.up != @@tree.node } = [lossless @value@] { order by node desc limit 1 } 0]] ) } $_ $ q_node_forge_up_node_2 { ; select node, created from @@forge } } iterpivot - sqlpivot { $_ $ q_node_forge_up_node [t_treevalquery { node } { @@tree.up = $node and @@tree.up != @@tree.node } = [lossless \$value] { limit 1 } 0] } } $_ $ q_node_forge_up_top [t_treevalquery { node as node } { @@tree.node = @@tree.up } = [lossless \$value] { limit 1 } 0] $_ $ q_node_last_node_node { select node from @@tree where up = $node and @@tree.node != @@tree.up order by node desc limit 1 } switch 0 { 0 { $_ $ q_node_last_node_value { with t1(node) as ( select node from @@tree where @@tree.up = $node and @@tree.up != @@tree.node order by node desc limit 1 ) , [t_with r0 r1 @@tree {where @@tree.node = t1.node} \ {} table t1] select value from r1 } } 1 { # this is much faster $_ $ q_node_last_node_value [t_treevalquery { value } { @@tree.up = $node and @@tree.up != @@tree.node } {} {} { order by node desc limit 1 } 1] } 2 { $_ $ q_node_last_node_value { with t1(node) as ( select node from @@tree where @@tree.up = $node and @@tree.up != @@tree.node order by node desc limit 1 ) , t3[t_with_value] select t3.value from t3 join t1 on t1.node = t3.node } } } switch 0 { 0 { $_ $ q_node_last_root_value { with t1(node) as ( select node from @@tree where @@tree.up = @@tree.node order by node desc limit 1 ) , [t_with r0 r1 @@tree {where @@tree.node = t1.node} \ {} table t1] select value from r1 } } 1 { $_ $ q_node_last_root_value { with t1(node) as ( select node from @@tree where @@tree.up = @@tree.node order by node desc limit 1 ) , t3[t_with_value] select t3.value from t3 join t1 on t1.node = t3.node } } 1 { $_ $ q_node_last_root_value [t_treevalquery { value } { @@tree.node = @@tree.up } {} {} { order by node desc limit 1 } 1] } } $_ $ q_node_leaves { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] , r2(node ,up ,link ,ref ,value ,level, top) as ( select * from r0 where not exists ( select 1 from @@tree t2 where t2.up = r0.node ) ) select node as @name0@ from ([t_with_select_nonames r2 r1 {}]) } $_ $ q_node_leavesvalue { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] , r2(node ,up ,link ,ref ,value ,level, top) as ( select * from r0 where not exists ( select 1 from @@tree t2 where t2.up = r0.node ) ) , t3[t_with_value] select (select value from t3 where t3.node = r2.node ) as @name0@ from r2 -- select case when r2.link is null then r2.value else t3.value end -- as @name0@ from r2 join t3 on r2.ref = t3.node -- order by r2.level desc } $_ $ q_node_count { select count(*) from @@tree where up = $node and node != $node } $_ $ q_top_count { select count(*) from @@tree where node = up } $_ $ q_node_highest { select max(node) from @@tree } $_ $ q_treenodenext_node_up_node { select node as @name0@ from @@tree where up = ( select up from @@tree where node = $node ) and node > $node order by node limit $limit offset $offset } $_ $ q_treenodenext_noalias_node_up_node { select node from @@tree where up = ( select up from @@tree where node = $node ) and node > $node order by node limit $limit } $_ $ q_treenodenext_up_top_node { error [list {to do}] } $_ $ q_treevals_up_top_node { select node as @name0@ from @@tree where up = node } $_ $ q_treevalspart_up_top_node { select node as @name0@ from @@tree where up = node order by node limit $limit offset $offset } $_ $ q_treevalslike_up_top_node { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse_up r0]] select orignode as @name0@ from r1 where up = node and value like $value } $_ $ q_treevals_up_top_value [t_treevalquery { value as @name0@ } { @@tree.node = @@tree.up } {} {} {} 1] $_ $ q_node_path_node { with recursive [t_with_path t1 node] select node as @name0@ from t1 order by level desc } $_ $ q_node_path_value { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse_up r0]] select value as @name0@ from ([t_with_select_nonames r0 r1 {}]) order by level desc } $_ $ q_node_forth { select node from @@tree where not exists ( select * from @@tree where node = $node and up = node ) and up = ( select up from @@tree where node = $node ) and node > $node union select node from @@tree where node = up and node > $node order by node limit 1 } $_ $ q_insert_values_value { insert into "@@values" values (null ,[lossless \$value]) } $_ $ q_node_new_value_exists { select 1 from "@@values" where value = [lossless \$value] } $_ $ q_node_back { select node from @@tree where up = ( select up from @@tree where node = $node ) and node < $node order by node desc limit 1 } $_ $ q_node_traverse { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] select node as @name0@ ,up as @name1@ ,ref as @name2@ ,value as @name3@ ,level as @name4@ from ([t_with_select_nonames r0 r1 {}]) } $_ $ q_node { select node from @@tree where node = $node } $_ $ q_node_empty { select count(node) == 0 from @@tree where up = $node and node != $node limit 1 } $_ $ q_top_empty { select count(node) == 0 from @@tree where node = up limit 1 } $_ $ q_node_lsempty { with t1(node) as ( select node as @name0@ from @@tree where up = $node and node != up order by node ) select node from t1 where not exists ( select 1 from @@tree where up = t1.node ) } $_ $ q_node_lsempty_top { error {to do} } $_ $ q_node_lsfull { with t1(node) as ( select node as @name0@ from @@tree where up = $node and node != up order by node ) select node from t1 where exists ( select 1 from @@tree where up = t1.node ) } $_ $ q_node_under { with recursive t1 (node ,level) as ( select up , 1 as level from @@tree where node = $node and up != $node union all select up, level + 1 as level from @@tree, t1 where @@tree.node = t1.node and @@tree.node != @@tree.up ) select level from t1 where node = $other } if 0 { $_ $ q_node_val { with [t_with r0 r1 @@tree {where @@tree.node = $node} {}] select value from ([t_with_select_nonames r0 r1 {}]) where value is not null } } else { $_ $ q_node_val [t_treevalquery { value } { @@tree.node = $node } {} {} {} 0] } $_ $ q_node_valueid { with recursive [t_query_resolvelink r { and @@tree.node = $node }] select value from @@tree where node = $node and node not in ( select node from @@link ) union all select ref from r where not exists ( select node from @@link where @@link.node = r.node ) } $_ $ q_node_linkval_set { ; insert or ignore into @@link values ( $node ) ; update @@tree set value = $ref where node = $node } $_ $ q_node_val_set { insert or ignore into "@@values" values (null ,[lossless \$value]) ; update @@tree set value = ( select node from "@@values" where value = [lossless \$value] ) where node = $node } $_ $ q_up& { select up from @@tree where node = $node and up != node order by node desc limit 1 } switch 0 { 0 { # this is much faster when pivoting to nodes that already exist # but no faster when searching for a node that doesn't. $_ $ q_pivot_name { with [t_with r0 r1 @@tree [subst -nobackslashes -novariables { where @@tree.up = $node and @@tree.node != @@tree.up }] {}] select orignode from r1 where value = [lossless \$value] order by orignode desc limit 1 } } 1 { # to do # isn't this incomplete in the link case? $_ $ q_pivot_name { ; select @@tree.node from @@tree , "@@values" where @@tree.up = $node and @@tree.node != @@tree.up and ( ( @@tree.node not in (select node from @@link) and @@tree.value = "@@values".node and "@@values".value = [lossless \$value] ) or ( @@tree.node in (select node from @@link) and ( ) ) ) order by @@tree.node desc limit 1 } } 2 { $_ $ q_pivot_name [t_treevalquery { node } { @@tree.up = $node and @@tree.up != @@tree.node } = [lossless \$value] { order by node desc limit 1 } 1] } } $_ $ q_pivot_simple { select @@tree.node from @@tree where @@tree.up = $node and @@tree.up != @@tree.node and @@tree.value = $valueid and @@tree.node not in (select node from @@link) order by @@tree.node desc limit 1 } if 0 { $_ $ q_pivot_name_simple { select @@tree.node from @@tree where @@tree.up = $node and @@tree.up != @@tree.node and @@tree.node not in (select node from @@link) and [lossless \$value] = ( select value from "@@values" where "@@values".node = @@tree.value ) } } # This query is faster than the subselect version $_ $ q_pivot_name_simple { select @@tree.node from @@tree join "@@values" on @@tree.value = "@@values".node where @@tree.up = $node and @@tree.up != @@tree.node and @@tree.node not in (select node from @@link) and [lossless \$value] = "@@values".value } # This query has been measured to be about 20% faster than the same # query reworded to use "join" $_ $ q_check_value { select @@tree.node from @@tree where @@tree.node = $node and [lossless \$value] = ( select value from "@@values" where "@@values".node = @@tree.value ) order by @@tree.node desc limit 1 } $_ $ q_valueid { select node from "@@values" where value = [lossless \$value] } # no significant performance difference between these variants switch 0 { 0 { $_ $ q_pivot_top_simple { select @@tree.node from @@tree where @@tree.up = @@tree.node and @@tree.node not in (select node from @@link) and [lossless \$value] in ( select value from "@@values" where "@@values".node = @@tree.value ) } } 1 { $_ $ q_pivot_top_simple { select @@tree.node from @@tree left join @@link on @@tree.node = @@link.node where @@tree.up = @@tree.node and @@link.node is null and [lossless \$value] in ( select value from "@@values" where "@@values".node = @@tree.value ) } } 2 { $_ $ q_pivot_top_simple { select @@tree.node from @@tree join "@@values" on @@tree.value = "@@values".node left join @@link on @@tree.node = @@link.node where @@tree.up = @@tree.node and @@link.node is null and [lossless \$value] = "@@values".value } } } $_ $ q_pivot_subquery { with [t_with r0 r1 @@tree {where @@tree.up = ( @subquery@ )} {}] select node from ([t_with_select_nonames r0 r1 {}]) where value = @value@ order by node desc } $_ $ q_pivot_name_top { with [t_with r0 r1 @@tree [subst -nobackslashes -novariables { where @@tree.up = @@tree.node }] {}] select orignode from r1 where value = [lossless \$value] order by orignode desc limit 1 } $_ $ q_pivot_node { select node from @@tree where node = $arg_0 order by node desc limit 1 } $_ $ q_pivot_roots { select node from @@tree where up = node order by node limit 1 } $_ $ q_select_values_node_from_value { select node , value , typeof(value) from "@@values" where value = [lossless \$value] } $_ $ q_tree_delete_node_top { delete from @@tree where up = $node and node = $node } $_ $ q_tree_delete_node_children { delete from @@tree where up = $node and node != $node } $_ $ q_tree_insert_link_top { -- do this first to avoid using last_insert_rowid, -- which might be affected by triggers insert into @@link values ( (select max(node) + 1 from @@tree) ) ; insert into @@tree values ( (select max(node) + 1 from @@tree) , (select max(node) + 1 from @@tree) , $ref ) } $_ $ q_tree_insert_link { -- do this first to avoid using last_insert_rowid, -- which might be affected by triggers insert into @@link values ( (select max(node) + 1 from @@tree) ) ; insert into @@tree values ( (select max(node) + 1 from @@tree) , $node ,$ref ) } $_ $ q_tree_editlink { update @@tree set value = cast($reference as numeric) where node = $node ; insert or ignore into @@link values ( $node ) } $_ $ q_tree_insert_value { insert into @@tree values ( (select max(node) + 1 from @@tree) ,$node ,$ref ) } $_ $ q_tree_insert_value_top { insert into @@tree values ( coalesce(( select max(node) + 1 from @@tree ), 0) , coalesce(( select max(node) + 1 from @@tree ), 0) ,$ref ) } $_ $ q_tree_forth { select coalesce(( select max(node) + 1 from @@tree ), 0) } $_ $ q_tree_select_node { select 1 from @@tree where node = $node } $_ $ q_treevals_node_up_node { [t_q_treevals_node_up_node] order by node } $_ $ q_treevals_node_up_node_order_value { [t_q_treevals_node_up_node] order by value } $_ $ q_treevalspart_node_up_node { select node as @name0@ from @@tree where up = $node and node != up order by node limit $limit offset $offset } $_ $ q_treevalsglob_any_node { with [t_query_compare_node glob [t_recurse r0]] } $_ $ q_treevalsglob_any_top_node { error {to do} } $_ $ q_treevalsglob_any_top { error {to do} } $_ $ q_treevalseq_any_node { with [t_query_compare_node = [t_recurse r0]] } $_ $ q_treevalseq_any_top { with [t_query_compare_top = [t_recurse r0]] } $_ $ q_under_links_findeq_node { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] , [t_links t2 r0 @@tree] , [t_with r2 r3 @@tree {where @@tree.node = t2.target} [t_recurse r2] table t2] , t4(top, orignode ,finalnode, value) as ( select top, orignode, finalnode, value from r1 union all select top, orignode, finalnode, value from r3 ) select node as @name0@ from t2 where target in ( select top from t4 where value = [lossless \$value] ) } $_ $ q_under_links_findeq_top { error {to do} } $_ $ q_treevalslike_any_node { with [t_query_compare_node like [t_recurse r0]] } $_ $ q_treevalslike_any_top_node { error {to do} } $_ $ q_treevalsmatch_any_node { with [t_query_compare_node match [t_recurse r0]] } $_ $ q_treevalsmatch_any_top_node { error do do } $_ $ q_treevalsmatch_any_topnode { error to do } $_ $ q_treevalsregexp_any_node { with [t_query_compare_node regexp [t_recurse r0]] } $_ $ q_treevalsregexp_any_top_node { error to do } $_ $ q_treevalsmatch_any_node { with [t_query_compare_node match [t_recurse r0]] } $_ $ q_treevalseq_node_up_node { with [t_query_compare_node = {}] } $_ $ q_treevalseq_up_top_node { error to do } $_ $ q_treevalsglob_node_up_node { with [t_query_compare_node glob {}] } $_ $ q_treevalslike_node_up_node { with [t_query_compare_node like {}] } $_ $ q_treevalsregexp_node_up_node { with [t_query_compare_node regexp {}] } $_ $ q_treevals_node_up_node_tail { with t1(node) as ( select node from @@tree where up = $node and node != up order by node desc limit $limit ) select node as @name0@ from t1 order by node } $_ $ q_treevals_up_top_node_tail { error to do } $_ $ q_treevals_value_up_node { with [t_with r0 r1 @@tree {where @@tree.up = $node and @@tree.node != @@tree.up} {}] select value as @name0@ from ([t_with_select_nonames r0 r1 {}]) order by node } $_ $ q_treevals_value_up_nodelike { with [t_with r0 r1 @@tree {where @@tree.up = $node and @@tree.node != @@tree.up} {}] select value as @name0@ from ([t_with_select_nonames r0 r1 {}]) where value like %$like% order by node } $_ $ q_tree_examine_top { select node as @name0@ ,up as @name1@ , value as @name2@ ,typeof(node) as @name3@ ,typeof(up) as @name4@ ,typeof(value) as @name5@ ,ref as @name6@ ,typeof(ref) as reftype from ( with [t_with r0 r1 @@tree {} {}] [t_with_select_nonames r0 r1 {}] ) } $_ $ q_walk_root { with recursive [t_with r0 r1 @@tree {where @@tree.node = @@tree.up or not exists ( select 1 from @@tree as tree2 where tree2.node = @@tree.up )} [t_recurse r0]] [t_with_select r0 r1 {}] } $_ $ q_walk_node { with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] [t_with_select r0 r1 {where r0.node != $node}] } $_ $ s_delete_node { delete from "@@values" where ( select count(*) from @@link where node = $node ) == 0 and ( select count(*) from @@tree where value = ( select value from @@tree where node = $node ) and node not in (select node from @@link) ) == 1 and "@@values".node = (select value from @@tree where node = $node) ; delete from @@link where @@link.node = $node ; delete from @@tree where node = $node } $_ $ s_insert_value { create temp table if not exists @@tree_insert_value ( value integer primary key ) without rowid ; delete from @@tree_insert_value ; insert into @@tree_insert_value select coalesce( (select max(node)+1 from @@tree) ,0) ; insert or ignore into "@@values" values (null ,[lossless \$value]) ; insert into @@tree values ( (select value from @@tree_insert_value) ,$up ,(select node from "@@values" where value = [lossless \$value]) ) ; select value from @@tree_insert_value } $_ $ s_insert_link { create temp table if not exists @@tree_insert_link ( value integer primary key ) without rowid ; delete from @@tree_insert_link ; insert into @@tree_insert_link select coalesce( (select max(node)+1 from @@tree) ,0) -- inserts NULL if the variable "value" does not exist in the local -- scope -- to do: is this behaviour accounted for everywhere? ; insert into @@tree values ( (select value from @@tree_insert_link) ,$up ,$value ) ; insert into @@link select value from @@tree_insert_link ; select value from @@tree_insert_link } $_ $ s_move_to { ; update @@tree set up = $to where node = $node } $_ $ s_node_cp { create temp table @@tree_cp ( node integer primary key , orignode numeric , origlink numeric , up numeric , value numeric ) ;insert into @@tree_cp with recursive [t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]] select coalesce((select max(node) + 1 from @@tree), 0) + row_number() over () as newnode , node , link ,up , ref from ([t_with_select_raw_nonames r0]) as t1 ; insert into @@link select node from @@tree_cp where origlink is not null ; update @@tree_cp as t1 set value = ( select t2.value from @@tree_cp as t2 where t2.orignode = t1.origlink ) where origlink in ( select orignode from @@tree_cp ) ; insert into @@tree select node , case when orignode = $node then $to else ( select t2.node from @@tree_cp as t2 where t1.up = t2.orignode ) end ,value from @@tree_cp as t1 ; drop table @@tree_cp } $_ $ sql_select_tree_forth { select coalesce(max(node) + 1, 0) from @@tree } $_ $ sql_create_table_readmap { create table if not exists @@readmap ( old integer primary key ,new numeric ) without rowid ; delete from @@readmap } $_ $ sql_link_delete { delete from @@link where node = $node } $_ $ sql_readchan_delete { delete from @@readchan_value where id = $id } if 0 { this didn't work because sqlite's incrblob can't write files of arbitrary size into the database. $_ $ sql_readchan_tmptable { create table if not exists @@readchan_value ( id integer primary key ,value integer ) ; delete from @@readchan_value ; insert into @@readchan_value values (null ,'') ; select last_insert_rowid() from @@readchan_value } $_ $ sql_readchan_queryvalues { select node from "@@values" where value = ( select value from @@readchan_value where id = $id ) } $_ $ sql_readchan_insert { insert or ignore into "@@values" select null ,value from @@readchan_value where id = $id ; update @@tree set value = ( select node from "@@values" where value = ( select value from @@readchan_value where id = $id ) ) where node = $newnode } } $_ $ sql_delete_table_readmap { ; delete from @@readmap } $_ $ sql_select_table_readmap { select old, new from @@readmap } $_ $ sql_insert_table_readmap { insert into @@readmap values ( $node , $new ) } $_ $ sql_repoint { update @@tree set value = $target where node = $node } $_ $ sql_table_tree_readmap { update @@tree set up = ( select new from @@readmap where @@tree.up = @@readmap.old ) where @@tree.node in (select new from @@readmap) ; update @@tree set value = ( select new from @@readmap where @@tree.value = @@readmap.old ) where @@tree.node in (select new from @@readmap) and @@tree.node in (select node from @@link) } $_ $ sql_values_count { select count(*) from "@@values" } $_ $ sql_value_get { select value from "@@values" where node = $id } }] } [namespace current]] accelerate }] ;# end string map } [namespace current]] ;# end ::apply