\ B-trees                                                            vandys
\ The order of the B-tree nodes is set at compile time.  Nodes
\  can be deleted, but no tree reblancing occurs, so an unbalanced
\  B-tree is possible.

\ A node has a cell for the parent, and for the child
\  before the lowest key, followed by #BNODE pairs of cells.

\ Each pair is made up of a key and a value.

\ If a node holds leafs, then the child pointer is 0, otherwise this
\  node is interior.  For leaf nodes, the "value" of each pair is
\  is the actual value for the given key.  For interior nodes, the
\  value is a pointer to a sub-node.

\ The "key" for interior nodes indicates the starting range for the
\  key space below it.  The initial cell holds a pointer to a sub-node
\  for keys before the lowest key value in the node.

\ The "key" value must be non-zero, as this implementation uses that
\  value as a sentinel for end of valid key/value pairs.
\     MORE COMMENTS ON SHADOW



\ B-trees basic manipulation                                         vandys
only extensions definitions

32 dup constant #BNODE Local   1+ 2* cells constant BNSIZE Local
: (bn>parent) ( node -- parentptr ) ; Local
: (bnode) ( parent -- node )   BNSIZE bkzalloc   tuck (bn>parent) ! ; Local
: (bn>child) ( node -- childptr )   cell+ ; Local
: (bn>pairs) ( node -- ptr )   cell+ cell+ ; Local
: (bnleaf?) ( node -- <bool> )   (bn>child) @ 0= ; Local
: (bnroot?) ( node -- <bool> )   (bn>parent) @ 0= ; Local
: btempty? ( node -- <bool> )   (bn>pairs) @ 0= ; Local

: (bnindex) ( key node -- keyptr )
   (bn>pairs) begin   @+ ?dup   while ( key node-val node-key )
      2 pick u> if   nip cell- exit   then
   cell+ repeat   nip cell- ; Local

: btalloc ( -- btree )   0 (bnode) ; Local







\ B-trees lookup                                                     vandys

: (key>leaf) ( key node -- node' )   begin   dup (bnleaf?) not   while
      over swap (bnindex) cell- @   repeat   nip ; Local

: bt@ ( key node -- val T | F )   over 0= abort" Bad key"
   dup btempty? if   2drop false exit then
   over swap (key>leaf) ( key leafnode )
   over swap (bnindex) cell- cell- ( key keyptr )
   tuck @ = if   cell+ @ true   else   drop false   then ; Local















\ B-trees insertion                                                  vandys

: (bnfull?) ( node -- <bool> )
   (bn>pairs) #BNODE 1- 2* cells + @ 0<> ; Local

variable 'count Local
: (bninsert) ( val key node keyptr -- )   'count @ ?dup if inc then
   tuck ( val key keyptr node keyptr )
   swap (bn>pairs) - 2 cells /   ( val key keyptr cnt )
   #BNODE swap - 1- 2* cells   ( val key keyptr cntcells )
   over dup cell+ cell+   rot move   2! ; Local

: (bnset) ( val key node -- )   2dup (bnindex)   ( val key node keyptr )
   dup cell- cell- @ 3 pick = if   nip nip cell- !
   else   (bninsert)   then ; Local










\ B-trees insertion                                                  vandys

: (reparent) ( node subnode -- )   (bn>parent) ! ; Local
: (bnreparent) ( node -- )   dup (bnleaf?) abort" Reparent leaf"
   dup dup (bn>child) @ (reparent)
   dup (bn>pairs) begin   @+   while
      @+ ( node nextkeyptr valnode )
      2 pick swap (reparent)   repeat 2drop ; Local

: (copy2ndleaf) ( node node' -- )   swap (bn>pairs) #BNODE cells +
   swap (bn>pairs)   #BNODE cells move ; Local
: (copy2nd) ( node node' -- )   over (bnleaf?) if
      (copy2ndleaf) exit   then
   swap (bn>pairs) #BNODE 1+ cells +
   swap (bn>child)   #BNODE 1- cells move   dup (bnreparent) ; Local

: (clear2nd) ( node -- key )   (bn>pairs) #BNODE cells +
   dup @ swap   #BNODE cells erase ; Local

: (bnhalve) ( node -- node node' key' )   dup (bn>parent) @ (bnode)
   2dup (copy2nd)   over (clear2nd) ; Local




\ B-trees insertion                                                  vandys

: (bnclone) ( node -- node' )   BNSIZE bkalloc   tuck BNSIZE move
   dup (bnleaf?) not if   dup (bnreparent)   then ; Local

: (rootParents) ( root node2 key2 node1 -- root node2 key2 node1 )
   3 pick over (bn>parent) !   3 pick 3 pick (bn>parent) ! ; scrLocal
: (bnAddRoot) ( root node2 key2 -- )
   2 pick (bnclone)   (rootParents)   ( root node2 key2 node1 )
   >r rot dup BNSIZE erase ( node2 key2 root R: node1 )
   dup >r (bn>pairs) 2!   r> r> swap (bn>child) ! ; Local














\ B-trees insertion, enumeration                                     vandys
: (bnsplit) ( node -- node' )
   (bnhalve)   ( node node' key' )   over (bnroot?) if
      2 pick >r   (bnAddRoot)   else
      rot (bn>parent) @   dup >r   (bnset)   then   r> ; Local

: bt! ( value key node -- )   dup btempty? if
      (bn>pairs) 2!   exit then
   over swap (key>leaf) ( value key leafnode )
   dup >r (bnset) r> ( leafnode )
   begin   dup (bnfull?)   while   (bnsplit)   repeat drop ; Local

: (btDo) ( arg fn bt -- )   begin   cell+ cell+ dup @   while
   3dup 2@ rot execute   repeat   3drop ; Local
: btDo ( arg fn bt -- )   dup (bnleaf?) if   (btDo) exit   then
   cell+ >r 2dup r@ @ recurse   r>
   begin cell+ @+ while   3dup @ recurse
   repeat   3drop ; Local







\ B-trees testing                                                    vandys

[ifdef] TESTING \ Testing
variable (bcheckKey)
: (checkKey) ( key -- )   dup (bcheckKey) @ <= abort" Bad key"
   (bcheckKey) ! ;
: (bcheckLeaf) ( node -- )   dup (bn>child) @ abort" Child"
   (bn>pairs) begin   @+ ?dup while   ( valptr curkey )
      (checkKey)   cell+ repeat   drop ;

: (bcheck) ( parent node -- )   tuck
   (bn>parent) @ - abort" Parent mismatch"
   dup (bnleaf?) if   (bcheckLeaf) exit   then
   dup dup (bn>child) @ recurse
   dup (bn>pairs)   begin   @+   ?dup while   (checkKey)
      @+ ( node nextkeyptr subnode )
      -1 (bcheckKey) +!   2 pick swap recurse ( node nextkeyptr )
   repeat   2drop ;

: bcheck   ( node -- )   dup (bnroot?) not abort" Not at root"
   (bcheckKey) off   0 swap (bcheck)
   ." Highest key is" (bcheckKey) ? cr ;



\ B-trees testing, display, size                                     vandys

btalloc constant b
: (tb)   dup .   b bcheck ;
: tb   extensions.randstate off
   10000 0 do   i   extensions.random 100000 mod
   b bt!   loop ;

[then] \ TESTING

: (.leaf) ( arg val key -- )   space
   1 u.r ." ->"  1 u.r   drop ;
: .bt ( bt -- )   0 swap ['] (.leaf) swap btDo ; Local












\ B-trees cleanup                                                    vandys

: (btfree) ( bt -- )   dup (bnleaf?) if   bkfree exit   then
   cell+ @+ recurse   begin @+ while   dup @ recurse
      cell+ repeat ; scrLocal

: btfree ( bt -- )   (btfree) bkfree ; Local

: btempty! ( bt -- )   (btfree)   BNSIZE erase ; Local
















\ B-trees key utilities                                              vandys

: (nextover) ( bt -- bt' T | F )   dup (bn>parent) @ ( bt parent )
   dup 0= if   nip exit   then
   (bn>child) ( bt 'val ) begin
      2dup @ = if
         cell+ @+ if   nip @ true exit   else
            drop (bn>parent) @   tailrecurse then
      then
   cell+ @+ 0= until   1 abort" Child not in parent" ; scrLocal

: (bt>sib) ( bt -- bt' T | F )   (nextover) 0= if   false exit   then
   begin   dup (bnleaf?) 0=   while   (bn>child) @   repeat
   true ; scrLocal

: btnextKey ( u bt -- u' T | F )   over swap (key>leaf) ( u btleaf )
   tuck (bnindex)   ( bt 'key ) @ ?dup if   nip true exit   then
   (bt>sib) 0= if   false exit   then
   (bn>pairs) @ true ; Local






\ B-trees more key utilities                                         vandys

: (bn>lastkey) ( bt -- 'key )   (bn>pairs) begin @+ while
      cell+   repeat   cell- cell- cell- ; Local
: bttopKey ( bt -- key )   dup btempty? abort" Empty btree"
   begin   dup (bn>lastkey)   swap (bnleaf?) if   @ exit   then
      cell+ @   again ; Local


















\ B-trees more key utilities                                         vandys

: bt>prev ( bt parent -- bt' | 0 )   (bn>pairs) begin @+ while
      ( bt a-val ) 2dup @ = if   nip cell- cell- @ exit   then
   cell+ repeat   2drop 0 ; scrLocal
: bt>lastLeaf ( bt -- bt' )   begin   dup (bnleaf?) 0=   while
      (bn>lastkey) cell+ @   repeat ; scrLocal
: bt>-sib ( btleaf -- btleaf' )
   begin   dup (bn>parent) @   ?dup while ( bt parent )
      tuck bt>prev   ?dup if   nip bt>lastLeaf exit   then
   repeat   drop 0 ; scrLocal

: backup ( btleaf a-key -- btleaf' a-key' T | F )
   over (bn>pairs) over <> if   cell- cell- true exit   then
   drop bt>-sib dup if   dup (bn>lastkey) true exit   then ; Local










\ B-trees more key utilities                                         vandys

: btprevKey ( u bt -- u' T | F )   over swap (key>leaf) ( u btleaf )
   2dup (bnindex)   ( u btleaf a-key )
   backup 0= if   drop false exit   then
   2 pick over @ = if   backup 0= if   drop false exit   then   then
   nip nip @   true ; Local


















\ B-trees OO class wrapper                                           vandys
Collection -> subclass: Btree
   ivars: intcell tree   intcell count endivars
Btree -> class -> :method new ( self -- bt )   super-> new ( bt )
   btalloc over Btree>tree ! method;
Btree -> :method ! ( val key self -- )   dup Btree>count 'count !
   Btree>tree @ bt!   'count off method;
Btree -> :method @ ( key self -- val T | F )   Btree>tree @ bt@ method;
Btree -> :method do ( arg self -- )   Btree>tree @ btDo method;
Btree -> :method .elems ( self -- )   Btree>tree @ .bt method;
Btree -> :method free ( self -- )   dup Btree>tree @ btfree
   super-> free method;
Btree -> :method nextKey ( u self -- u' )   Btree>tree @ btnextKey method;
Btree -> :method topKey ( self -- u )   Btree>tree @ bttopKey method;
Btree -> :method prevKey ( u self -- u' )   Btree>tree @ btprevKey method;
Btree -> :method size ( self -- u )   Btree>count @ 1+ method;

Btree -> :method in? ( key self -- ? )   -> @   dup if nip then method;
Btree -> :method empty! ( self -- )   btempty! method;

                                                                     vandys
The sentinal pair at the end of the node actually gets used transiently
 during an insertion.  The way an insertion works is that the new
 key/value pair is always inserted into the node.  If the last, "sentinel"
 pair is then found to be used, the node is known to be "full", and it
 is split in two, with the new latter half being inserted up into the
 parent.


















                                                                     vandys


Number of entries stored per B-tree node
: (bn>parent) Point to parent pointer of a node
: (bnode) Allocate bnode, setting parent
: (bn>child) Point to the child pointer of a node
: (bn>pairs) Point to first of pairs under a node
: (bnleaf?) Tell if the given node is a leaf
: (bnroot?) Tell if node is root of btree
: btempty? Tell if node has no key/value pairs

: (bnindex) Return the key pointer for the key passed in
   Scan across pairs, looking for exact match
      Got it, return
   Advance... at end of loop, point beyond last key pointer

: btalloc Allocate top of an (empty) btree









: (key>leaf) Return the leaf node which would hold this key


: bt@ Look up key in btree, return value if present





















: (bnfull?) Tell if given node has all its key/value pairs filled


Pointer to key/val pair counter, if non-NULL
: (bninsert) Insert a key/value pair into the node





: (bnset) Insert a key/value pair; if the key is already present the
 value is simply updated, otherwise the pair is inserted.













: (reparent) Set parent of a node
: (bnreparent) Now that a set of entries has copied out from an old node,
 let each child node know about this new parent.




: (copy2ndleaf) Handle relatively easy case of the 2nd part of a node
 being split out when it's a leaf; nobody below needs to know about
 a new parent   : (copy2nd) otherwise does the copy and then arranges
 for reparenting.



: (clear2nd) Clear 2nd half of a node now that its contents has been
 copied to a new node.

: (bnhalve) Split a node in half, returning the 2nd half contents
 in a new node.  The key for this split point is also preserved.






: (bnclone) Create a new node, whose contents mirrors that of the
 passed original.

: (rootParents) Fixup parent pointers for nodes becoming
 children of root
: (bnAddRoot) 2nd part of root already split off, copy 1st part
 and reassemble with root pointing down to just the 1st and 2nd
 parts.
















: (bnsplit) Split a full node in half.  Special handling for root node,
 whose memory at that address must always remain at the top of the btree,
 thus we copy both halves out and make the root point down to the new
 pair of halves

: bt! Store value at given key in btree





: (btDo) Execute function across each leaf key/val pair

: btDo Recursively descend btree, invoke (btDo) on leaf nodes













































: (.leaf) Display contents of Btree leaf

: .bt Display btree














: btfree Free nodes of tree, depth first.  Passed node is NOT freed.



: btfree Free all sub-nodes, then this node itself

: btempty! Free all sub-nodes, then init this node to empty


















: (nextover) Given a node, find the next one over to a higher key value
   No parent, we're up out of the end of the whole tree
   Walk the value fields...
      When we find our lower node in the value field
         Pick up the next node over, or pop up and out of here

   Walk to next value field, pop up and out when we run out of keys


: (bt>sib) Move from one leaf node to its next upward kin
   Once we have next node over, drive down to first leaf node below
   Get first key from this leaf node

: btnextKey Given key, return next high and T, else F if none higher
   If have next highest key here, just return it
   Move to next leaf node over from us, return F if no more
   Return first key of this node








: (bn>lastkey) Return pointer to key of last key/value pair in node

: bttopKey Return highest key value in btree






















: bt>prev Given a node and its parent, return the one before this one
 in this parent, or 0

: bt>lastLeaf Given node, walk down to node with highest key under this
 part of the tree
: bt>-sib Walk from leaf to nearest leaf holding keys lower than ours




: backup Given node and key pointer, return node and key pointer for
 previous key.  This will either be two cells back on the same node (if
 there are key slots before the current one) or else a previous node with
 a pointer to the highest key in that node.  Returns 0 if there is no
 previous pointer










: btprevKey Given key, return next high and T, else F if none higher
   Get pointer to key position
   Back up to the key which is equal or less than current key
   If it's equal, back up before it
   Return that key



















The class; just a wrapper, except we also use this opportunity to keep
 a count of insertions to speed the size-of-btree query
Instance creation

Basic access


Display and enumeration

Free storage

Key traversal methods


:method size The count is bumped by 1 to reflect the special case of
 putting the initial key/value into an empty Btree
:method in? Tell if a given key is in the Btree
:method empty! Free up any sub-nodes, then init top to empty