Re: Anyone could give a complete and yet small program on the use for the generic

[mfb@mbunix.mitre.org (Michael F Brenner)]

Dear Hung-Hsien Chang,

Here is an example of a generic package that passes types, objects,
functions, and procedures. It works in both Ada-83 and Ada-95 unchanged.
However, in Ada-95, an additional feature was added called an abstract
generic. Since I am a beginner with abstract packages, someone else
should post an example of a working abstract package, so I can see
one that works myself.

You are right. Books are not the best way to learn how to program
something, even in Ada. The easiest way to learn is to look at 
working programs, modify them, and build on them. So asking for
an example of a working program is not only valid educationally, 
but IMO it is the only valid way to learn Ada. 

Below the generic specification and implementation I have placed a test
program that demonstrates that it works on a large variety of 
instantiations, including exact numbers, approximate numbers, 
fixed length strings, variable length strings, record types, etc.

I programmed this generic package and all of its instantiations myself,
and it has no bugs. <mikeb@mitre.org>

-- The package balanced_essence is subject to Ada modification to the
-- Free Software Foundations General Public LIBRARY License which 
-- provides that the code and its modifications must always remain
-- free, but anybody, even commercial firms may use it in their
-- products without those products becoming free. It is part of
-- the free Eyemusic Command and Control System.

-- This package provides skip lists which are the equivalent to 
-- balanced trees, only a little slower, and a lot easier to debug.

generic
  type keys   is private;  -- Entered in list in ascending order according to <
  first_key: keys;         -- Lowest key according to <.
  last_key:  keys;         -- Highest key according to <.
  with function  "<"         (left, right: keys) return boolean;
  with function  same        (left, right: keys) return boolean;
  with function  key_image   (key:   keys)       return string;
  with procedure assign_key  (left: in out keys; right: keys);

  type values is private;  -- A value is associated with each key.
  null_value: values;
  with function  value_image (value: values)     return string;
  with procedure assign_value (left: in out values; right: values);

  type nodes  is range <>; -- Each node has a key and a value.

  type levels is range <>; -- Levels'last should be log base 2 of nodes'last.

package balanced_essence is
  pragma elaborate_body (balanced_essence);

  -- Balanced Trees (Used for Fast Lookups)
  --
  -- This package uses a technique similar to that described in
  -- CACM, June 1990 in an article by William Pugh titled:
  -- "Skip Lists: A Probabilistic Alternative to Balanced Trees".
  -- Pugh gives program design language
  -- and an explanation of why skip lists are almost
  -- as fast to look up and faster to insert than fully balanced trees,
  -- including AVL trees and self-adjusting trees. Thus, a skip list
  -- can be considered as an almost balanced tree; the part of it that
  -- is not balanced is determined by a random number generator, and
  -- averages more than 75% balanced.
  --
  -- The faster inserts do not make up for the partial lack of balance, if
  -- objects are going to be looked up many times.
  -- The real reason you would use a skip list is that
  -- balanced trees never seem to get past their software development bugs,
  -- and therefore never realize their (theoretical) superior performance.
  -- A partially balanced tree (skip list) can be implemented quickly with
  -- the bugs eliminated during a little unit testing.
  --
  -- When symbol tables and similar associative arrays are implemented
  -- using a skip list, they run in LOG_N time for each lookup, as
  -- opposed to a linear lookup that runs in time N.
  --
  -- 1990-07-28 MB  Created
  -- 1990-08-13 SMA Added delete (node) instead of just delete (key)
  -- 1990-09-27 MB  Removed delete (node): you have to search for the key
  --                in order to build up the list of nodes that point to
  --                the key on each strand, otherwise you only delete it
  --                on the one strand, which leaves the tree corrupted.

  type behaviors_for_duplicate_keys is
    (fail,
     overwrite_values,
     raise_duplicate_exception);

  type behaviors_when_not_found is
    (raise_not_found_exception,
     insert_nothing_and_return_next_lower_node, -- for NODE return only
     insert_nothing_and_return_null_value,
     insert_null_value_and_return_it);

  duplicate: exception;
  not_found: exception;
  failure:      constant nodes := nodes'first;
  trailer_node: constant nodes := nodes'first;
  header_node:  constant nodes := nodes'succ (trailer_node);

  -- The TRAILER_NODE is the last node in the list. It is stored at
  -- location -1, just before the HEADER_NODE.

  type skip_lists is limited private;

  procedure initialize (L: in out skip_lists);
  procedure finalize   (L: in out skip_lists);
  procedure re_initialize (L: skip_lists);

  procedure delete     (L: skip_lists; k: keys);
  function  insert     (L: skip_lists; k: keys;  v: values) return nodes;
  function  search     (L: skip_lists; k: keys)  return nodes;
  function  search     (L: skip_lists; k: keys)  return values;
  function  key        (L: skip_lists; n: nodes) return keys;
  function  value      (L: skip_lists; n: nodes) return values;
  procedure tell       (L: skip_lists);

  function  next_node  (L: skip_lists; n: nodes) return nodes;

    -- To use NEXT_NODE, use a loop like the following:
    --
    --       n: nodes := header_node;
    --                                        -- HEADER_NODE defined above.
    --       loop
    --         exit when n := trailer_node;
    --                                        -- TRAILER_NODE defined above.
    --         process (n);
    --                                        -- Caller must provide PROCESS.
    --         n := next_node (n);
    --                                        -- NEXT_NODE defined above.
    --       end loop;

  function  linear_search          (L: skip_lists; k: keys) return nodes;

  procedure set_insertion_behavior (L: skip_lists;
                                    insertion_behavior:
                                    behaviors_for_duplicate_keys);
  procedure set_search_behavior    (L: skip_lists;
                                    search_behavior:
                                    behaviors_when_not_found);
  procedure set_tracing            (on: boolean);
private
  type pointers is array (levels) of nodes;

  type node_descriptors is record
    key:     keys;
    value:   values;
    pointer: pointers;
  end record;

  -- The definition of type NODE_DESCRIPTORS shows that each of the nodes
  -- contains all of the levels of pointers. Thus, it is important to
  -- decide on the number of levels of pointers before instantiating this
  -- object. A good value for the number of nodes is probably a tiny bit
  -- more than log base 2 of the number of nodes. For applications where
  -- there is a human waiting for the lookup, measure and optimize this!
  -- Or else use a hash code table or finite state auomata instead, so the
  -- human does not wait more than 0.25 seconds after pressing the key.

  type node_lists is array (nodes) of node_descriptors;

  -- The linked list implementing the balanced tree is actually a fixed array.

  type pab_skip_lists is record
    node_list:          node_lists;
    high_level:         levels;
    last_node_used:     nodes;
    update:             pointers;
    insertion_behavior: behaviors_for_duplicate_keys := fail;
    search_behavior:    behaviors_when_not_found := raise_not_found_exception;
  end record;

  type skip_lists is access pab_skip_lists;
end balanced_essence;

--
-- The package status provides status.tell and status.telln which are
-- like text_io.put and text_io.put_line with the additional features
-- that they are efficient, small, and do output simultaneously to
-- the screen and to an error collection file called status.tmp
--
-- The package rand_int provides random numbers and can be replaced
-- with any other random number generating package. It is used on
-- only one line in balanced_essence, to provide an exact (integer)
-- number in the range 0..big.   

with status;
with rand_int;
package body balanced_essence is

  tracing_bal: boolean := False;

  procedure assert (condition: boolean; message: string) is
    -- It is essential for efficiency that this be a
    -- local procedure, and that it be compiled in-line.
    fatal_balanced_tree: exception;
  begin
    if not condition then
      status.telln(message);
      raise fatal_balanced_tree;    
    end if;
  end assert;
  pragma inline (assert);

  function ">" (left, right: keys) return boolean is
  begin
    return not same (left, right) and then not (left<right);
  end ">";

  procedure check_range (key: keys) is
  begin
    assert (key>first_key and key<last_key, "key:bad");
  end check_range;

  procedure set_p (L: skip_lists; n: nodes; i: levels; p: nodes) is
  begin
    L.node_list(n).pointer(i) := p;
  end set_p;

  procedure re_initialize (L: skip_lists) is
  begin
    L.last_node_used := header_node;

      -- LAST_USED_NODE is set to the HEADER_NODE,
      -- indicating an empty list.

    for i in levels loop
      set_p (L, header_node,  i, trailer_node);
      set_p (L, trailer_node, i, trailer_node);
    end loop;

      -- All pointers in the header node and the
      -- trailer node point at the trailer node.

    assign_key   (L.node_list(trailer_node).key,   last_key);
    assign_value (L.node_list(trailer_node).value, null_value);

      -- Dummy keys are inserted in the TRAILER_NODE that
      -- are larger than any other possible key.

    assign_key   (L.node_list(header_node).key,    first_key);
    assign_value (L.node_list(header_node).value,  null_value);

      -- Dummy keys are also inserted in the HEADER_NODE
      -- that are smaller than any other possible key.
      -- The necessity for this is not commonly known. Beware.
      -- We learned about this through hard experience.

    L.high_level     := 1;

      -- The HIGH_LEVEL is set to 1, so that a search of the list will
      -- immediately come up empty (since the HEADER_NODE points to the
      -- TRAILER_NODE which contains the highest possible key).

    L.insertion_behavior := raise_duplicate_exception;

      -- The default insertion behavior is that
      -- inserting a duplicate record is fatal.

    L.search_behavior    := raise_not_found_exception;

      -- The default search behavior is that
      -- not finding a key is fatal.

  end re_initialize;

  procedure initialize (L: in out skip_lists) is
  begin
    L := new pab_skip_lists;

      -- If you got to here with a SIGSEGV, there was
      -- enough virtual storage to allocate the tree.

    re_initialize (L);

      -- The tree is initialized.

  end initialize;

  procedure finalize (L: in out skip_lists) is
  begin
    re_initialize (L);
    L.insertion_behavior := fail;

      -- Note that we do NOT free the nodes of L,
      -- which were NOT dynamically allocated (at
      -- least not by us), and we do NOT free the tree,
      -- which WAS dynamically allocated by us.
      -- By simply reinitializing, we can reuse the tree.

  end finalize;

  procedure tell (L: skip_lists) is
                                    -- The TELL method traces a balanced tree.
    pointers:      string (1..64);
    pointers_upto: natural := 0;
  begin
    status.tell ("hi-level and node");
    status.tell (levels'image(L.high_level));
    status.telln(nodes'image(L.last_node_used));

    for node in nodes range -1..L.last_node_used loop
      pointers_upto := 0;
      for i in pointers'range loop
        pointers (i) := ' ';
      end loop;
      for level in levels loop
        declare
          this_pointer: constant nodes  := L.node_list(node).pointer(level);
          message:      constant string := nodes'image(this_pointer);
        begin
          exit when pointers_upto + message'length > pointers'length;
                                        -- The message will fit in the buffer.
          pointers (pointers_upto+1..pointers_upto+message'length) := message;
          pointers_upto := pointers_upto + message'length;
        end;
      end loop;
      status.tell (key_image  (L.node_list(node).key));
      status.tell (nodes'image(node));
      status.tell (" V ");
      status.tell (value_image(L.node_list(node).value));
      status.tell (" P");
      status.telln(pointers   (1..pointers_upto));
    end loop;
  end tell;

-- Object Access Functions

  function key (L: skip_lists; n: nodes) return keys is
  begin
    return L.node_list(n).key;
  end key;

  function p (L: skip_lists; n: nodes; i: levels) return nodes is
  begin
    return L.node_list(n).pointer(i);
  end p;

  procedure is_okay (L: skip_lists) is
  begin
    if L=null or else L.insertion_behavior = fail then
      raise not_found;
      -- It could have raised a unique exCeption, but
      -- you exPect using an uninitialized tree to do an
      -- unexpected thing, so this one throws NOT_FOUND.
    end if;
  end is_okay;

  procedure update_search (L:           skip_lists;
                           k:           keys;
                           before_node: out nodes;
                           after_node:  out nodes) is

    -- This is the kernel of the INSERT, DELETE, and SEARCH.

    x: nodes := header_node;
    y: nodes;
  begin
    if tracing_bal then
      status.tell ("usearch [");
      status.tell (key_image(k));
      status.tell ("] ");
      check_range (k);
    end if;

    for i in reverse levels'first..L.high_level loop -- for each level

      -- Within each level, find the first key at least as big as K.
      loop
        y := p(L,x,i);
        exit when not (key(L,y)<k);
        x := y;
      end loop;

      L.update(i) := x; -- Update the pointers for insert and delete,
                        -- not used by the visible SEARCH.
    end loop;

    -- The before_node points at the node, you see,
    -- that points at where the key would be,
    -- if the key were in the tree.

    before_node := x;

    if tracing_bal then
      status.tell ("before node=");
      status.tell (nodes'image(x));
    end if;

    after_node := p (L, x, 1);

    -- If the key is in the tree,
    -- X is now pointing at it.
    -- Otherwise, X is now just AFTER
    -- where the key would  be.

  end update_search;

  procedure delete (L: skip_lists; k: keys) is
    pre_x: nodes; -- node that points to x
    x:     nodes;
  begin
    is_okay (L);
    check_range (k);
    update_search (L, k, pre_x, x);

    if same (key (L, x), k) then
      assert (P(L,L.update(1),1)=x, "del:P(L,L.u(1),1)/=x");
      assert (same (key(L,x), k),   "del:key(L,x) /= k");

      for i in levels'first .. L.high_level loop
        exit when P (L, L.update(i), i) /= x;
        set_p       (L, L.update(i), i, P(L,x,i));
      end loop;

      -- free_node (x);

                     -- Instead of freeing it, we shall waste it.
                     -- We did not, after all, allocate it, and
                     -- it is probably not even a pointer type.
                     -- These lists are temporary; we insert and search.
                     -- The entire list is deallocated simultaneously,
                     -- when you leave the address space of the list.
                     -- The programmer expects that deleting is rare.
                     -- If deleting is not rare, then redo this design,
                     -- by using a heap instead of an array of nodes.

      loop
        exit when L.high_level = 1;
        exit when P(L, header_node, L.high_level) = trailer_node;
        L.high_level := L.high_level - 1;
      end loop;
    end if;
  end delete;

  function random_level return levels is
    level:    levels   := 1;
    big:      constant := 8192;
    fraction: constant := big / 2;
    use rand_int;
  begin
    loop
        -- Spin the "dice" until the sum of the probabilities exceed 0.5.
      exit when rand_int.random_modulus mod big >= fraction;
      level := level+1;
      exit when level = levels'last;
    end loop;
    return level;
  end random_level;

  function insert (L: skip_lists; k: keys; v: values) return nodes is
    new_level: levels;
    pre_x:     nodes; -- node that points to x
    x:         nodes;
    node:      nodes;
  begin
    is_okay (L);

    if tracing_bal then
      status.tell ("INS key=");
      status.tell (key_image(k));
      status.tell (" Value=[");
      status.telln (value_image(v));
      check_range (k);
    end if;

    update_search (L, k, pre_x, x);

    if not same (key (L, x), k) then
      new_level := random_level;
      if new_level > L.high_level then
        for i in L.high_level + 1 .. new_level loop
          L.update(i) := header_node;
        end loop;
        L.high_level := new_level;
      end if;
      assert (L.last_node_used < nodes'last, "ins:oflo");
      L.last_node_used := L.last_node_used + 1;

      -- The new node is "allocated".

      x                := L.last_node_used;

      for i in levels'first .. new_level loop
        node := P(L, L.update(i), i);
        set_p (L, x,           i, node);
        set_p (L, L.update(i), i, x);
      end loop;

      assign_key (L.node_list(x).key, K);
    elsif L.insertion_behavior = raise_duplicate_exception then
      raise duplicate;
    else
      null;
    end if;
    assign_value (L.node_list(x).value, v); -- In either case, set the value.
    return x;
  end insert;

  function next_node (L: skip_lists; n: nodes) return nodes is
  begin

    -- This permits iteration through the balanced tree, starting
    -- at any value of N (particularly starting at the HEADER_NODE),
    -- and proceeeding until all nodes are visited, when the return
    -- value will be TRAILER_NODE.

    is_okay (L);
    return p (L,n,levels'first);
  end next_node;

  function linear_search (L: skip_lists; k: keys) return nodes is
    node:                 nodes := HEADER_NODE;
    number_of_searches:   nodes := 0;
    end_of_list: constant nodes := L.last_node_used + 1;
  begin
    is_okay (L);

    loop
      exit when node = TRAILER_Node;
      exit when number_of_searches > end_of_list;
      exit when same (key (L, node), k);
      number_of_searches := number_of_searches + 1;
      node := next_node (L, node);
    end loop;

    assert (number_of_searches <= end_of_list, "lin:oflo");
    return node;
  end linear_search;

  function search (L: skip_lists; k: keys) return nodes is
    pre_x:    nodes;
    x:        nodes;
    y:        nodes;
  begin
    update_search (L, k, pre_x, x);
    if same (key (L, x), k) then
      y:=x;
    else
      case L.search_behavior is
        when insert_nothing_and_return_next_lower_node => y:=PRE_X;
        when insert_nothing_and_return_null_value => y:=failure;
        when insert_null_value_and_return_it      => y:=insert(L,k,null_value);
        when raise_not_found_exception            => raise not_found;
      end case;
    end if;

    return y;
  end search;

  function search (L: skip_lists; k: keys) return values is
    pre_x:    nodes;
    x:        nodes;
    y:        nodes;
    v:        values;
  begin
    update_search (L, k, pre_x, x);
    if same (key (L, x), k) then
      v:=value(L,x);
    else
      case L.search_behavior is
        when insert_nothing_and_return_next_lower_node => raise not_found;
        when insert_nothing_and_return_null_value => v:=null_value;
        when insert_null_value_and_return_it      => y:=insert(L,k,null_value);
                                                     v:=null_value;
        when raise_not_found_exception            => raise not_found;
      end case;
    end if;
    return v;
  end search;

  procedure set_insertion_behavior (L: skip_lists;
                                    insertion_behavior:
                                    behaviors_for_duplicate_keys) is
  begin
    L.insertion_behavior := insertion_behavior;
  end set_insertion_behavior;

  procedure set_search_behavior (L: skip_lists;
                                 search_behavior:
                                 behaviors_when_not_found) is
  begin
    L.search_behavior := search_behavior;
  end set_search_behavior;

  procedure set_tracing (on: boolean) is
  begin
    tracing_bal := on;
  end set_tracing;

  function value (L: skip_lists; n: nodes) return values is
  begin
    assert (n/=header_node, "val:n=hd");
    return L.node_list(n).value;
  end value;

begin
  assert (nodes'first = -1 and levels'first = 1, "API");
end balanced_essence;


with balanced_essence;
with fixed_string_control;
with status;
procedure tsbal is

-- Testing the Balanced Trees

procedure test_bal_easy is
  use status;

  type test_values  is range -1..128;
  type nodes        is range -1..20;
  type levels       is range 1..8;
  type tests        is range 1..10;
  type value_lists  is array (tests) of test_values;
  input_values:  constant value_lists := (33,36,39,31,32,35,38,37,34,40);
  n:             nodes;
  v:             test_values;
  telling:       constant boolean := FALSE;
  x:             nodes;

  type target_keys  is range 0..128;
  type key_lists    is array (tests) of target_keys;
  input_keys:    constant key_lists   := ( 3, 6, 9, 1, 2, 5, 8, 7, 4,10);

  function image (value: test_values) return string is
  begin
    return test_values'image (value);
  end image;

  procedure assign (left: in out test_values; right: test_values) is
  begin
    left := right;
  end assign;

  procedure test_bal_simple is
    package my_keys is
      subtype test_keys    is target_keys;

      procedure assign (left: in out test_keys; right: test_keys);
      function image (key:   test_keys) return string;
      function same (left, right: test_keys) return boolean;
    end my_keys;

    use my_keys;

    package skip_list is new balanced_essence (
      keys         => test_keys,
      first_key    => test_keys'first,
      last_key     => test_keys'last,
      "<"          => "<",
      same         => same,
      key_image    => image,
      assign_key   => assign,
      values       => test_values,
      null_value   => -1,
      assign_value => assign,
      nodes        => nodes,
      levels       => levels,
      value_image  => image);

    use skip_list;

    list: skip_lists;
    node: nodes;

    package body my_keys is
      procedure assign (left: in out test_keys; right: test_keys) is
      begin
        left := right;
      end assign;

      function image (key:   test_keys) return string is
      begin
        return test_keys'image (key);
      end image;

      function same (left, right: test_keys) return boolean is
      begin
          return left = right;
      end same;
    end my_keys;

  begin
    initialize (list);
    for T in tests loop
      node := insert (list, input_keys(T), input_values(T));
    end loop;

    for T in tests loop
      n := search (list, test_keys(T));
      v := value  (list, n);
      telln ("n=" &
             nodes'image(n) &
             "  value " &
             image (v));
    end loop;

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("next x=" &
             image (value (list, x)));
    end loop;
      telln("about to display the entire list");
      tell(list);
      telln("about to display the entire list");
    for T in tests range 1..3 loop
      delete (list, input_keys (T));
    end loop;
      tell (list);
    telln ("skip list test 1: 7 items in ascending order (no 3,6,9)");

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("            next x=" &
             test_values'image (value (list, x)));
    end loop;

  end test_bal_simple;


  procedure test_bal_2 is
    package my_keys is
      type test_keys    is access target_keys;

      procedure assign (left: in out test_keys; right: test_keys);
      function image (key:   test_keys) return string;
      function same (left, right: test_keys) return boolean;
      function less_than (left, right: test_keys) return boolean;
    end my_keys;

    use my_keys;

    package skip_list is new balanced_essence (
      keys         => test_keys,
      first_key    => new target_keys'(target_keys'first),
      last_key     => new target_keys'(target_keys'last),
      "<"          => less_than,
      same         => same,
      key_image    => image,
      assign_key   => assign,
      values       => test_values,
      null_value   => -1,
      assign_value => assign,
      nodes        => nodes,
      levels       => levels,
      value_image  => image);

    use skip_list;
    list: skip_lists;
    node: nodes;

    package body my_keys is
      procedure assign (left: in out test_keys; right: test_keys) is
      begin
        left := right; -- Copy the pointers without allocating a new copy.
      end assign;

      function image (key:   test_keys) return string is
      begin
        if key=null then
           report("Fatal: image: key is null");
        end if;
        return target_keys'image (key.all);
      end image;

      function less_than (left, right: test_keys) return boolean is
      begin
        if left=null or right=null then
           report("Fatal: less_than: argument is null");
        end if;
        return left.all < right.all;
      end less_than;

      function same (left, right: test_keys) return boolean is
      begin
        if left=null or right=null then
           report("Fatal: same: argument is null");
        end if;
        return left.all = right.all;
      end same;
    end my_keys;

  begin
    telln("started test_bal_2");
    initialize(list);
    for T in tests loop
      node := insert (list, new target_keys'(input_keys(T)), input_values(T));
    end loop;
    telln("inserted test_bal_2");

    for T in tests loop
      n := search (list, new target_keys'(target_keys(T)));
      v := value  (list, n);
      telln ("n=" &
             nodes'image(n) &
             "  value " &
             image (v));
    end loop;

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("next x=" & image (value (list, x)));
    end loop;

      tell(list);
    for T in tests range 1..3 loop
      delete (list, new target_keys'(input_keys (T)));
    end loop;
      tell (list);
    telln ("skip list test 2: 7 items in ascending order (no 3,6,9)");

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("  next x=" &
             test_values'image (value (list, x)));
    end loop;

  end test_bal_2;

begin

  -- The Tests are:
  --
  --   1. Key=Number
  --      Value=Number
  --
  --   2. Key=String
  --      Value=String
  --
  --   3. Key=Pointer to String
  --      Value=String
  --
  --   4. Key=Pointer to String
  --      Value=Pointer to String
  --
  --   5. Key=Fixed_String
  --      Value=Fixed_String
  --

  telln ("starting test_bal_easy");
  test_bal_simple;
  test_bal_2;
  telln ("test_bal_easy worked");
end test_bal_easy;


procedure test_bal_hard is
   use status;

  type nodes        is range -1..20;
  type levels       is range 1..8;
  type tests is range 1..10;
  type test_values  is access string;
  type value_lists is array (tests) of test_values;
  input_values:  constant value_lists := (
    new string'("33 thirty_three"),
    new string'("36 thirty_six"),
    new string'("39 thirty_nine"),
    new string'("31 thirty-one"),
    new string'("32 thirty-two"),
    new string'("35 thirty-five"),
    new string'("38 thirty-eight"),
    new string'("37 thirty-seven"),
    new string'("34 thirty-four"),
    new string'("40 forty"));

  output_values: value_lists;
  n:             nodes;
  v:             test_values;
  telling:       constant boolean := FALSE;
  x:             nodes;

  function image (value: test_values) return string is
  begin
    if value = null then
      return "!!";
    else
      return value.all;
    end if;
  end image;

  procedure assign (left: in out test_values; right: test_values) is
  begin
    left := right; -- just copying the pointer, not the object.
  end assign;

  procedure test_bal_3 is
    type target_keys     is range 0..128;
    type key_lists   is array (tests) of target_keys;
    input_keys:    constant key_lists   := ( 3, 6, 9, 1, 2, 5, 8, 7, 4,10);

    package my_keys is
      type test_keys    is access target_keys;

      procedure assign (left: in out test_keys; right: test_keys);
      function image (key:   test_keys) return string;
      function same (left, right: test_keys) return boolean;
      function less_than (left, right: test_keys) return boolean;
    end my_keys;

    use my_keys;

    package skip_list is new balanced_essence (
      keys         => test_keys,
      first_key    => new target_keys'(target_keys'first),
      last_key     => new target_keys'(target_keys'last),
      "<"          => less_than,
      same         => same,
      key_image    => image,
      assign_key   => assign,
      values       => test_values,
      null_value   => new string'(""),
      assign_value => assign,
      nodes        => nodes,
      levels       => levels,
      value_image  => image);

    use skip_list;
    list: skip_lists;
    node: nodes;

    package body my_keys is
      procedure assign (left: in out test_keys; right: test_keys) is
      begin
        left := right; -- Copy the pointers without allocating a new copy.
      end assign;

      function image (key:   test_keys) return string is
      begin
        if key=null then
           report("Fatal: image is null");
        end if;
        return target_keys'image (key.all);
      end image;

      function less_than (left, right: test_keys) return boolean is
      begin
        if left=null or right=null then
           report("Fatal: less_than is null");
        end if;
        return left.all < right.all;
      end less_than;

      function same (left, right: test_keys) return boolean is
      begin
        if left=null or right=null then
           report("Fatal: same is null");
        end if;
        return left.all = right.all;
      end same;
    end my_keys;

  begin
    initialize(list);
    for T in tests loop
      node := insert (list, new target_keys'(input_keys(T)), input_values(T));
    end loop;

    for T in tests loop
      n := search (list, new target_keys'(target_keys(T)));
      v := value  (list, n);
      telln ("n=" &
             nodes'image(n) &
             "  value " &
             image (v));
    end loop;

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("text x=" &
             image (value (list, x)));
    end loop;

      tell(list);
    for T in tests range 1..3 loop
      delete (list, new target_keys'(input_keys (T)));
    end loop;
      tell (list);
    telln ("skip list test 3: 7 items in ascending order (no 3,6,9)");

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("  next x=" &
             image (value (list, x)));
    end loop;

  end test_bal_3;

  procedure test_bal_4 is
    subtype target_keys is string;
    type test_keys is access target_keys;
    type key_lists   is array (tests) of test_keys;
    input_keys:    constant key_lists   := (
       new string'(" 3"),
       new string'(" 6"),
       new string'(" 9"),
       new string'(" 1"),
       new string'(" 2"),
       new string'(" 5"),
       new string'(" 8"),
       new string'(" 7"),
       new string'(" 4"),
       new string'("10"));

    package my_keys is
      procedure assign (left: in out test_keys; right: test_keys);
      function image (key:   test_keys) return string;
      function same (left, right: test_keys) return boolean;
      function less_than (left, right: test_keys) return boolean;
    end my_keys;

    use my_keys;

    package skip_list is new balanced_essence (
      keys         => test_keys,
      first_key    => new target_keys'(""),
      last_key     => new target_keys'("~~~~~~~~"),
      "<"          => less_than,
      same         => same,
      key_image    => image,
      assign_key   => assign,
      values       => test_values,
      null_value   => new string'(""),
      assign_value => assign,
      nodes        => nodes,
      levels       => levels,
      value_image  => image);

    use skip_list;
    list: skip_lists;
    node: nodes;

    package body my_keys is
      procedure assign (left: in out test_keys; right: test_keys) is
      begin
        left := right; -- Copy the pointers without allocating a new copy.
      end assign;

      function image (key:   test_keys) return string is
      begin
        if key=null then
           report("Fatal: image is null");
        end if;
        return key.all;
      end image;

      function less_than (left, right: test_keys) return boolean is
      begin
        if left=null or right=null then
           report("Fatal: less_than is null");
        end if;
        return left.all < right.all;
      end less_than;

      function same (left, right: test_keys) return boolean is
      begin
        if left=null or right=null then
           report("Fatal: same is null");
        end if;
        return left.all = right.all;
      end same;
    end my_keys;

  begin
    initialize(list);
    for T in tests loop
      node := insert (list, input_keys(T), input_values(T));
    end loop;

    for T in tests loop
      n := search (list, input_keys(T));
      v := value  (list, n);
      telln ("n=" &
             nodes'image(n) &
             "  value " &
             image (v));
    end loop;

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("next x=" &
             image (value (list, x)));
    end loop;

      tell(list);
    for T in tests range 1..3 loop
      delete (list, input_keys (T));
    end loop;
      tell (list);
    telln ("skip list test 4: 7 items in ascending order (no 3,6,9)");

    x := header_node;
    for T in tests loop
      x := next_node (list, x);
      telln ("next x=" &
             image (value (list, x)));
    end loop;

  end test_bal_4;

begin

  -- The Tests are:
  --
  --   1. Key=Number
  --      Value=Number
  --
  --   2. Key=String
  --      Value=String
  --
  --   3. Key=Pointer to String
  --      Value=String
  --
  --   4. Key=Pointer to String
  --      Value=Pointer to String
  --
  --   5. Key=Fixed_String
  --      Value=Fixed_String
  --

  telln ("started test_bal_hard");
  test_bal_3;
  test_bal_4;
  telln ("test_bal_hard worked");
end test_bal_hard;



procedure test_bal_fixed_1 is
  use status;
  use fixed_string_control;

  type nodes        is range -1..20;
  type levels       is range 1..8;
  type tests is range 1..10;
  subtype test_values  is fixed_strings;
  type value_lists is array (tests) of test_values;
  input_values:  constant value_lists := (
    fixed_string("33 thirty_three"),
    fixed_string("36 thirty_six"),
    fixed_string("39 thirty_nine"),
    fixed_string("31 thirty-one"),
    fixed_string("32 thirty-two"),
    fixed_string("35 thirty-five"),
    fixed_string("38 thirty-eight"),
    fixed_string("37 thirty-seven"),
    fixed_string("34 thirty-four"),
    fixed_string("40 forty"));

  output_values: value_lists;
  n:             nodes;
  v:             test_values;
  telling:       constant boolean := FALSE;
  x:             nodes;

  subtype target_keys is string;
  subtype test_keys is fixed_strings;
  type key_lists   is array (tests) of test_keys;
  input_keys:    constant key_lists   := (
    fixed_string(" 3"),
    fixed_string(" 6"),
    fixed_string(" 9"),
    fixed_string(" 1"),
    fixed_string(" 2"),
    fixed_string(" 5"),
    fixed_string(" 8"),
    fixed_string(" 7"),
    fixed_string(" 4"),
    fixed_string("10"));


  package skip_list is new balanced_essence (
    keys         => test_keys,
    first_key    => null_fixed_string,
    last_key     => fixed_string("~~~~~~~~"),
    "<"          => "<",
    same         => same,
    key_image    => image,
    assign_key   => assign,
    values       => test_values,
    null_value   => null_fixed_string,
    assign_value => assign,
    nodes        => nodes,
    levels       => levels,
    value_image  => image);

  use skip_list;
  list: skip_lists;
  node: nodes;

  procedure iterate is
     this_key: fixed_strings;
  begin
     x := header_node;
     for T in tests loop
       x := next_node (list, x);
       telln ("next x=" &
              image (value (list, x)));
       this_key := key (list,x);
       if search (list, this_key) = failure then
          tell(list);
          report("Failed: test_search a");
       elsif linear_search (list, this_key) = failure then
          tell(list);
          report("Failed: test_search b");
       elsif search (list, input_keys (T)) = failure then
          tell(list);
          report("Failed: test_search c");
       elsif linear_search (list, input_keys (T)) = failure then
          tell(list);
          report("Failed: test_search d");
       end if;
     end loop;
  end iterate;

begin
  telln ("test_bal_fixed_1 started");
  initialize(list);
  for T in tests loop
    node := insert (list, input_keys(T), input_values(T));
  end loop;

  for T in tests loop
    n := search (list, input_keys(T));
    v := value  (list, n);
    telln ("n=" &
           nodes'image(n) &
           "  value " &
           image (v));
  end loop;

  iterate;

    tell(list);
  for T in tests range 1..3 loop
    delete (list, input_keys (T));
  end loop;
    tell (list);
  telln ("skip list test 4: 7 items in ascending order (no 3,6,9)");

  x := header_node;
  for T in tests loop
    x := next_node (list, x);
    telln ("next x=" &
           image (value (list, x)));
  end loop;
  telln ("test_bal_fixed_1 worked");
end test_bal_fixed_1;



procedure test_bal_fixed_2 is
   use status;
  use fixed_string_control;

  type nodes        is range -1..20;
  type levels       is range 1..8;
  type tests is range 1..10;
  subtype test_values  is fixed_strings;
  type value_lists is array (tests) of test_values;
  input_values:  constant value_lists := (
    fixed_string("33 thirty_three"),
    fixed_string("36 thirty_six"),
    fixed_string("39 thirty_nine"),
    fixed_string("31 thirty-one"),
    fixed_string("32 thirty-two"),
    fixed_string("35 thirty-five"),
    fixed_string("38 thirty-eight"),
    fixed_string("37 thirty-seven"),
    fixed_string("34 thirty-four"),
    fixed_string("40 forty"));

  output_values: value_lists;
  n:             nodes;
  v:             test_values;
  telling:       constant boolean := FALSE;
  x:             nodes;

  subtype target_keys is string;
  subtype test_keys is fixed_strings;
  type key_lists   is array (tests) of test_keys;
  input_keys:    constant key_lists   := (
    fixed_string(" 3"),
    fixed_string(" 6"),
    fixed_string(" 9"),
    fixed_string(" 1"),
    fixed_string(" 2"),
    fixed_string(" 5"),
    fixed_string(" 8"),
    fixed_string(" 7"),
    fixed_string(" 4"),
    fixed_string("10"));


  package skip_list is new balanced_essence (
    keys         => test_keys,
    first_key    => null_fixed_string,
    last_key     => fixed_string("~~~~~~~~"),
    "<"          => "<",
    same         => same,
    key_image    => image,
    assign_key   => assign,
    values       => test_values,
    null_value   => null_fixed_string,
    assign_value => assign,
    nodes        => nodes,
    levels       => levels,
    value_image  => image);

  use skip_list;
  list: skip_lists;
  node: nodes;

  procedure iterate is
     this_key: fixed_strings;
  begin
     x := header_node;
     for T in tests loop
       x := next_node (list, x);
       telln ("next x=" &
              image (value (list, x)));
       this_key := key (list,x);
       if search (list, this_key) = failure then
          tell(list);
          report("Failed: test_search a");
       elsif linear_search (list, this_key) = failure then
          tell(list);
          report("Failed test_search b");
       elsif search (list, input_keys (T)) = failure then
          tell(list);
          report("Failed test_search c");
       elsif linear_search (list, input_keys (T)) = failure then
          tell(list);
          report("Failed test_search d");
       end if;
     end loop;
  end iterate;

begin
  initialize(list);
  for T in tests loop
    node := insert (list, input_keys(T), input_values(T));
  end loop;

  for T in tests loop
    n := search (list, input_keys(T));
    v := value  (list, n);
    telln ("n=" &
           nodes'image(n) &
           "  value " &
           image (v));
  end loop;

  iterate;

    tell(list);
  for T in tests range 1..3 loop
    delete (list, input_keys (T));
  end loop;
    tell (list);
  telln ("skip list test 4: 7 items in ascending order (no 3,6,9)");

  x := header_node;
  for T in tests loop
    x := next_node (list, x);
    telln ("next x=" &
           image (value (list, x)));
  end loop;

  telln ("test_bal_fixed_2 worked");
end test_bal_fixed_2;


procedure test_bal_fixed_3 is
  use status;
  use fixed_string_control;

  type nodes        is range -1..20;
  type levels       is range 1..8;
  type tests is range 1..17;
  subtype test_values  is fixed_strings;
  type value_lists is array (tests) of test_values;
  input_values:  constant value_lists := (
    fixed_string("33 thirty_three"),
    fixed_string("36 thirty_six"),
    fixed_string("39 thirty_nine"),
    fixed_string("31 thirty-one"),
    fixed_string("32 thirty-two"),
    fixed_string("35 thirty-five"),
    fixed_string("38 thirty-eight"),
    fixed_string("37 thirty-seven"),
    fixed_string("34 thirty-four"),
    fixed_string("E1 extra 1"),
    fixed_string("E2 extra 2"),
    fixed_string("E3 extra 3"),
    fixed_string("E4 extra 4"),
    fixed_string("E5 extra 5"),
    fixed_string("E6 extra 6"),
    fixed_string("E7 extra 6"),
    fixed_string("40 forty"));

  output_values: value_lists;
  n:             nodes;
  v:             test_values;
  telling:       constant boolean := FALSE;
  x:             nodes;

  subtype target_keys is string;
  subtype test_keys is fixed_strings;
  type key_lists   is array (tests) of test_keys;
  input_keys:    constant key_lists   := (
     fixed_string("MODATA"),
     fixed_string("PB6Q.3"),
     fixed_string("PB6Q.3HI"),
     fixed_string("PDS1.3.2.1"),
     fixed_string("PDS1.3.2.2.1"),
     fixed_string("PDS1.3.2.2"),
     fixed_string("PDS1.3.3.1"),
     fixed_string("PDS1.3.3.2"),
     fixed_string("PPS3.1.9.8.1"),
     fixed_string("PPS3.4.1.1.3.1"),
     fixed_string("PPS3.4.1.1.3"),
     fixed_string("PPS3.4.1.1"),
     fixed_string("PPS3.4.1.2"),
     fixed_string("PPS3.4.1.3.3"),
     fixed_string("PPS3.4.1.3"),
     fixed_string("SRCCBMBMEM"),
     fixed_string("SRCCMEMO"));

  package skip_list is new balanced_essence (
    keys         => test_keys,
    first_key    => null_fixed_string,
    last_key     => fixed_string("~~~~~~~~"),
    "<"          => "<",
    same         => same,
    key_image    => image,
    assign_key   => assign,
    values       => test_values,
    null_value   => null_fixed_string,
    assign_value => assign,
    nodes        => nodes,
    levels       => levels,
    value_image  => image);

  use skip_list;
  list: skip_lists;
  node: nodes;

  procedure iterate is
     this_key: fixed_strings;
  begin
     x := header_node;
     for T in tests loop
       x := next_node (list, x);
       telln ("next x=" &
              image (value (list, x)));
       this_key := key (list,x);
       if search (list, this_key) = failure then
          tell(list);
          report("Failed test_search 5");
       elsif linear_search (list, this_key) = failure then
          tell(list);
          report("Failed test_search 6");
       elsif search (list, input_keys (T)) = failure then
          tell(list);
          report("Failed test_search 7");
       elsif linear_search (list, input_keys (T)) = failure then
          tell(list);
          report("Failed test_search 8");
       end if;
     end loop;
  end iterate;

begin
  telln ("test_bal_fixed_2 started");
  initialize(list);
  for T in tests loop
    node := insert (list, input_keys(T), input_values(T));
  end loop;

  for T in tests loop
    n := search (list, input_keys(T));
    v := value  (list, n);
    telln ("n=" &
           nodes'image(n) &
           "  value " &
           image (v));
  end loop;

  iterate;

    tell(list);
  for T in tests range 1..3 loop
    delete (list, input_keys (T));
  end loop;
    tell (list);
  telln ("skip list test 4: 7 items in ascending order (no 3,6,9)");

  x := header_node;
  for T in tests loop
    x := next_node (list, x);
    telln ("next x=" &
           image (value (list, x)));
  end loop;

  telln ("test_bal_fixed_3 worked");
end test_bal_fixed_3;

begin
  test_bal_easy;
  test_bal_hard;
  test_bal_fixed_1;
  test_bal_fixed_2;
  test_bal_fixed_3;
  status.telln("tsbal passed");
end tsbal;