! B-tree test program

%option "-nonstandard-low"

%systemroutinespec phex2(%integer i)

%externalroutinespec fsys initialise
%externalroutinespec create partition table(%integername p size)
%externalroutinespec initialise partition(%integer partition, size,
                                                   index, index size)

! The following two must be the same as in TREE.CORE
%constinteger free size = 256 - 8
%recordformat header fm((%short checksum, 
                         %short root, used, flags, free count,
                         %shortarray free(1 : free size),
                         %short should have, seed) %c
                        %or %bytearray b(0 : 511))

%constinteger block slots = 253
%recordformat block fm(%short checksum,
                       %short flags,
                       %byte pointer limit, text limit,
                       %shortarray x(1 : block slots))
%constinteger leaf = 1;  ! Hence no child-pointers

%ownrecord(header fm)%name header

%externalintegerfnspec open tree by ID(%record(*)%name access,
                                       %integer ID, %integername access)
%externalintegerfnspec close tree(%integer access)
%externalintegerfnspec read block(%integer access token, block,
                                  %record(*)%name buffer)
%externalintegerfnspec write block(%integer access token, block,
                                   %record(*)%name buffer)

%externalintegerfnspec B tree add entry(%integer access token,
                                        %string(255) key, %integer data)
%externalintegerfnspec B tree find entry(%integer access token,
                                         %string(255) key, %integername data)
%externalintegerfnspec B tree delete entry(%integer access token,
                                           %string(255) key)

%externalintegerfnspec compare(%string(*)%name a, b, %integer case)

%include "MOUSE:MOUSE.INC"

%owninteger access token = 0

! Diagnostic stuff

%routine dump(%integer bytes, %bytename buffer)
   %integer i, j, k
      newline
      i = 0
      %while i < bytes %cycle
         %for j = 0, 1, 15 %cycle
            %if i + j >= bytes %then space %and space %c
                               %else phex2(byteinteger(addr(buffer) + j))
            space %if j & 3 = 3
         %repeat
         printstring(" [")
         write(i, -3)
         printstring("]  |")
         %for j = 0, 1, 15 %cycle
            %if j + i < bytes %start
               k = byteinteger(addr(buffer) + j) & 127
               %if k = 0 %start
                  k = '.'
               %else %unless ' ' <= k <= '~'
                  k = '_'
               %finish
               printsymbol(k)
            %else
               space
            %finish
         %repeat
         printsymbol('|')
         newline
         i = i + 16;  buffer == buffer [16]
      %repeat
      newline
%end

%routine put filtered(%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

%owninteger have
%ownstring(255) previous key

%routine print tree(%integer root, indent)
   %record(block fm) b
   %shortname p
   %integer i, status
   %string(*)%name k
      %unless 0 < root <= header_used %start
         printstring("Invalid block address ")
         write(root, 0);  newline
         %signal 13, root
      %finish
      status = read block(access token, root, b)
      %if status < 0 %start
         printstring("Read failed ");  write(status, 0)
         newline
         %return
      %finish
      !! spaces(indent)
      !! printstring("Pointer limit = ");  write(b_pointer limit, 0)
      !! printstring(", text limit = ");  write(b_text limit, 0)
      !! newline
      %signal 13, b_pointer limit, b_text limit %c
          %unless 0 < b_pointer limit < b_text limit
      indent = indent + 3
      %if b_flags & leaf = 0 %start
         print tree(b_x(1), indent)
         i = b_pointer limit - 1
         p == b_x(2)
      %else
         i = b_pointer limit
         p == b_x(1)
      %finish
      %while i > 0 %cycle
         write(root, indent);  printstring(": ")
         write(integer(addr(p) + 2), 5);  spaces(2)
         k == string(addr(b_x(p)));  put filtered(k);  newline
         p == p [3]
         %unless compare(previous key, k, 0) < 0 %start
            printstring("*** Sort order error ***");  newline
         %finish
         previous key = k
         i = i - 3
         have = have + 1
         %if b_flags & leaf = 0 %start
            print tree(p, indent)
            p == p [1];  i = i - 1
         %finish
      %repeat
%end

%routine analyse one(%integer n, %record(block fm)%name b)
   %shortname p
   %integer i
      printstring("Block ");  write(n, 0);  newline
      printstring("   Pointer limit = ");  write(b_pointer limit, 0)
      printstring(", text limit = ");  write(b_text limit, 0)
      newline
      %return %unless 0 < b_pointer limit < b_text limit
      %if b_flags & leaf = 0 %start
         printstring("   -> ");  write(b_x(1), 0)
         newline
         i = b_pointer limit - 1
         p == b_x(2)
      %else
         i = b_pointer limit
         p == b_x(1)
      %finish
      %while i > 0 %cycle
         write(integer(addr(p) + 2), 5);  spaces(3)
         %unless b_text limit <= p <= block slots %start
            printstring("Dud text pointer ");  write(p, 0)
            p == p [3]
         %else
            put filtered(string(addr(b_x(p))));  p == p [3]
         %finish
         newline
         i = i - 3
         %if b_flags & leaf = 0 %start
            printstring("   -> ");  write(p, 0)
            newline
            p == p [1];  i = i - 1
         %finish
      %repeat
%end


! Test program

%string(127)%fn k(%integer x)
   %integer i, q, r, n
   %string(127) s = ""
      n = x
      %for i = 1, 1, 8 %cycle
         q = x // 10
         r = x - 10 * q
         s = to string(r + '0') . s
         x = q
      %repeat
      s = s . "." %for i = 0, 1, n & 31
      %result = s
%end

%begin
   %record(block fm) b
   %string(255) key
   %integer command, data, i, n, c, status, i size, p size
      %on 4, 9 %start
         %if event_event = 4 %start
            skip symbol %while next symbol # NL
            skip symbol
            -> top
         %finish
         -> done
      %finish
      open input(0, ":T");  select input(0)
      open output(0, ":T");  select output(0)
      prompt("Do you want to initialise the disc? ")
      read symbol(command) %until command > ' '
      %if command = 'Y' %or command = 'y' %start
         create partition table(p size)
         printstring("Partition size is ")
         write(p size, 0);  newline
         prompt("Index file size: ")
         read(i size) %until 0 < i size <= p size // 2
         initialise partition(1, p size, (p size - i size) // 2, i size)
         initialise partition(2, p size, (p size - i size) // 2, i size)
         initialise partition(3, p size, (p size - i size) // 2, i size)
      %finish
      skip symbol %while next symbol # NL;  skip symbol
      fsys initialise
      status = open tree by ID(nil, 16_01010002, access token)
      %if status < 0 %start
         printstring("Open failed ");  write(status, 0)
         newline
         %stop
      %finish
      header == record(integer(access token))
      printstring("Got header, root at ");  write(header_root, 0)
      printstring(", should have ");  write(header_should have, 0)
      newline
      %if header_seed = 0 %start
         header_seed = CPU time & 32767
         printstring("Seed set to ");  write(header_seed, 0)
         newline
      %else
         printstring("Seed is ");  write(header_seed, 0)
         newline
      %finish
top:  %cycle
         prompt("Command: ")
         read symbol(command) %until command > ' '
         %if command = 'p' %start
            have = 0;  previous key = ""
            print tree(header_root, 0) %if header_root # 0
            printstring("Should have ");  write(header_should have, 0)
            printstring(", actually have ");  write(have, 0)
            newline
         %else %if command = 'a'
            prompt("Key:  ");  read(key)
            prompt("Data: ");  read(data)
            status = B tree add entry(access token, key, data)
            %if status < 0 %start
               printstring("Add failed ");  write(status, 0)
               newline
            %else
               header_should have = header_should have + 1
               status = write block(access token, 0, header)
               %if status < 0 %start
                  printstring("Write header failed ");  write(status, 0)
                  newline
               %finish
            %finish
         %else %if command = 'r'
            prompt("N ");  read(n)
            %for i = 1, 1, n %cycle
               write(i, 4);  print symbol(13)
               header_seed = (321 * header_seed + 246247) & 32767
               status = B tree add entry(access token, k(header_seed),
                                         header_seed)
               %if status < 0 %start
                  printstring("Add failed ");  write(status, 0)
                  newline
               %finish
            %repeat
            header_should have = header_should have + n
            status = write block(access token, 0, header)
            %if status < 0 %start
               printstring("Write header failed ");  write(status, 0)
               newline
            %finish
            printstring("Last key inserted was ")
            printstring(k(header_seed))
            newline
         %else %if command = 'i'
            prompt("N ");  read(n)
            prompt("From ");  read(c)
            %for i = 1, 1, n %cycle
               write(i, 4);  print symbol(13)
               status = B tree add entry(access token, k(i + c - 1), i + c - 1)
               %if status < 0 %start
                  printstring("Add failed ");  write(status, 0)
                  newline
               %finish
            %repeat
            header_should have = header_should have + n
            status = write block(access token, 0, header)
            %if status < 0 %start
               printstring("Write header failed ");  write(status, 0)
               newline
            %finish
            printstring("Last key inserted was ")
            printstring(k(n + c - 1))
            newline
         %else %if command = 'b'
            prompt("N ");  read(n)
            prompt("From ");  read(c) %until c - n > 0
            %for i = 1, 1, n %cycle
               write(i, 4);  print symbol(13)
               status = B tree add entry(access token, k(c - i + 1), c - i + 1)
               %if status < 0 %start
                  printstring("Add failed ");  write(status, 0)
                  newline
               %finish
            %repeat
            header_should have = header_should have + n
            status = write block(access token, 0, header)
            %if status < 0 %start
               printstring("Write header failed ");  write(status, 0)
               newline
            %finish
            printstring("Last key inserted was ")
            printstring(k(c - n + 1))
            newline
         %else %if command = 'f'
            prompt("Key:  ");  read(key)
            printstring(key);  printstring(": ")
            status = B tree find entry(access token, key, data)
            %if status = 0 %start
               write(data, 0)
            %else
               printstring("not found")
            %finish
            newline
         %else %if command = 'd'
            prompt("Key: ");  read(key)
            status = B tree delete entry(access token, key)
            %if status = 0 %start
               header_should have = header_should have - 1
               status = write block(access token, 0, header)
               %if status < 0 %start
                  printstring("Write header failed ");  write(status, 0)
                  newline
               %finish
            %else
               printstring("Delete failed");  newline
            %finish
         %else %if command = 'z'
            prompt("Key (numeric): ");  read(n)
            status = B tree delete entry(access token, k(n))
               %if status = 0 %start
               header_should have = header_should have - 1
               status = write block(access token, 0, header)
               %if status < 0 %start
                  printstring("Write header failed ");  write(status, 0)
                  newline
               %finish
            %else
               printstring("Delete failed");  newline
            %finish
         %else %if command = 's'
            prompt("N ");  read(n)
            status = read block(access token, n, b)
            %if status < 0 %start
               printstring("Read block failed ");  write(status, 0)
               newline
            %finish
            dump(512, byteinteger(addr(b)))
         %else %if command = 'x'
            prompt("N ");  read(n)
            status = read block(access token, n, b)
            %if status < 0 %start
               printstring("Read block failed ");  write(status, 0)
               newline
            %finish
            analyse one(n, b)
         %else %if command = 'e'
            %exit
         %finish
      %repeat
done: status = close tree(access token)
      %if status < 0 %start
         printstring("Close failed");  newline
      %finish
%end %of %program