* Re: Anyone could give a complete and yet small program on the use for the generic
1997-01-02 0:00 ` Robert Dewar
@ 1997-01-03 0:00 ` Michael F Brenner
1997-01-04 0:00 ` Rich Maggio
1997-01-10 0:00 ` Robert I. Eachus
1997-01-03 0:00 ` Jon S Anthony
1 sibling, 2 replies; 13+ messages in thread
From: Michael F Brenner @ 1997-01-03 0:00 UTC (permalink / raw)
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;
^ permalink raw reply [flat|nested] 13+ messages in thread