! B-tree code module.  This module is %included in the system-specific
! database manager.  This module exports key management only, with data values
! consisting of %integers expected to be passed to/from the data record
! manipulation section (a separate module).
!
! Note that no effort is made to manipulate the tree in a way guaranteed to
! maintain consistency across crashes -- it is *assumed* that nothing will
! go wrong, or at least that the lower levels can back us up to the previous
! state of the file in extremis.


%externalstring(47) copyright tree %alias "GDMR_(C)_TREE.CORE" = %c
   "Copyright (C) 1987 George D.M. Ross"

%constinteger stack depth = 16;  ! More than enough.

%constinteger block slots = 253
%recordformat block fm(%short checksum,
                       %short flags,
                       %byte pointer limit, text limit,
                       %shortarray x(1 : block slots))
! Space usage:
!     pointers (to key text, children and data) grow from the start forward.
!     key text grows from the end backwards.
! Pointer arrangement:
!     pointers to children are separated by pairs consisting of
!     (pointer to key text, datum)
! NB  pointer to key is a %short
!     datum is an %integer
%constinteger leaf = 1;  ! Hence no child-pointers

%constinteger infinity = 16_3FFF0000;  ! Allow for arithmetic!!

%constinteger key limit = 127;  ! To avoid nasty split/merge problems

%constinteger key not found error = -501
%constinteger duplicate key error = -502
%constinteger null key      error = -503
%constinteger key size      error = -504
%constinteger bugcheck      error = -505


!! %routine zput string(%string(255) s)
!!    %integer i, ch
!!       %return %if s = ""
!!       %for i = 1, 1, length(s) %cycle
!!          ch = charno(s, i)
!!          %if ' ' <= ch <= '~' %start
!!             print symbol(ch)
!!          %else
!!             print symbol('<')
!!             write(ch, 0)
!!             print symbol('>')
!!          %finish
!!       %repeat
!! %end


! String comparison (case not significant).

%integerfn compare(%string(*)%name a, b)
   %integer l, m, p, q, d
   %bytename aa, bb
      l = length(a);  m = length(b)
      aa == charno(a, 1);  bb == charno(b, 1)
      %while l > 0 %and m > 0 %cycle
         ! Standardise case for comparison
         %if aa # bb %start
            %if 'A' <= aa <= 'Z' %then p = aa - 'A' + 'a' %else p = aa
            %if 'A' <= bb <= 'Z' %then q = bb - 'A' + 'a' %else q = bb
            d = p - q
            %result = d %if d # 0
         %finish
         l = l - 1;  m = m - 1
         aa == aa [1];  bb == bb [1]
      %repeat
      %result = length(a) - length(b)
%end


! (Explicit) stack management
! Doing it this way is considerably easier than either coding recursively
! for implicit stack management or keeping parent pointers around (which
! would have to be adjusted when blocks were adopted after a split).
! Note that we may want to treat two stacks as one during readjustment.

%recordformat stack fm(%integer p, %integerarray x(1 : stack depth))

%routine push(%integer what, %record(stack fm)%name s)
   %signal 10, 1, s_p, "Stack corrupt" %unless 0 <= s_p < stack depth
   s_p = s_p + 1
   s_x(s_p) = what
%end

%integerfn pop(%record(stack fm)%name h, l)
   %signal 10, 1, h_p, "Stack corrupt" %if h_p > stack depth
   %if h_p = 0 %start
      ! Top part empty
      %signal 10, 1, 0, "Stack underflow" %if l == nil;  ! No lower part
      %signal 10, 1, l_p, "Stack corrupt" %unless 0 < l_p <= stack depth
      l_p = l_p - 1
      %result = l_x(l_p + 1)
   %else
      h_p = h_p - 1
      %result = h_x(h_p + 1)
   %finish
%end

%integerfn top(%record(stack fm)%name h, l)
   %signal 10, 1, h_p, "Stack corrupt" %if h_p > stack depth
   %if h_p = 0 %start
      ! Top part empty
      %signal 10, 1, 0, "Stack underflow" %if l == nil;  ! No lower part
      %signal 10, 1, l_p, "Stack corrupt" %unless 0 < l_p <= stack depth
      %result = l_x(l_p)
   %else
      %result = h_x(h_p)
   %finish
%end

%routine invert stack(%record(stack fm)%name from, onto)
   %integer i
      %signal 10, 1, onto_p, "Stack corrupt" %unless 0 <= onto_p <= stack depth
      %return %if from_p = 0
      %signal 10, 1, from_p, "Stack corrupt" %if from_p < 0
      %signal 10, 1, from_p + onto_p, "Stack overflow" %c
         %if from_p + onto_p > stack depth
      onto_x(onto_p + i) = from_x(from_p - i + 1) %for i = 1, 1, from_p
      onto_p = onto_p + from_p
%end

!! %routine print stack(%record(stack fm)%name h, l)
!!    %integer i
!!       %if h ## nil %and h_p > 0 %start
!!          write(h_x(i), 1) %for i = 1, 1, h_p
!!       %finish
!!       %if l ## nil %and l_p > 0 %start
!!          write(l_x(i), 1) %for i = 1, 1, l_p
!!       %finish
!! %end


! Searching.  Fills block, returns index to key, stacks parents.  This version
! uses a binary search to find the key.  It's marginally quicker than the
! brute-force one following, but is rather less robust against mangled trees...

!%integerfn B tree find(%integer access token,
!                       %string(*)%name key, %record(block fm)%name b,
!                       %integername index, %record(stack fm)%name parents)
!   %integer status, where, comparison, l, m, u
!   %shortname p
!      !! printstring("Searching for ");  printstring(key);  newline
!      where = find root(access token)
!try next level:
!      !! printstring("Searching ");  write(where, 0);  newline
!      push(where, parents)
!      status = read block(access token, where, b)
!      %result = status %if status < 0
!      %if b_flags & leaf = 0 %start
!         ! Non-leaf node, hence has down-pointers
!         l = 2;  u = b_pointer limit
!         %while l < u %cycle
!            m = ((l + u) // 2) & (\ 3) + 2
!            !! printstring("Non-leaf: l = ");  write(l, 0)
!            !! printstring(", m = ");  write(m, 0)
!            !! printstring(", u = ");  write(u, 0);  newline
!            p == b_x(m)
!            comparison = compare(string(addr(b_x(p))), key)
!            !! printstring("Compare: ");  printstring(string(addr(b_x(p))))
!            !! space;  printstring(key);  space;  write(comparison, 0);  newline
!            %if comparison = 0 %start
!               ! Found it
!               !! printstring("Found it at ");  write(m, 0);  newline
!               index = m
!               %result = 0
!            %else %if comparison < 0
!               ! Too low, go right
!               !! printstring("->");  newline
!               l = m + 4
!            %else
!               ! Too high, go left
!               !! printstring("<-");  newline
!               u = m - 1
!            %finish
!         %repeat
!         ! Not found in this one
!         %if comparison < 0 %then where = b_x(m + 3) %else where = b_x(m - 1)
!         !! printstring("Not in this block, going ")
!         !! %if comparison < 0 %then printstring("right") %else printstring("left")
!         !! printstring(" to ");  write(where, 0);  newline
!         -> try next level
!      %else
!         ! Leaf node, hence no down-pointers
!         !! printstring("Leaf node");  newline
!         l = 1;  u = b_pointer limit
!         %while l < u %cycle
!            m = ((l + u) // 6) * 3 + 1
!            !! printstring("Leaf: l = ");  write(l, 0)
!            !! printstring(", m = ");  write(m, 0)
!            !! printstring(", u = ");  write(u, 0);  newline
!            p == b_x(m)
!            comparison = compare(string(addr(b_x(p))), key)
!            !! printstring("Compare: ");  printstring(string(addr(b_x(p))))
!            !! space;  printstring(key);  space;  write(comparison, 0);  newline
!            %if comparison = 0 %start
!               ! Found it
!               !! printstring("Found it at ");  write(m, 0);  newline
!               index = m
!               %result = 0
!            %else %if comparison < 0
!               ! Too low, go right
!               !! printstring("->");  newline
!               l = m + 3
!            %else
!               ! Too high, go left
!               !! printstring("<-");  newline
!               u = m - 1
!            %finish
!         %repeat
!         ! Not found in this one
!         !! printstring("Not in this leaf");  newline
!         index = m
!         %result = key not found error
!      %finish
!%end

! Now the brute-force linear search.  It does more comparisons but fewer
! calculations, and ends up a touch slower, but it is more robust....

%integerfn B tree find(%integer access token,
                       %string(*)%name key, %record(block fm)%name b,
                       %integername index, %record(stack fm)%name parents)
   %integer status, where, current pos, i, comparison
   %shortname p
      !! printstring("Searching for ");  printstring(key);  newline
      where = find root(access token)
try next level:
      !! printstring("Searching ");  write(where, 0);  newline
      push(where, parents)
      status = read block(access token, where, b)
      %result = status %if status < 0
      %if b_flags & leaf = 0 %start
         i = b_pointer limit - 1
         p == b_x(2)
         current pos = 2
      %else
         i = b_pointer limit
         p == b_x(1)
         current pos = 1
      %finish
      %while i > 0 %cycle
         !! printstring("Compare: ");  printstring(key)
         !! space;  printstring(string(addr(b_x(p))));  newline
         comparison = compare(key, string(addr(b_x(p))))
         %if comparison < 0 %start
            ! Before current position
            %if b_flags & leaf = 0 %start
               where = p [-1]
               -> try next level
            %finish
            ! Not found, return next highest
            index = current pos
            %result = key not found error
         %else %if comparison = 0
            ! Found it
            index = current pos
            %result = 0
         %finish
         ! Else after current position, so bump pointers
         ! and try again
         %if b_flags & leaf = 0 %start
            ! Key pointer, data, following left pointer
            p == p [4];  i = i - 4
            current pos = current pos + 4
         %else
            ! Key pointer, data
            p == p [3];  i = i - 3
            current pos = current pos + 3
         %finish
      %repeat
      %if b_flags & leaf = 0 %start
         ! Greater than all, so must go down the
         ! last one.
         where = p [-1]
         -> try next level
      %finish
      ! Not found in leaf
      index = current pos
      %result = key not found error
%end


! Block space-checker.  %true if there's enough room in the current
! block for the key + the data to fit

%predicate B tree check space(%string(*)%name key, %record(block fm)%name b)
   %integer key needed, child factor, total required
      key needed = length(key) // 2 + 1
      %if b_flags & leaf = 0 %then child factor = 1 %c
                             %else child factor = 0
      total required = b_pointer limit + 1 {key p.} + 2 {data} + 1 {slosh} %c
                       + key needed + child factor
      %true %if total required < b_text limit
      %false
%end


! Insertion.  Adds the key + the data + (optionally) the child-pointer
! to the current block at the position indicated, shuffling if necessary.

%routine B tree insert here(%string(*)%name key, %integer data, %short child,
                            %record(block fm)%name b, %integer pos)
   %integer key pos, child factor, i, shuffle amount
      !! printstring("Insert here: ");  printstring(key);  newline
      ! Insert the text of the key
      key pos = b_text limit - length(key) // 2 - 1
      string(addr(b_x(key pos))) = key
      b_text limit = key pos
      %if b_flags & leaf = 0 %then child factor = 1 %c
                             %else child factor = 0
      shuffle amount = child factor + 3
      %if pos <= b_pointer limit %start
         ! In the middle, so we'll have to shuffle
         b_x(i + shuffle amount) = b_x(i) %for i = b_pointer limit, -1, pos
      %finish
      b_pointer limit = b_pointer limit + shuffle amount
      b_x(pos) = key pos
      integer(addr(b_x(pos + 1))) = data
      b_x(pos + 3) = child %if child factor # 0
%end


! Block splitter.  Inserts the key + data + (optionally) child pointer
! at the correct position, splitting the block into two.  The key + data
! at the split position are passed back, as is the block (l/r) into which
! the key & data were inserted.

%routine B tree split(%string(*)%name key, %integer data, child,
                      %record(block fm)%name from, to l, to r,
                      %string(*)%name up key,
                      %integername up data, insert block)
   %integer added, child factor, key needed, remaining
   %shortname to p, from p

   %routine copy(%record(block fm)%name to, %integer split threshold)
      %integer moved so far
         to = 0;  to_text limit = block slots + 1
         to p == to_x(1)
         moved so far = 0
         %if child factor # 0 %start
            ! Must copy the leftmost separately
            to p = from p
            to p == to p [1];  from p == from p [1]
            to_pointer limit = 1
            moved so far = 1
            remaining = remaining - 1
         %finish
         %while remaining > 0 %cycle
            %if added = 0 %c
                  %and compare(key, string(addr(from_x(from p)))) < 0 %start
               ! Must insert the key here
               key needed = length(key) // 2 + 1
               moved so far = moved so far + key needed + 3 {k+d} + child factor
               %return %if moved so far > split threshold
               ! There's still room
               to p = to_text limit - key needed
               to_text limit = to p
               string(addr(to_x(to p))) = key
               integer(addr(to p) + 2) = data
               to p == to p [3]
               to_pointer limit = to_pointer limit + 3
               %if child factor # 0 %start
                  to p = child
                  to p == to p [1]
                  to_pointer limit = to_pointer limit + 1
               %finish
               added = 1
            %finish
            ! Copy the next key & data (& child)
            key needed = length(string(addr(from_x(from p)))) // 2 + 1
            moved so far = moved so far + key needed + 3 {k+d} + child factor
            %return %if moved so far > split threshold
            ! There's still room
            to p = to_text limit - key needed
            to_text limit = to p
            string(addr(to_x(to p))) = string(addr(from_x(from p)))
            integer(addr(to p) + 2) = integer(addr(from p) + 2);  ! Copy the data
            to p == to p [3];  from p == from p [3]
            to_pointer limit = to_pointer limit + 3
            remaining = remaining - 3
            %if child factor # 0 %start
               to p = from p
               to p == to p [1];  from p == from p [1]
               to_pointer limit = to_pointer limit + 1
               remaining = remaining - 1
            %finish
         %repeat
   %end

      !! printstring("Tree split: ");  printstring(key);  newline
      %if from_flags & leaf = 0 %then child factor = 1 %c
                                %else child factor = 0
      from p == from_x(1);  remaining = from_pointer limit
      added = 0

      ! Copy first block's keys & data
      copy(to l, (block slots + 1 %c
                  - from_text limit + from_pointer limit) // 2)

      ! Preserve the middle key & data for propagation upwards
      %if added = 0 %c
            %and compare(key, string(addr(from_x(from p)))) < 0 %start
         ! Propagate the new key & data upwards
         up key = key;  up data = data
         added = 1;  ! Don't add it twice!!
      %else
         ! Propagate the current key & data
         up key = string(addr(from_x(from p)));  from p == from p [1]
         up data = integer(addr(from p));        from p == from p [2]
         remaining = remaining - 3
      %finish
      insert block = added;  ! #0:l, =0:r

      ! Copy the second block's keys & data
      copy(to r, infinity)

      ! Now check to make sure that we've added the new key.  If it
      ! happened to be after all the ones in the current block we
      ! won't have yet.
      %if added = 0 %start
         ! Must insert the key here
         key needed = length(key) // 2 + 1
         to p = to r_text limit - key needed
         to r_text limit = to p
         string(addr(to r_x(to p))) = key
         integer(addr(to p) + 2) = data
         to r_pointer limit = to r_pointer limit + 3
         %if child factor # 0 %start
            to p [3] = child
            to r_pointer limit = to r_pointer limit + 1
         %finish
      %finish
%end


! New root for tree

%routine B tree new root(%string(*)%name key, %integer data,
                         %integer lower, upper, %record(block fm)%name b)
   %integer key pos, i
      !! printstring("New root: ");  printstring(key)
      !! space;  write(data, 0)
      !! space;  write(lower, 0);  space;  write(upper, 0)
      !! newline
      b = 0
      key pos = block slots - length(key) // 2
      string(addr(b_x(key pos))) = key
      b_text limit = key pos
      %if lower > 0 %start
         i = 2
         b_x(1) = lower
      %else
         i = 1
         b_flags = leaf
      %finish
      b_x(i) = key pos
      integer(addr(b_x(i + 1))) = data
      %if lower > 0 %start
         b_x(5) = upper
         b_pointer limit = 5
      %else
         b_pointer limit = 3
      %finish
%end


! Down-pointer search.  Returns a pointer to the key pointer immediately
! following the specified down-pointer.

%integerfn B tree search for down(%integer access token,
                                  %integer what, %record(stack fm)%name p1, p2,
                                  %record(block fm)%name b, %integername pos)
   %shortname p
   %integer i, status
      status = read block(access token, top(p1, p2), b)
      %result = status %if status < 0
      p == b_x(1)
      i = b_pointer limit
      pos = 2
      %while i > 0 %cycle
         %result = 0 %if p = what
         pos = pos + 4
         i = i - 4
         p == p [4]
      %repeat
      !! printstring("No down-pointer in parent??");  newline
      %result = bugcheck error;  ! Bug if we get here?
%end


! Either insert the new key at the located position, or split the
! block and propagate things upwards.  NOTE that because we reuse a
! split block's address for the lower new block if we have to split,
! we just have to insert the upper block's address after the new
! key/data.  Hairy, but effective.  <pos> points at the pointer to key.
! We have to reconstruct the stack too, since we'll maybe need it
! to readjust the tree after a deletion.

%integerfn B tree do insert(%integer access token,
                            %record(block fm)%name b, %integer pos,
                            %string(*)%name key, %integer data, child,
                            %record(stack fm)%name sh, sl)
   %record(stack fm) insert trace = 0
   %record(block fm) bl, br
   %integer status, where, split lower, split upper, split which, up data
   %string(255) up key

top:  where = pop(sh, sl)
      !! printstring("Do insert at ");  write(pos, 0)
      !! printstring(" in ");  write(where, 0);  newline
      %if B tree check space(key, b) %start
         ! Space in block, so just insert it here
         B tree insert here(key, data, child, b, pos)
         status = write block(access token, where, b)
         %result = status %if status < 0
         push(where, insert trace)
      %else
         ! Must split
         split lower = where;  split upper = get new block(access token)
         %result = split upper %if split upper < 0
         !! printstring("Must split: ");  write(where, 0)
         !! printstring(" -> ");  write(split lower, 0)
         !! printstring(" and ");  write(split upper, 0)
         !! newline
         ! NB we ASSUME that the lower split reuses the former address.
         B tree split(key, data, child, b, bl, br, up key, up data, split which)
         bl_flags = b_flags;  br_flags = b_flags
         status = write block(access token, split lower, bl)
         %result = status %if status < 0
         status = write block(access token, split upper, br)
         %result = status %if status < 0
         %if split which = 0 %then push(split upper, insert trace) %c
                             %else push(split lower, insert trace)
         ! We've split our block.  Now we have to propagate the middle
         ! upwards to our parent
         %if where = find root(access token) %start
            ! We were already the root, so we'll need to create a
            ! new one and insert the pointers
            where = get new block(access token)
            %result = where %if where < 0
            B tree new root(up key, up data, split lower, split upper, b)
            status = write block(access token, where, b)
            %result = status %if status < 0
            status = set root(access token, where)
            %result = status %if status < 0
            push(where, insert trace)
            -> reassemble stack
         %else
            ! We weren't the root, so propagate parents in our
            ! two new nodes and then find the correct insertion site
            key = up key;  data = up data
            child = split upper
            status = B tree search for down(access token, split lower,
                                            sh, sl, b, pos)
            %result = status %if status < 0
            -> top
         %finish
      %finish
reassemble stack:
      invert stack(insert trace, sh)
      %result = 0
%end


! B-tree insertion  **exported**

%externalintegerfn B tree add entry(%integer access token,
                                    %string(255) key, %integer data)
   %record(stack fm) stack = 0
   %record(block fm) b
   %integer status, where, pos
      !! printstring("Add """);  printstring(key)
      !! printstring(""", ");  write(data, 0)
      !! newline
      %result = null key error %if key = ""
      %result = key size error %if length(key) > key limit
      %if find root(access token) = 0 %start
         ! Special case if the tree is empty
         !! printstring("Empty -- special");  newline
         where = get new block(access token)
         %result = where %if where < 0
         B tree new root(key, data, -1, -1, b)
         status = write block(access token, where, b)
         %result = status %if status < 0
         %result = set root(access token, where)
      %finish

      status = B tree find(access token, key, b, pos, stack)
      %result = duplicate key error %if status = 0
      %result = status %if status # key not found error

      %result = B tree do insert(access token, b, pos, key, data, 0, stack, nil)
%end


! B-tree search  **exported**

%externalintegerfn B tree find entry(%integer access token,
                                     %string(255) key, %integername data)
   %record(stack fm) stack
   %record(block fm) b
   %integer status, found pos
      stack_p = 0
      !! printstring("Find """);  printstring(key)
      !! print symbol('"');  newline
      %result = null key error %if key = ""
      %result = key size error %if length(key) > key limit
      %result = key not found error %if find root(access token) = 0;  ! Null tree
      status = B tree find(access token, key, b, found pos, stack)
      %result = status %if status < 0
      ! Found it.  Extract value and return
      data = integer(addr(b_x(found pos + 1)))
      %result = 0
%end


! B-tree modification  **exported**

%externalintegerfn B tree modify entry(%integer access token,
                                       %string(255) key, %integer data)
   %record(stack fm) stack
   %record(block fm) b
   %integer status, found pos
      stack_p = 0
      !! printstring("Find """);  printstring(key)
      !! print symbol('"');  newline
      %result = null key error %if key = ""
      %result = key size error %if length(key) > key limit
      %result = key not found error %if find root(access token) = 0;  ! Null tree
      status = B tree find(access token, key, b, found pos, stack)
      %result = status %if status < 0
      ! Found it.  Set new value and write it out.
      integer(addr(b_x(found pos + 1))) = data
      %result = write block(access token, top(stack, nil), b)
%end


! Delete one entry (key, data, right child if any).  Return value of child.

%routine B tree delete one(%record(block fm)%name b, %integer delete pos,
                           %string(*)%name delete key,
                           %integername delete data, delete child)
   %integer delete text, i, key size, shuffle size
   %shortname p
      !! printstring("Delete at ");  write(delete pos, 0)
      !! newline
      p == b_x(delete pos);  delete text = p
      delete key = string(addr(b_x(delete text)))
      key size = length(string(addr(b_x(delete text)))) // 2 + 1
      %if b_flags & leaf = 0 %then shuffle size = 4 %c
                             %else shuffle size = 3
      ! First we delete the text of the key.  If it's the last one
      ! we just forget it instead.
      %if delete text > b_text limit %start
         ! Not the last -- we'll have to shuffle.
         b_x(i) = b_x(i - key size) %c
            %for i = delete text + key size - 1, -1, b_text limit - key size
         ! And remember to adjust all the text pointers...
         i = b_pointer limit;  p == b_x(shuffle size - 2 {allow for children})
         %while i > 0 %cycle
            p = p + key size %if p < delete text
            p == p [shuffle size]
            i = i - shuffle size
         %repeat
      %finish
      b_text limit = b_text limit + key size
      ! Return the data and child pointer (if any)
      delete data = integer(addr(b_x(delete pos + 1)))
      delete child = b_x(delete pos + 3) %if b_flags & leaf = 0
      ! Now remove the text pointer and the data by shuffling (if required)
      ! and decrementing the limit.
      %if delete pos < b_pointer limit - shuffle size %start
         ! We'll have to shuffle down
         b_x(i) = b_x(i + shuffle size) %c
            %for i = delete pos, 1, b_pointer limit - shuffle size
      %finish
      b_pointer limit = b_pointer limit - shuffle size
%end


! Find the key/data to borrow.  Return block & pointer to key

%integerfn B tree find borrow(%integer access token,
                              %integer donor, %record(stack fm)%name stack,
                              %record(block fm)%name b, %integername pos)
   %integer status
      %cycle
         push(donor, stack)
         status = read block(access token, donor, b)
         %result = status %if status < 0
         %exit %if b_flags & leaf # 0
         ! Else we've to go down another level.
         donor = b_x(b_pointer limit);  ! Rightmost child
      %repeat
      pos = b_pointer limit - 2
      %result = 0
%end


! Add a key/data pair to the tail of a block.  Don't worry about down-pointers,
! as they'll be added later if required.

%routine B tree insert at tail(%record(block fm)%name b, %string(*)%name key,
                               %integer data)
   %integer needed, text pos
      !! printstring("Insert at tail: ");  printstring(key)
      !! space;  write(data, 0);  newline
      needed = length(key) // 2 + 1
      text pos = b_text limit - needed
      string(addr(b_x(text pos))) = key
      b_text limit = text pos
      b_x(b_pointer limit + 1) = text pos
      integer(addr(b_x(b_pointer limit + 2))) = data
      b_pointer limit = b_pointer limit + 3
%end


! Merge the contents of the second block onto the end of the first.  This will
! add any missing down-pointers at the same time

%routine B tree merge on(%record(block fm)%name t, s)
   %integer remaining, target text, required
   %shortname tp, sp
   %string(*)%name ss
      !! printstring("Merge on");  newline
      tp == t_x(t_pointer limit + 1)
      sp == s_x(1)
      remaining = s_pointer limit
      target text = t_text limit
      %if t_flags & leaf = 0 %start
         ! Copy the first down-pointer
         tp = sp
         tp == tp [1];  sp == sp [1]
         remaining = remaining - 1
      %finish
      %while remaining > 0 %cycle
         ! Copy the text
         ss == string(addr(s_x(sp)))
         required = length(ss) // 2 + 1
         target text = target text - required
         string(addr(t_x(target text))) = ss
         tp = target text
         ! Copy the data
         integer(addr(tp) + 2) = integer(addr(sp) + 2)
         sp == sp [3];  tp == tp [3]
         remaining = remaining - 3
         %if t_flags & leaf = 0 %start
            ! Copy the down-pointer
            tp = sp
            tp == tp [1];  sp == sp [1]
            remaining = remaining - 1
         %finish
      %repeat
      ! Finally, account for the new keys & data
      t_pointer limit = t_pointer limit + s_pointer limit
      t_text limit = target text
      %signal 10, t_pointer limit, t_text limit, "Overlap" %c
         %if t_pointer limit >= t_text limit
%end


! Insert an entry at the front of a block (assumes there will be room).

%routine B tree insert at front(%record(block fm)%name b, %string(*)%name key,
                                %integer data, child)
   %integer i
      !! printstring("Insert at front: ");  printstring(key);  newline
      b_text limit = b_text limit - length(key) // 2 - 1
      string(addr(b_x(b_text limit))) = key
      %if b_flags & leaf = 0 %start
         b_pointer limit = b_pointer limit + 4
         b_x(i) = b_x(i - 4) %for i = b_pointer limit, -1, 5
         b_x(1) = child
         b_x(2) = b_text limit
         integer(addr(b_x(3))) = data
      %else
         b_pointer limit = b_pointer limit + 3
         b_x(i) = b_x(i - 3) %for i = b_pointer limit, -1, 4
         b_x(1) = b_text limit
         integer(addr(b_x(2))) = data
      %finish
%end


! Delete the first entry from a block, returning key, data and first child.
! Like <delete one>, but returns *first* child, not second.

%routine B tree delete from front(%record(block fm)%name b,
                                  %string(*)%name delete key,
                                  %integername delete data, delete child)
   %integer delete text, i, key size, shuffle size
   %shortname p
      !! printstring("Delete from front");  newline
      %if b_flags & leaf = 0 %then shuffle size = 4 %c
                             %else shuffle size = 3
      p == b_x(shuffle size - 2);  delete text = p
      delete key = string(addr(b_x(delete text)))
      !! printstring("Deleting ");  printstring(delete key)
      !! printstring(" at ");  write(delete text, 0)
      !! printstring(" (");  write(b_text limit, 0)
      !! print symbol(')');  newline
      key size = length(delete key) // 2 + 1
      ! First we delete the text of the key.  If it's the last one
      ! we just forget it instead.
      %if delete text > b_text limit %start
         ! Not the last -- we'll have to shuffle.
         b_x(i) = b_x(i - key size) %c
            %for i = delete text + key size - 1, -1, b_text limit - key size
         ! And remember to adjust all the text pointers...
         i = b_pointer limit;  p == b_x(shuffle size - 2 {allow for children})
         %while i > 0 %cycle
            p = p + key size %if p < delete text
            p == p [shuffle size]
            i = i - shuffle size
         %repeat
      %finish
      b_text limit = b_text limit + key size
      ! Return the data and child pointer (if any)
      delete data = integer(addr(b_x(shuffle size - 1)))
      delete child = b_x(1) %if b_flags & leaf = 0
      ! Now remove the text pointer and the data by shuffling
      ! and decrementing the limit.  Note that a shuffle is always required (?).
      b_x(i) = b_x(i + shuffle size) %c
         %for i = 1, 1, b_pointer limit - shuffle size
      b_pointer limit = b_pointer limit - shuffle size
%end


! B-tree deletion  **exported**

%externalintegerfn B tree delete entry(%integer access token, %string(255) key)
   %record(stack fm) parent stack = 0, borrow stack = 0
   %record(block fm) b, borrow block, parent block
   %record(block fm) left sibling block, right sibling block
   %integer where, current pos, dummy, donor pos, child, down pointer, free space
   %integer left sibling, left used, right sibling, right used, deleted data
   %integer left parent need, right parent need, rotating data, child factor
   %integer status
   %string(255) deleted key, rotating key

      !! printstring("Searching for ");  printstring(key)
      !! newline
      %result = null key error %if key = ""
      %result = key size error %if length(key) > key limit
      ! First find the entry.  If the tree is empty then we
      ! can't delete anything...
      %result = key not found error %if find root(access token) = 0
      status = B tree find(access token, key, b, current pos, parent stack)
      %result = status %if status < 0

      ! Now we delete the key & data.
      !
      ! <current pos> is pointing at the key
      ! top(parent stack) is pointing at the block
      !
      ! We have two cases to consider.  If we are a non-leaf then there is
      ! a down-pointer related to our key.  In this case we have to borrow
      ! from lower down the tree to replace the key.  We can do this simply
      ! by deleting the unwanted entry and inserting the borrowed one, possibly
      ! splitting the block in the process.  If we're a leaf then we don't need
      ! to borrow, but instead just delete the unwanted entry.  In either case
      ! we might have to readjust the shape of the tree later.
      !
      where = top(parent stack, nil)
      !! printstring("Found it in ");  write(where, 0)
      !! newline
      %if b_flags & leaf # 0 %start
         ! We're a leaf.  Just delete the entry.  We'll worry about
         ! rebalancing it all later.
         B tree delete one(b, current pos, deleted key, dummy, dummy)
      %else
         ! We're a non-leaf, so attempt to find something to borrow.
         ! We want to borrow the highest entry in the tree immediately
         ! to our left.
         status = B tree find borrow(access token, b_x(current pos - 1),
                                     borrow stack, borrow block, donor pos)
         %result = status %if status < 0

         ! We've found the rightmost on the left tree.  Delete the
         ! entry we're wanting rid of, and insert the borrowed
         ! one in its place.
         B tree delete one(b, current pos, deleted key, dummy, child)
         status = B tree do insert(access token, b, current pos,
                                   string(addr(borrow block_x(%c
                                             borrow block_x(donor pos)))),
                                   integer(addr(borrow block_x(donor pos + 1))),
                                   child, parent stack, nil)
         %result = status %if status < 0
         ! Note that our parent stack may have been completely
         ! rearranged by the insertion.

         ! Finally, delete the borrowed entry from the donor.
         B tree delete one(borrow block, donor pos, deleted key, dummy, dummy)

         ! Now, before we drop out to the leaf readjustment phase we
         ! have to write out our modified non-leaf and then copy the
         ! modified leaf in in its place.
         status = write block(access token, where, b)
         %result = status %if status < 0
         b = borrow block
      %finish

readjust:
      ! Leaf readjustment phase.  First check to see if there is
      ! enough unused space to make it worthwhile doing anything.
      where = pop(borrow stack, parent stack)
      -> all done %if b_text limit - b_pointer limit < block slots // 2

      ! We're less than half full, so attempt to tidy up a bit.  Strategy
      ! is to attempt to merge if possible, otherwise to rotate if possible,
      ! otherwise forget it.  Note that if we are empty then we can certainly
      ! either merge or rotate; if we're not we may have keys that are too
      ! long to allow either, in which case we just stick with a non-optimal
      ! space usage.
      !! printstring("Readjusting ");  write(where, 0)
      !! print stack(borrow stack, parent stack);  newline
      %if where = find root(access token) %start
         ! If we're the root then there's not much we can do.
         %if b_pointer limit <= 1 %start
            ! Nothing left in the top node.  Pull the height down.
            ! Note we're safe to test against '1' regardless of whether
            ! we're a leaf or not, since if we're not empty we'll always
            ! have at least 3 cells used.
            !! printstring("Empty root, pull it down");  newline
            status = free block(access token, where)
            %result = status %if status < 0
            %if b_flags & leaf = 0 %start
               %result = set root(access token, b_x(1))
            %else
               %result = set root(access token, 0)
            %finish
         %finish
         ! Otherwise there's nothing more we can do, so drop through.
      %else
         ! We're not the root, so maybe we should do some readjustment here.
         ! Find our parent's down-pointer to ourselves.
         status = B tree search for down(access token, where, borrow stack,
                                parent stack, parent block, down pointer)
         %result = status %if status < 0
         down pointer = down pointer - 1;  ! We want the pointer, not the key.
         ! Find out how much space our siblings have.
         left sibling = down pointer - 4
         !! printstring("Left sibling pointer at ");  write(left sibling, 0)
         !! newline
         %if left sibling > 0 %start
            left sibling = parent block_x(left sibling)
            !! printstring("Left sibling block is ");  write(left sibling, 0)
            !! newline
            status = read block(access token, left sibling, left sibling block)
            %result = status %if status < 0
            left parent need = 4 + %c
               length(string(addr(parent block_x(parent block_x(down pointer - 3)))))
            left used = left sibling block_pointer limit + %c
                        block slots - left sibling block_text limit + 1
         %else
            ! No left sibling, so kid on it was really full
            left used = infinity
            left parent need = infinity
         %finish
         right sibling = down pointer + 4
         !! printstring("Right sibling pointer at ");  write(right sibling, 0)
         !! newline
         %if right sibling <= parent block_pointer limit %start
            right sibling = parent block_x(right sibling)
            !! printstring("Right sibling block is ");  write(right sibling, 0)
            !! newline
            status = read block(access token, right sibling, right sibling block)
            %result = status %if status < 0
            right parent need = 4 + %c
               length(string(addr(parent block_x(parent block_x(down pointer + 1)))))
            right used = right sibling block_pointer limit + %c
                         block slots - right sibling block_text limit + 1
         %else
            ! No right sibling, so kid on it was really full
            right used = infinity
            right parent need = infinity
         %finish
         ! Find how much free space we have
         free space = b_text limit - b_pointer limit - 2
         !! printstring("Left need ");  write(left parent need, 0)
         !! printstring(", left used ");  write(left used, 0)
         !! printstring(", right need ");  write(right parent need, 0)
         !! printstring(", right used ");  write(right used, 0)
         !! printstring(", free ");  write(free space, 0)
         !! newline
         ! Now, can we merge?
         %if left used + left parent need <= free space %start
            ! Can merge left
            !! printstring("Merging left");  newline
            B tree delete one(parent block, down pointer - 3,
                              deleted key, deleted data, dummy)
            B tree insert at tail(left sibling block, deleted key, deleted data)
            ! NB the down-pointer (if any) is supplied from the merged sibling.
            B tree merge on(left sibling block, b)
            ! All done.  Free the unwanted block and write out the
            ! newly-merged sibling.
            status = free block(access token, where)
            %result = status %if status < 0
            status = write block(access token, left sibling, left sibling block)
            %result = status %if status < 0
            ! Copy in the parent, and go round again
            b = parent block
            -> readjust
         %else %if right used + right parent need <= free space
            ! Can merge right
            !! printstring("Merging right");  newline
            B tree delete one(parent block, down pointer + 1,
                              deleted key, deleted data, dummy)
            B tree insert at tail(b, deleted key, deleted data)
            ! NB the down-pointer (if any) is supplied from the merged sibling.
            B tree merge on(b, right sibling block)
            ! All done.  Free the unwanted sibling and write out the
            ! newly-merged block.
            status = free block(access token, right sibling)
            %result = status %if status < 0
            status = write block(access token, where, b)
            %result = status %if status < 0
            ! Copy in the parent, and go round again
            b = parent block
            -> readjust
         %finish
         ! Couldn't merge, so try to rotate
         %if left parent need <= free space %and %c
               left used > block slots - free space %and %c
               (left used >= right used %or right parent need > free space) %start
            ! Rotate from left
            !! printstring("Rotating from left");  newline
            B tree delete one(parent block, down pointer - 3,
                              deleted key, deleted data, dummy)
            %if b_flags & leaf = 0 %then child factor = 1 %c
                                   %else child factor = 0
            B tree delete one(left sibling block,
                              left sibling block_pointer limit - child factor - 2,
                              rotating key, rotating data, dummy)
            B tree insert at front(b, deleted key, deleted data, dummy)
            status = B tree do insert(access token, parent block,
                                      down pointer - 3,
                                      rotating key, rotating data, where,
                                      borrow stack, parent stack)
            %result = status %if status < 0
            ! Write out our left sibling block.
            status = write block(access token, left sibling, left sibling block)
            %result = status %if status < 0
            ! Don't need to write out our parent block, as it has
            ! already been written by the above insertion.  Just fall
            ! through to write out ourselves.....  We decide a priori not to
            ! bother trying to readjust from our parent upwards.
         %else %if right parent need <= free space %and %c
               left used > block slots - free space
            ! Rotate from right
            !! printstring("Rotating from right");  newline
            B tree delete one(parent block, down pointer + 1,
                              deleted key, deleted data, dummy)
            B tree delete from front(right sibling block, rotating key,
                                     rotating data, dummy)
            B tree insert at tail(b, deleted key, deleted data)
            %if b_flags & leaf = 0 %start
               ! Must insert the down-pointer too.
               b_pointer limit = b_pointer limit + 1
               b_x(b_pointer limit) = dummy
            %finish
            status = B tree do insert(access token, parent block,
                                      down pointer + 1,
                                      rotating key, rotating data, right sibling,
                                      borrow stack, parent stack)
            %result = status %if status < 0
            ! Write out our right sibling block and fall through.  As above,
            ! we don't need to write out our parent, and we're not going to
            ! bother trying to readjust it.....
            status = write block(access token, right sibling, right sibling block)
         %result = status %if status < 0
         %finish
         ! Couldn't rotate either.  Give up and fall through....
      %finish

all done:
      ! Write out the (maybe) readjusted block and return.
      status = write block(access token, where, b)
      %result = status
%end


! Test empty/non-empty state of tree.  **exported**

%externalpredicate B tree empty(%integer access token)
   %true %if find root(access token) = 0
   %false
%end


! Return a linked list of all the keys in the tree.  **exported**
! (This is a rather unpleasant hack, but will do for now...)

%recordformat key list fm(%record(key list fm)%name next,
                          %integer value, %string(255) key)

%record(key list fm)%map B tree key list part(%integer access token, block,
                                              %integername status)
   %record(block fm) b
   %record(key list fm)%name head == nil, current, last, down
   %integer remaining
   %shortname p
   %string(*)%name key
      !! printstring("List part for block ");  write(block, 0);  newline
      status = read block(access token, block, b)
      %result == nil %if status < 0
      p == b_x(1);  remaining = b_pointer limit
      %while remaining > 0 %cycle
         %if b_flags & leaf = 0 %start
            ! Follow down
            down == B tree key list part(access token, p, status)
            ! Chain it on
            %while down ## nil %cycle
               current == down;  down == down_next
               current_next == nil
               %if head == nil %then head == current %c
                               %else last_next == current
               last == current
            %repeat
            %result == head %if status < 0
            ! Bump pointer
            p == p [1]
            remaining = remaining - 1
            %exit %if remaining <= 0;  ! For trailing down-pointers
         %finish
         key == string(addr(b_x(p)))
         current == record(heap get(length(key) + 9))
         current_key = key
         current_value = integer(addr(p) + 2)
         current_next == nil
         %if head == nil %then head == current %c
                         %else last_next == current
         !! printstring("Adding ");  zput string(current_key)
         !! spaces(2);  phex(current_value)
         !! printstring(", remaining ");  write(remaining, 0);  newline
         last == current
         p == p [3];  remaining = remaining - 3
      %repeat
      status = 0
      %result == head
%end

%externalrecord(key list fm)%map B tree key list(%integer access token,
                                                 %integername status)
   %result == B tree key list part(access token, find root(access token), status)
%end

%end %of %file