* Re: Need B-Tree Source.....
[not found] ` <199804031451.QAA09698@basement.replay.com>
@ 1998-04-04 0:00 ` Michael F Brenner
0 siblings, 0 replies; only message in thread
From: Michael F Brenner @ 1998-04-04 0:00 UTC (permalink / raw)
-- Yes, skip lists are good (sometimes faster, always easier to debug,
-- sometimes better dynamic characteristics like this one for
-- realtime use where there is no dynamic allocation).
-- Here is a sample skip list code with a test main program. Just
-- compile the following and link TTSKIP. Or with gnat,
-- gnatchop the following and then gnatmake ttskip.
--------------------------------------------------------------
package fixed_string_control is
pragma pure (fixed_string_control);
-- Fixed String control
-- The fixed_strings objects are allocated to a given fixed length and
-- track their length (within the allocation) thereafter.
-- They are sometimes (in the case of multiple copies of different
-- lengths) more efficient than ordinary_strings because allocation and
-- deallocation do not occur after initial creation.
-- The down side of fixed_strings is that someday you may get
-- a string that is longer than your chosen fixed length, and
-- then everything must be recompiled to get a new length for
-- strings. And everything will then take up the extra storage.
-- The fixed_strings objects are allocated to a given fixed length and
-- track their length (within the allocation) thereafter.
-- They are sometimes (in the case of multiple copies of different
-- lengths) more efficient than ordinary_strings
-- because allocation and deallocation do not
-- occur after initial creation. For example, instantiating
-- a linked_list generic with an access_strings type not only ran
-- out of storage, but also took more than 50% longer; while
-- changing to fixed_strings did not run out of storage.
-- The down side of fixed_strings is that someday you may get
-- a string that is longer than your chosen fixed length, and
-- then everything must be recompiled to get a new length for
-- strings. And everything will then take up the extra storage.
-- The maximum LENGTH of a fixed_string is determined forever, until
-- the next recompile of the whole world (cold start). The first
-- implementation of this package used 252, which is the largest
-- line editable by Turbo Pascal 3.0.
subtype fixed_string_strings is string (1..255);
-- Fixed strings are stored as arrays of
-- fixed_string_strings'LENGTH characters in memory.
-- Each fixed_string is stored (in LIST, below in the
-- PRIVATE section) as a character string of the
-- maximum possible length, along with its current length (in LENGTH).
-- The component LENGTH varies from 0 to the maximum length as different
-- strings are stored into the fixed_string using the COPY procedure.
type fixed_strings is private;
null_fixed_string: constant fixed_strings;
-- The null fixed_string is a fixed_string of maximum length whose
-- length is set to 0. It compares (using "<" below) less than all other
-- fixed_strings.
-- The high fixed_string is a fixed_string of maximum length whose
-- LENGTH component is set to the maximum length, and each character
-- is filled with the highest character in the alphabet.
high_fixed_string: constant fixed_strings;
-- The concatenation of fixed_strings works like ordinary_strings except it
-- returns a STRING instead of a fixed_string, and it fails when
-- the LENGTH is too long. On the other hand, concatenation of
-- ordinary_strings works until storage runs out.
function "&" (left: fixed_strings; right: fixed_strings) return string;
function "&" (left: string; right: fixed_strings) return string;
function "&" (left: fixed_strings; right: string) return string;
-- The fixed_string comparison method uses the character position
-- in the ASCII~ alphabet as
-- the collating sequence in strings of the same length. When strings
-- are of differing length, and they agree up the minimum of their lengths,
-- then the shorter string is considered less than the longer string.
function "<" (left, right: fixed_strings) return boolean;
function ">" (left, right: fixed_strings) return boolean;
-- The COPY method is used to store ordinary_strings or
-- fixed_strings into a fixed_string.
procedure copy (source: fixed_strings; target: in out fixed_strings);
procedure copy (source: string; target: in out fixed_strings);
-- The concatenation method is used to append a string onto the end
-- of a fixed_string.
procedure concat(onto: in out fixed_strings; appendage: string);
-- The element method returns a column of a fixed_string just like
-- array references get columns from ordinary_strings.
function element (message: fixed_strings;
col: natural) return character;
-- The IMAGE method returns the string image of a fixed_string.
function image (message: fixed_strings) return string;
-- The in_place_lower_case function converts
-- alphabetic character from upper to lower
-- case, ignoring all other characters. It is done in place on a fixed_string.
procedure in_place_lower_case (message: in out fixed_strings);
-- The in_place_truncate method is a procedure instead of a function,
-- for efficiency.
-- Therefore, it is not compatible with functional call in other packages.
procedure in_place_truncate (message: in out fixed_strings;
ch: character := ' ');
-- The in_place_upper_case function converts
-- alphabetic character from lower to upper
-- case, ignoring all other characters. It is done in place on a fixed_string.
procedure in_place_upper_case (message: in out fixed_strings);
-- The LENGTH method returns the length of the fixed_string.
function length (message: fixed_strings) return natural;
-- The SAME method is the equality operator for fixed_strings. To
-- be equal, the two strings must be of the same length, and agree
-- for each of their characters.
function same (left, right: fixed_strings) return boolean;
function same (left: fixed_strings; right: string) return boolean;
-- The set_element method sets a character in a single column
-- of a fixed_string like array references do for character
-- strings.
procedure set_element (message: in out fixed_strings;
col: natural;
value: character);
-- The set_length method truncates a string to a given length or else
-- extends its current length with blanks.
procedure set_length (message: in out fixed_strings; new_length: natural);
-- The fixed_string method converts an ordinary_string into a fixed_string.
function fixed_string (message: string) return fixed_strings;
-- The SLICE method emulates array slices for fixed_strings. The
-- SUBSTR method is similar, but based on length instead of final column.
-- The two-argument SUBSTR gets all characters on or after the given column.
-- All of these permit the START argument to take on a value equal to the
-- length of the fixed_string plus 1, returning the null ordinary_string.
function slice (message: fixed_strings;
start, finish: natural) return string;
function substr (message: fixed_strings;
start, length: natural) return string;
function substr (message: fixed_strings;
start: natural) return string;
private
type fixed_strings is record
length: integer := -1;
list: fixed_string_strings;
end record;
null_fixed_string: constant fixed_strings := (0, (others => ' '));
high_fixed_string: constant fixed_strings :=
(fixed_string_strings'last, (others => character'last));
end fixed_string_control;
package rand is
pragma pure (rand); -- Pure: same seed gives same number
-- RAND:
--
-- Purpose:
-- Spins a random dice with anywhere from1 to 16384 sides.
-- For example, to spin an 8-sided dice, do this:
-- eight_sided_seed: seeds;
-- random_number: rand.exacts;
-- spin (eight_sided_seed, 8, random_number);
-- Now the variable random contains a number in the range 1..8.
--
-- Architecture:
-- ADT (Abstract Data Type)
-- SIS (Semantically Independent Specification)
--
-- Notes: Other random number algorithms use floating point arithmetic,
-- multiply operators, or return numbers in the range 0.0 .. 1.0.
-- This one does not.
type seeds is limited private;
type exacts is range 0..32767;
for exacts'size use 16;
procedure spin (seed: in out seeds;
sides: exacts;
random_number: out exacts);
private
type seed_lists is array (exacts range 0..55) of exacts;
type seeds is record
fibonnacci_father: exacts := 24;
fibonnacci_mother: exacts := 55;
seed_list: seed_lists :=
(13, 16691, 7, 2113, 11, 5419, 2, 673, 1, 13857,
43, 15317, 5, 229, 14311, 1321, 2833, 337, 19, 4649,
3, 331, 31, 683, 9719, 2089, 257, 109, 17, 1613,
41, 1801, 29, 241, 4093, 9091, 101, 271, 23, 2351,
73, 953, 47, 113, 8779, 9901, 137, 449, 37, 4513,
97, 2731, 59, 431, 3541, 1409);
end record;
end rand;
with rand;
generic
type keys is limited private; -- Each node has a key and a value.
first_key: in out keys; -- Lowest key according to <.
last_key: in out 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 copy_key (source: keys; target: in out keys);
type values is limited private; -- A unique value for each key.
null_value: in out values;
with function value_image (value: values) return string;
with procedure copy_value (source: values; target: in out values);
with procedure tell (message: string);
with procedure telln(message: string);
package skip_essence is
pragma preelaborate (skip_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. A good reason to use skip
-- lists is balanced trees never seem to get past their software
-- development bugs. So 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.
--
-- 1997-01-31 MB Converted private keys and data to limited private
-- 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);
-- It would be nice to have an implementation that stores as
-- many duplicate keys and their respective values, but this does not.
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;
tree_fungus: exception;
type nodes is range -1 .. 2147483647;
type levels is range 1 .. 127;
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;
last_node: nodes;
last_level: levels);
procedure finalize (L: in out skip_lists);
procedure re_initialize (L: in out skip_lists);
procedure delete (L: in out skip_lists; k: keys);
procedure insert (L: in out skip_lists;
k: keys;
v: values;
inserted_node: out nodes);
procedure search (L: in out skip_lists;
k: keys;
found: in out nodes);
procedure search (L: in out skip_lists;
k: keys;
found: in out 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: in out skip_lists;
insertion_behavior:
behaviors_for_duplicate_keys);
procedure set_search_behavior (L: in out skip_lists;
search_behavior:
behaviors_when_not_found);
procedure set_tracing (L: in out skip_lists;
on: boolean);
private
-- In a skip list each node contains all of the levels of pointers. Thus,
-- it is important to decide on the number of levels of pointers. 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 of a skip list, so the human
-- does not wait more than 0.25 seconds after pressing the key.
-- The linked list implementing the balanced tree is actually a fixed array.
type key_lists is array (nodes range <>) of keys;
type value_lists is array (nodes range <>) of values;
type node_lists is array (nodes range <>) of nodes;
type level_lists is array (levels range <>) of nodes;
type pab_skip_lists (last_node: nodes;
last_level: levels;
last: nodes) is record
-- assert last = (last_node+2)*nodes(last_level)
high_level: levels;
high_node: nodes;
insertion_behavior: behaviors_for_duplicate_keys := fail;
search_behavior: behaviors_when_not_found := raise_not_found_exception;
tracing_bal: boolean := False;
key_list: key_lists (-1..last_node);
value_list: value_lists (-1..last_node);
node_list: node_lists (0..last);
update: level_lists (1..last_level);
seed: rand.seeds;
end record;
type skip_lists is access pab_skip_lists;
end skip_essence;
package string_control is
pragma pure (string_control);
-- Ordinary String control
function caselessly_equal (left, right: character)
return boolean;
function caselessly_equal (object: string; start, length: natural;
pattern: string)
return boolean;
procedure concat (message: string;
appendee: in out string;
length: in out natural);
function first_missing (message: string;
pattern: character := ' ')
return integer;
function first_occurring (message: string;
pattern: character := ' ')
return integer;
function first_occurring (message: string;
pattern: string)
return integer;
function indent (message: string)
return string;
procedure in_place_insert (message: in out string;
message_length: in out natural;
insertion: string;
after: natural);
function last_missing (message: string;
pattern: character := ' ')
return integer;
function last_occurring (message: string;
pattern: character := ' ')
return integer;
function left_trim (message: string;
pattern: character := ' ')
return string;
procedure lower_case (message: in out string;
start: natural;
finish: natural);
function lower_case (c: character)
return character;
function lower_case (message: string)
return string;
function right_trim (message: string;
pattern: character := ' ')
return string;
function same (left, right: string)
return boolean;
function substitute (base_string: string;
search_string: string;
replace_string: string)
return string;
procedure upper_case (message: in out string;
start: natural;
finish: natural);
function upper_case (c: character)
return character;
function upper_case (message: string)
return string;
end string_control;
with string_control;
package body fixed_string_control is
fixed_string_index_beyond_end: exception;
procedure is_okay (message: fixed_strings; method: string) is
fixed_string_not_initialized: exception;
begin
-- The fixed_string is checked to see if it had been initialized.
-- status.telln("method=" & method);
if message.length not in 0..fixed_string_strings'last then
raise fixed_string_not_initialized;
end if;
end is_okay;
function "&" (left: fixed_strings; right: fixed_strings) return string is
hold: fixed_strings;
begin
is_okay (left, "&(F,f)"); is_okay (right, "&(f,F)");
copy (left, hold);
concat (hold, right.list(1..right.length));
return hold.list(1..hold.length);
end "&";
function "&" (left: string; right: fixed_strings) return string is
hold: fixed_strings;
begin
is_okay (right, "&(o,f)");
copy (left, hold);
concat (hold, right.list(1..right.length));
return hold.list(1..hold.length);
end "&";
function "&" (left: fixed_strings; right: string) return string is
hold: fixed_strings;
begin
is_okay (left, "&(f,o)");
copy (left, hold);
concat (hold, right);
return hold.list(1..hold.length);
end "&";
function "<" (left, right: fixed_strings) return boolean is
begin
is_okay(left, "F<f"); is_okay(right,"f<F");
if left.length < right.length then
return left.list(1..left.length) <= right.list(1..left.length);
elsif left.length = right.length then
return left.list(1..left.length) < right.list(1..left.length);
else -- left.length > right.length
return left.list(1..right.length) < right.list(1..right.length);
end if;
end "<";
function ">" (left, right: fixed_strings) return boolean is
begin
is_okay(left, "F>f"); is_okay(right,"f>F");
if left.length < right.length then
return left.list(1..left.length) > right.list(1..left.length);
elsif left.length = right.length then
return left.list(1..left.length) > right.list(1..left.length);
else -- left.length > right.length
return left.list(1..right.length) >= right.list(1..right.length);
end if;
end ">";
procedure copy (source: string; target: in out fixed_strings) is
fixed_string_too_long_to_copy: exception;
begin
if source'length > fixed_string_strings'last then
raise fixed_string_too_long_to_copy;
end if;
target.length := source'length;
target.list (1..source'length) := source;
end copy;
procedure copy (source: fixed_strings; target: in out fixed_strings) is
begin
is_okay (source, "copy");
target := source;
end copy;
procedure concat (onto: in out fixed_strings; appendage: string) is
new_length: constant integer := onto.length + appendage'length;
fixed_string_too_long_to_concat: exception;
begin
is_okay (onto, "onto");
if new_length > fixed_string_strings'last then
raise fixed_string_too_long_to_concat;
end if;
onto.list(onto.length+1..new_length) := appendage;
onto.length := new_length;
end concat;
function element (message: fixed_strings;
col: natural) return character is
begin
is_okay (message, "element");
if col<1 then
raise fixed_string_index_beyond_end;
elsif col > message.length then
raise fixed_string_index_beyond_end;
end if;
return message.list (col);
end element;
function fixed_string (message: string) return fixed_strings is
temp: fixed_strings;
fixed_string_message_too_big: exception;
begin
if message'length > fixed_string_strings'last then
raise fixed_string_message_too_big;
end if;
temp.length:= message'length;
temp.list (1.. message'length):= message;
return temp;
end fixed_string;
function image (message: fixed_strings) return string is
begin
is_okay (message, "image");
if message.length=0 then return "";
else return message.list (1..message.length);
end if;
end image;
procedure in_place_lower_case (message: in out fixed_strings) is
begin
is_okay (message, "in_place_lower_case");
string_control.lower_case (message.list, 1, message.length);
end in_place_lower_case;
procedure in_place_truncate (message: in out fixed_strings;
ch: character := ' ') is
begin
is_okay (message, "in_place_truncate");
-- Structured loops may have multiple exits, but not multiple
-- entrances. The following loop EXIT commands ensure ease of
-- checking for both termination and effectiveness.
loop
exit when message.length = 0;
exit when message.list (message.length) /= ch;
message.length := message.length - 1;
end loop;
end in_place_truncate;
procedure in_place_upper_case (message: in out fixed_strings) is
begin
is_okay (message, "in_place_upper_case");
string_control.upper_case (message.list, 1, message.length);
end in_place_upper_case;
function length (message: fixed_strings) return natural is
begin
is_okay (message, "length");
return message.length;
end length;
function same (left, right: fixed_strings) return boolean is
begin
is_okay (left,"F=f"); is_okay(right, "f=F");
return left.length=right.length and then
left.list(1..left.length) = right.list(1..left.length);
end same;
function same (left: fixed_strings; right: string) return boolean is
begin
is_okay (left, "f=o");
return left.length=right'length and then
left.list(1..left.length) = right;
end same;
procedure set_element (message: in out fixed_strings;
col: natural;
value: character) is
begin
is_okay (message, "set_element");
if col > fixed_string_strings'last then
raise fixed_string_index_beyond_end;
elsif col = message.length+1 then
message.length := message.length + 1;
message.list (col) := value;
elsif col > message.length then
raise fixed_string_index_beyond_end;
else
message.list (col) := value;
end if;
end set_element;
procedure set_length (message: in out fixed_strings; new_length: natural) is
hold_length: integer := message.length;
begin
message.length := new_length;
if hold_length > fixed_string_strings'last or
hold_length < 0 then
for i in fixed_string_strings'range loop
message.list (i) := ' ';
end loop;
end if;
if hold_length > 0 then
for i in hold_length+1 .. new_length loop
message.list (i) := ' ';
end loop;
end if;
end set_length;
function slice (message: fixed_strings;
start, finish: natural) return string is
hold: fixed_strings;
begin
is_okay (message, "slice");
if start = 0 then
raise fixed_string_index_beyond_end;
elsif finish > message.length then
raise fixed_string_index_beyond_end;
end if;
if finish < start then
return "";
else
hold.length := finish+1-start;
hold.list (1..hold.length) := message.list (start..finish);
return hold.list (1..hold.length);
end if;
end slice;
function substr (message: fixed_strings;
start, length: natural) return string is
begin
is_okay (message, "substr");
if start+length-1 > fixed_string_strings'last then
raise fixed_string_index_beyond_end;
end if;
return slice (message, start, start+length-1);
end substr;
function substr (message: fixed_strings; start: natural) return string is
begin
is_okay (message, "substr(f,n)");
return slice (message, start, message.length);
end substr;
end fixed_string_control;
package body rand is
-- This random number generation technique is one of the oldest
-- dynamical systems, in constant use for over a thousand years,
-- made famous by Fibonnacci. It was proved uniform and its period
-- was shown to be long in "Random number generator for PC's" by
-- Marsaglia, Narasimhan, and Zaman in Computer Physics
-- Communications volume 60 number 3 October 1990 pages 345-349.
-- The seed array values are stable (you can change them). This
-- expression of this algorithm is a significant improvement over
-- published algorithms because of its superior initialization
-- numbers and its historical Fibonnacci-like biological references.
procedure spin (seed: in out seeds;
sides: exacts;
random_number: out exacts) is
-- The biology of the pseudo-fibonnacci sequence is as follows:
s: seed_lists renames seed.seed_list;
offspring: constant exacts :=
s(seed.fibonnacci_father) + s(seed.fibonnacci_mother);
internal_modulus: constant := 16384;
child: constant exacts := offspring mod internal_modulus;
begin
seed.fibonnacci_mother := seed. fibonnacci_mother - 1;
s(seed.fibonnacci_father) := child;
seed.fibonnacci_father := seed.fibonnacci_father - 1;
if seed.fibonnacci_father = s'first then
seed.fibonnacci_father := s'last;
elsif seed.fibonnacci_mother = s'first then
seed.fibonnacci_mother := s'last;
end if;
random_number := 1 + child mod sides; -- Random number from 1 to sides
end spin;
end rand;
package body skip_essence is
-- History
--
-- 19970916 MB initialized search output parameter detected by 3.10p
procedure assert (condition: boolean; message: string) is
-- It is essential for efficiency that this be a local procedure.
begin
if not condition then
telln(message);
raise tree_fungus;
end if;
end assert;
procedure check_range (key: keys) is
begin
assert (first_key<key and key<last_key, "key:bad"&key_image(key)); --?
end check_range;
-- Object Access Functions
function key (L: skip_lists; n: nodes) return keys is
begin
return L.key_list(n);
end key;
function p (L: skip_lists; n: nodes; i: levels) return nodes is
-- implement skip_list as array (1..last_level, -1..last_node) of nodes;
index: constant nodes := (n+1)*nodes(L.last_level)+nodes(i)-1;
begin
return L.node_list(index);
end p;
procedure set_p (L: skip_lists; n: nodes; i: levels; p: nodes) is
index: constant nodes := (n+1)*nodes(L.last_level)+nodes(i)-1;
begin
L.node_list(index) := p;
end set_p;
function value (L: skip_lists; n: nodes) return values is
begin
assert (n/=header_node, "val:n=hd");
return L.value_list(n);
end value;
-- Methods
procedure re_initialize (L: in out skip_lists) is
begin
L.high_node := 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;
-- Each pointer in the header node and the
-- trailer node point at the trailer node.
copy_key (last_key, L.key_list(trailer_node));
copy_value (null_value, L.value_list(trailer_node));
-- Dummy keys are inserted in the TRAILER_NODE that
-- are larger than any other possible key.
copy_key (first_key, L.key_list(header_node));
copy_value (null_value, L.value_list(header_node));
-- 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;
last_node: nodes;
last_level: levels) is
API_test1: constant nodes := -1;
API_test2: constant levels := 1;
begin
L := new pab_skip_lists (last_node,
last_level,
(last_node+1)*nodes(last_level));
-- 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 -- Traces a balanced tree
pointers: string (1..64);
null_pointer_area: constant string (pointers'range) := (others => ' ');
pointers_upto: natural := 0;
begin
tell ("hi-level and node");
tell (levels'image(L.high_level));
telln(nodes'image(L.high_node));
for node in nodes range -1..L.high_node loop
pointers_upto := 0;
pointers := null_pointer_area;
for level in 1..L.high_level loop
declare
this_pointer: constant nodes := p (L, node, 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;
tell (key_image (L.key_list(node)));
tell (nodes'image(node));
tell (" V ");
tell (value_image(L.value_list(node)));
tell (" P");
telln(pointers (1..pointers_upto));
end loop;
end tell;
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: in out 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 L.tracing_bal then
tell (" usearch [");
tell (key_image(k));
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 have been,
-- if the key were in the tree.
before_node := x;
if L.tracing_bal then
tell (" before node=");
tell (nodes'image(x));
telln ("");
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: in out 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 allocate it, and it might not be a pointer.
-- 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 (L: skip_lists) return levels is
level: levels := 1;
big: constant := 8192;
fraction: constant := big / 2;
random_number: rand.exacts;
begin
loop
-- Spin the "dice" until the sum of the probabilities exceed 0.5.
rand.spin (L.seed, big, random_number);
exit when integer (random_number) > fraction;
level := level+1;
exit when level = L.last_level;
end loop;
return level;
end random_level;
procedure insert (L: in out skip_lists;
k: keys;
v: values;
inserted_node: out nodes) is
next_level: levels;
pre_x: nodes; -- node that points to x
x: nodes;
level_node: nodes;
begin
is_okay (L);
if L.tracing_bal then
tell (" INS key=");
tell (key_image(k));
tell (" Value=[");
tell (value_image(v));
tell ("]");
check_range (k);
end if;
update_search (L, k, pre_x, x);
if not same (key (L, x), k) then
next_level := random_level (L);
if next_level > L.high_level then
for i in L.high_level + 1 .. next_level loop
L.update(i) := header_node;
end loop;
L.high_level := next_level;
end if;
assert (L.high_node < L.last_node, "ins:oflo");
L.high_node := L.high_node + 1;
-- The new node is "allocated".
x := L.high_node;
for i in levels'first .. next_level loop
level_node := P(L, L.update(i), i);
set_p (L, x, i, level_node);
set_p (L, L.update(i), i, x);
end loop;
copy_key (K, L.key_list(x));
elsif L.insertion_behavior = raise_duplicate_exception then
raise duplicate;
else
null;
end if;
copy_value (v, L.value_list(x)); -- In either case, set the value.
inserted_node := 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 each node is 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.high_node + 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;
procedure search (L: in out skip_lists; k: keys; found: in out 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 =>
insert (L, k, null_value, y);
when raise_not_found_exception =>
raise not_found;
end case;
end if;
found := y;
end search;
procedure search (L: in out skip_lists; k: keys; found: in out values) is
pre_x: nodes; -- not implemented yet?
x: nodes;
y: nodes;
v: values;
begin
update_search (L, k, pre_x, x);
if same (key (L, x), k) then
copy_value (value (L,x), found);
else
case L.search_behavior is
when insert_nothing_and_return_next_lower_node =>
raise not_found;
when insert_nothing_and_return_null_value =>
copy_value (null_value, v);
when insert_null_value_and_return_it =>
insert(L,k,null_value,y);
copy_value (null_value, v);
when raise_not_found_exception =>
raise not_found;
end case;
copy_value (v, found);
end if;
end search;
procedure set_insertion_behavior (L: in out skip_lists;
insertion_behavior:
behaviors_for_duplicate_keys) is
begin
L.insertion_behavior := insertion_behavior;
end set_insertion_behavior;
procedure set_search_behavior (L: in out skip_lists;
search_behavior:
behaviors_when_not_found) is
begin
L.search_behavior := search_behavior;
end set_search_behavior;
procedure set_tracing (L: in out skip_lists; on: boolean) is
begin
L.tracing_bal := on;
end set_tracing;
end skip_essence;
package body string_control is
function caselessly_equal (left, right: character) return boolean is
begin
return
left=right or else
(left in 'A'..'Z' and then right=character'val(character'pos(left)+32))
or else
(left in 'a'..'z' and then right=character'val(character'pos(left)-32));
end caselessly_equal;
function caselessly_equal (object: string; start, length: natural;
pattern: string) return boolean is
begin
if length /= pattern'length then return FALSE;
else
for i in 1..length loop
if not caselessly_equal (object (start + i - 1),
pattern (pattern'first + i - 1)) then
return FALSE;
end if;
end loop;
end if;
return TRUE;
end caselessly_equal;
procedure concat (message: string;
appendee: in out string;
length: in out natural) is
concat_too_long: exception;
begin
if length + message'length > appendee'length then
raise concat_too_long;
end if;
appendee (length + 1 .. length + message'length) := message;
length := length + message'length;
end concat;
function first_missing (message: string;
pattern: character := ' ') return integer is
begin
for i in message'range loop
if message(i) /= pattern then
return i;
end if; -- message (message'first..i) are patterns.
end loop;
return message'last + 1; -- Returns the first column without PATTERN.
end first_missing;
function first_occurring (message: string;
pattern: character := ' ') return integer is
begin
for i in message'range loop
if message(i) = pattern then
return i;
end if; -- message (message'first..i) contains no pattern
end loop;
return message'last+1; -- Returns the first column with PATTERN.
end first_occurring;
function first_occurring (message: string; pattern: string) return integer is
upto: natural := message'first;
last: integer := message'last + 1 - pattern'length;
index_null_pattern: exception;
RSTART: natural := 0;
begin
RSTART := 0;
if pattern="" then
raise index_null_pattern;
end if;
loop
exit when upto>last;
if message(upto..upto+pattern'length-1)=pattern then
RSTART := upto;
return RSTART;
end if;
upto := upto + 1;
end loop;
return RSTART;
end first_occurring;
procedure in_place_insert (message: in out string;
message_length: in out natural;
insertion: string;
after: natural) is
string_control_in_place_insert_ml_plus_il_gt_ml: exception;
begin
if message_length + insertion'length > message'length then
raise string_control_in_place_insert_ml_plus_il_gt_ml;
end if;
message(insertion'length + 1 + after .. message_length+insertion'length) :=
message(after+1..message_length);
message(after+1..after+insertion'length) := insertion;
message_length := message_length + insertion'length;
end in_place_insert;
function indent(message: string) return string is
begin
return (1..message'length + 1 => ' ');
end indent;
function last_missing (message: string;
pattern: character := ' ') return integer is
begin
for i in reverse message'range loop
if message(i) /= pattern then
return i;
end if; -- message (i..message'last) are patterns.
end loop;
return 0; -- Returns the last column without PATTERN.
end last_missing;
function last_occurring (message: string;
pattern: character := ' ') return integer is
begin
for i in reverse message'range loop
if message (i) = pattern then
return i;
end if; -- message (i..message'last) contains no pattern
end loop;
return 0; -- Returns the last column with PATTERN.
end last_occurring;
function left_trim (message: string;
pattern: character := ' ') return string is
left_trim_last: constant natural := first_missing (message, pattern);
begin
return message (left_trim_last .. message'last);
end left_trim;
function lower_case (c: character) return character is
begin
if c in 'A'..'Z' then
return character'val (character'pos (c) + 32);
end if;
return c;
end lower_case;
procedure lower_case (message: in out string;
start: natural; finish: natural) is
begin
for i in start..finish loop
if message (i) in 'A'..'Z' then
message (i) := character'val (character'pos (message (i)) + 32);
end if;
end loop;
end lower_case;
function lower_case (message: string) return string is
hold_message: string (1..message'length) := message;
ch: character;
offset: constant := character'pos ('a') - character'pos ('A');
begin
for c in hold_message'range loop
ch := hold_message (c);
if ch in 'A'..'Z' then
hold_message (c) := character'val (character'pos (ch) + offset);
end if; -- MESSAGE (FIRST..C) is in lower_case.
end loop;
return hold_message; -- MESSAGE is in lower_case.
end lower_case;
function right_trim (message: string;
pattern: character := ' ') return string is
right_trim_last: constant natural := last_missing (message, pattern);
begin
return message (message'first .. right_trim_last);
end right_trim;
function same (left, right: string) return boolean is
-- String Comparison: Semantically, left=right.
begin
return left'length = right'length and then
left = right;
end same;
function substitute (base_string: string;
search_string: string;
replace_string: string)
return string is
location: constant natural := first_occurring (base_string, search_string);
begin
if location = 0 then
return base_string;
elsif location = 1 then
return replace_string &
base_string (location+
search_string'length..
base_string'last);
elsif location = base_string'last + 1 - search_string'length then
return base_string (base_string'first..
base_string'last-search_string'length) &
replace_string;
else
declare
left_part: constant string :=
base_string (base_string'first..location - 1);
begin
return left_part &
replace_string &
base_string (location + search_string'length ..
base_string'last);
end;
end if;
end substitute;
function upper_case (c: character) return character is
begin
if c in 'a'..'z' then
return character'val (character'pos (c) - 32);
end if;
return c;
end upper_case;
procedure upper_case (message: in out string;
start: natural; finish: natural) is
begin
for i in start..finish loop
if message (i) in 'a'..'z' then
message (i) := character'val (character'pos (message (i)) - 32);
end if;
end loop;
end upper_case;
function upper_case (message: string) return string is
hold_message: string (1..message'length) := message;
ch: character;
offset: constant := character'pos ('a') - character'pos ('A');
begin
for c in hold_message'range loop
ch := hold_message (c);
if ch in 'a'..'z' then
hold_message (c) := character'val (character'pos (ch) - offset);
end if; -- MESSAGE (FIRST..C) is in upper_case.
end loop;
return hold_message; -- MESSAGE is in upper case.
end upper_case;
end string_control;
with skip_essence;
with fixed_string_control;
with text_io;
with ttstrord;
with ttstrfix;
procedure ttskip is
-- Testing the Balanced Trees
bal_output: text_io.file_type;
procedure tell (message: string) is
begin
text_io.put (bal_output, message);
end tell;
procedure telln (message: string) is
begin
text_io.put_line (bal_output, message);
end telln;
procedure kill (message: string) is
ttskip_failed: exception;
begin
text_io.put_line (message);
text_io.put_line ("TTSKIP Failed");
raise ttskip_failed;
end kill;
procedure test_bal_easy is
type test_values is range -1..127; -- -1 indicates a null value
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);
telling: constant boolean := FALSE;
type target_keys is range 0..127; -- The first and last key are reserved.
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 copy (source: test_values; target: in out test_values) is
begin
target := source;
end copy;
procedure test_bal_simple is
package my_keys is
subtype test_keys is target_keys;
null_value: test_values := -1;
first_key: test_keys := test_keys'first;
last_key: test_keys := test_keys'last;
procedure copy (source: test_keys; target: in out 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 skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => "<",
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
value_image => image,
copy_value => copy,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
node: nodes;
n: nodes;
x: nodes;
v: test_values;
package body my_keys is
procedure copy (source: test_keys; target: in out test_keys) is
begin
target := source;
end copy;
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, 20, 8);
for T in tests loop
insert (list, input_keys(T), input_values(T), node);
end loop;
for T in tests loop
search (list, test_keys(T), n);
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;
first_key: test_keys := new target_keys'(target_keys'first);
last_key: test_keys := new target_keys'(target_keys'last);
null_value: test_values := -1;
procedure copy (source: test_keys; target: in out 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 skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => less_than,
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
copy_value => copy,
value_image => image,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
node: nodes;
n: nodes;
x: nodes;
v: test_values;
package body my_keys is
procedure copy (source: test_keys; target: in out test_keys) is
begin
target := source; -- copies pointers without allocating a new copy?
end copy;
function image (key: test_keys) return string is
begin
if key=null then
kill("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
kill("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
kill("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,20,8);
for T in tests loop
insert (list, new target_keys'(input_keys(T)), input_values(T), node);
end loop;
telln("inserted test_bal_2");
for T in tests loop
search (list, new target_keys'(target_keys(T)), n);
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
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;
v: test_values;
telling: constant boolean := FALSE;
procedure copy (source: test_values; target: in out test_values) is
begin
target := source;
end copy;
function image (value: test_values) return string is
begin
if value = null then
return "!!";
else
return value.all;
end if;
end image;
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;
first_key: test_keys := new target_keys'(target_keys'first);
last_key: test_keys := new target_keys'(target_keys'last);
null_value: test_values := new string'("");
procedure copy (source: test_keys; target: in out 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 skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => less_than,
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
copy_value => copy,
value_image => image,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
n: nodes;
x: nodes;
node: nodes;
package body my_keys is
procedure copy (source: test_keys; target: in out test_keys) is
begin
target := source; -- copies pointers, not objects?
end copy;
function image (key: test_keys) return string is
begin
if key=null then
kill("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
kill("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
kill("Fatal: same is null");
end if;
return left.all = right.all;
end same;
end my_keys;
begin
initialize(list,20,8);
for T in tests loop
insert (list, new target_keys'(input_keys(T)), input_values(T), node);
end loop;
for T in tests loop
search (list, new target_keys'(target_keys(T)), n);
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
first_key: test_keys := new target_keys'("");
last_key: test_keys := new target_keys'("~~~~~~~~");
null_value: test_values := new string'("");
procedure copy (source: test_keys; target: in out 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 skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => less_than,
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
copy_value => copy,
value_image => image,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
node: nodes;
n: nodes;
x: nodes;
v: test_values;
package body my_keys is
procedure copy (source: test_keys; target: in out test_keys) is
begin
target := source; -- copies pointers, not objects?
end copy;
function image (key: test_keys) return string is
begin
if key=null then
kill("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
kill("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
kill("Fatal: same is null");
end if;
return left.all = right.all;
end same;
end my_keys;
begin
initialize(list,20,8);
for T in tests loop
insert (list, input_keys(T), input_values(T), node);
end loop;
for T in tests loop
search (list, input_keys(T), n);
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 fixed_string_control;
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"));
v: test_values;
telling: constant boolean := FALSE;
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"));
first_key: test_keys := null_fixed_string;
last_key: test_keys := fixed_string ("~~~~~~~~");
null_value: test_values := null_fixed_string;
package skip_list is new skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => "<",
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
copy_value => copy,
value_image => image,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
node: nodes;
n: nodes;
x: 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);
search (list, this_key, n);
if n = failure then
tell(list);
kill("Failed: test_search a");
elsif linear_search (list, this_key) = failure then
tell(list);
kill("Failed: test_search b");
end if;
search (list, input_keys (T), n);
if n = failure then
tell(list);
kill("Failed: test_search c");
elsif linear_search (list, input_keys (T)) = failure then
tell(list);
kill("Failed: test_search d");
end if;
end loop;
end iterate;
begin
telln ("test_bal_fixed_1 started");
initialize(list,20,8);
for T in tests loop
insert (list, input_keys(T), input_values(T), node);
end loop;
for T in tests loop
search (list, input_keys(T), n);
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 fixed_string_control;
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"));
v: test_values;
telling: constant boolean := FALSE;
subtype target_keys is string;
subtype test_keys is fixed_strings;
first_key: test_keys := null_fixed_string;
last_key: test_keys := fixed_string ("~~~~~~~~");
null_value: fixed_strings := null_fixed_string;
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 skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => "<",
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
copy_value => copy,
value_image => image,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
node: nodes;
n: nodes;
x: 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);
search (list, this_key, n);
if n = failure then
tell(list);
kill("Failed: test_search a");
elsif linear_search (list, this_key) = failure then
tell(list);
kill("Failed test_search b");
end if;
search (list, input_keys (T), n);
if n = failure then
tell(list);
kill("Failed test_search c");
elsif linear_search (list, input_keys (T)) = failure then
tell(list);
kill("Failed test_search d");
end if;
end loop;
end iterate;
begin
initialize(list,20,8);
for T in tests loop
insert (list, input_keys(T), input_values(T), node);
end loop;
for T in tests loop
search (list, input_keys(T), n);
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 fixed_string_control;
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("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"));
v: test_values;
telling: constant boolean := FALSE;
subtype target_keys is string;
subtype test_keys is fixed_strings;
first_key: test_keys := null_fixed_string;
last_key: test_keys := fixed_string("~~~~~~~~");
null_value: test_values := null_fixed_string;
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 skip_essence (
keys => test_keys,
first_key => first_key,
last_key => last_key,
"<" => "<",
same => same,
key_image => image,
copy_key => copy,
values => test_values,
null_value => null_value,
copy_value => copy,
value_image => image,
tell => tell,
telln => telln);
use skip_list;
list: skip_lists;
node: nodes;
n: nodes;
x: 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);
search (list, this_key, n);
if n = failure then
tell(list);
kill("Failed test_search 5");
elsif linear_search (list, this_key) = failure then
tell(list);
kill("Failed test_search 6");
end if;
search (list, input_keys (T), n);
if n = failure then
tell(list);
kill("Failed test_search 7");
elsif linear_search (list, input_keys (T)) = failure then
tell(list);
kill("Failed test_search 8");
end if;
end loop;
end iterate;
begin
telln ("test_bal_fixed_2 started");
initialize(list,20,8);
for T in tests loop
insert (list, input_keys(T), input_values(T), node);
end loop;
for T in tests loop
search (list, input_keys(T), n);
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: 17 items in ascending order (3 deleted)");
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
ttstrfix;
ttstrord;
begin
text_io.open (bal_output, text_io.out_file, "tsbal.tmp", "");
exception
when text_io.name_error =>
text_io.create (bal_output, text_io.out_file, "tsbal.tmp", "");
end;
test_bal_easy;
test_bal_hard;
test_bal_fixed_1;
test_bal_fixed_2;
test_bal_fixed_3;
telln("ttskip passed");
text_io.close (bal_output);
end ttskip;
with fixed_string_control;
procedure ttstrfix is
use fixed_string_control;
test_message: constant string := " Now is tHe time k1!";
procedure assert (condition: boolean) is
tsstrvar_failed: exception;
begin
if not condition then
raise tsstrvar_failed;
end if;
end assert;
procedure test_copy_1 is
x: fixed_strings;
begin
copy("",x);
assert (image(x)="");
end test_copy_1;
procedure test_case_1 is
message: fixed_strings :=fixed_string("okay, I have - UPs & 96 Downs");
upped: fixed_strings :=fixed_string("OKAY, I HAVE - UPS & 96 DOWNS");
lowed: fixed_strings :=fixed_string("okay, i have - ups & 96 downs");
work: fixed_strings;
begin
copy("abc", work);
in_place_upper_case(work);
assert (same(work,"ABC"));
copy(message, work);
in_place_upper_case(work);
assert (same (work, upped));
copy(message,work);
in_place_lower_case(work);
assert (same (work, lowed));
end test_case_1;
procedure test_element_1 is
d: fixed_strings := null_fixed_string;
begin
set_element (d, 1, 'a');
set_element (d, 2, 'b');
set_element (d, 3, 'c');
assert (element (d, 2) = 'b');
end test_element_1;
procedure test_concat_1 is
f,g,h,k: fixed_strings;
begin
copy("A", f);
copy("B", g);
copy("AB", h);
copy(f&g, k);
assert (same (k,h));
end test_concat_1;
procedure test_fixed_string is
temp: constant string:= "(abcdefg)";
temp_fixed: fixed_strings;
begin
temp_fixed:= fixed_string (temp (2..8));
assert (same(temp_fixed, "abcdefg"));
end test_fixed_string;
procedure test_in_place_truncate_1 is
message: fixed_strings := fixed_string("abc ");
begin
in_place_truncate (message);
assert (same (message, "abc"));
assert (length(message)=3);
end test_in_place_truncate_1;
procedure test_lessthan_1 is
begin
assert (not (fixed_string("abc")<fixed_string("ab") ));
assert ( (fixed_string("ab") <fixed_string("abc")) );
assert (not (fixed_string("ac") <fixed_string("ab")) );
assert ( (fixed_string("ab") <fixed_string("ac")) );
assert (not (fixed_string("abc")<fixed_string("aa")) );
assert ( (fixed_string("aa") <fixed_string("abc")) );
assert (not (fixed_string("ac") <fixed_string("abc")) );
assert ( (fixed_string("abc")<fixed_string("ac")) );
assert ( (fixed_string("abc")>fixed_string("ab")) );
assert ( (fixed_string("abc")<fixed_string("ac")) );
assert (not (fixed_string("ab") >fixed_string("abc")) );
assert ( (fixed_string("ac") >fixed_string("ab")) );
assert (not (fixed_string("ab") >fixed_string("ac")) );
assert ( (fixed_string("abc")>fixed_string("aa")) );
assert (not (fixed_string("aa") >fixed_string("abc")) );
assert ( (fixed_string("ac") >fixed_string("abc")) );
end test_lessthan_1;
procedure test_same_1 is
SS: constant string :="Now is the time for all good men to come to the";
a,b,c,d: fixed_strings;
begin
copy("Now",a);
copy("Now",b);
copy("Now ",c);
copy(" Now",d);
assert (same (a, b));
assert (not same (a,c));
assert (not same (a,d));
copy(SS,c);
copy(SS,d);
assert (same (c,d));
end test_same_1;
procedure test_slice_1 is
x, y, z: fixed_strings;
okay: constant string := "abcd";
begin
copy("abc",x);
copy(okay(2..3),y);
copy(slice(x, 2, 3),z);
assert (same (y,z));
copy(substr(x,2,2),z);
assert (same (z,y));
assert (substr(z,1,0)="");
end test_slice_1;
begin
test_copy_1;
test_case_1;
test_concat_1;
test_element_1;
test_fixed_string;
test_in_place_truncate_1;
test_lessthan_1;
test_same_1;
test_slice_1;
end ttstrfix;
with string_control;
procedure ttstrord is
use string_control;
procedure assert (condition: boolean; message: string :="") is
tsstrord_failed: exception;
begin
if not condition then
raise tsstrord_failed;
end if;
end assert;
pragma inline (assert);
procedure test_case_1 is
y: string (1..4) := "oKay";
begin
assert (lower_case ('A') = 'a');
assert (lower_case ('a') = 'a');
assert (lower_case ('*') = '*');
assert (upper_case ('a') = 'A');
assert (upper_case ('A') = 'A');
assert (upper_case ('*') = '*');
lower_case (y, 3, 4); assert (y="oKay");
lower_case (y, 2, 3); assert (y="okay");
upper_case (y, 4, 4); assert (y="okaY");
end test_case_1;
procedure test_caseless_1 is
begin
assert (caselessly_equal ("abc", 2, 2, "Bc"));
assert (not caselessly_equal ("abc", 1, 2, "Bc"));
assert (caselessly_equal ("declare",1,7,"declare"));
assert (caselessly_equal ("DECLARE",1,7,"declare"));
assert (caselessly_equal ("DECLARE",1,7,"DECLARE"));
assert (caselessly_equal ("declare",1,7,"DECLARE"));
end test_caseless_1;
procedure test_in_place_insert_1 is
hello: string (1..8) := "ABCDExyz";
hello_length: natural := 5;
to_be_inserted: constant string := "123";
begin
in_place_insert (message => hello,
message_length => hello_length,
insertion => to_be_inserted,
after => 3);
assert(hello_length = 8);
assert(same (hello, "ABC123DE"));
end test_in_place_insert_1;
procedure test_search_1 is
x: constant string := "aB ";
y: constant string := " aB";
z: constant string := " aB ";
begin
assert (x (1..0) = "" );
assert (x (2..0) = "" );
assert (lower_case (x) = "ab ");
assert (upper_case (x) = "AB ");
assert (right_trim (z) = y );
assert (right_trim (" ") = "" );
assert (right_trim ("") = "" );
assert (left_trim (z) = x );
assert (left_trim (z) /= y );
assert (left_trim (" ") = "" );
assert (left_trim ("") = "" );
assert (first_occurring (x,'a') = 1 );
assert (last_occurring (x,'a') = 1 );
assert (first_missing (x,'a') = 2 );
assert (last_missing (x,'a') = 3 );
assert (first_occurring (x,'c') = 4 );
assert (last_occurring (x,'c') = 0 );
assert (first_missing (x,'c') = 1 );
assert (last_missing (x,'c') = 3 );
assert (first_missing ("!!!",'!') = 4 );
assert (last_missing ("!!!",'!') = 0 );
assert (last_missing (x,'c') = 3 );
assert (first_missing ("!!!",'!') = 4 );
assert (last_missing ("!!!",'!') = 0 );
end test_search_1;
begin
test_case_1;
test_caseless_1;
test_in_place_insert_1;
test_search_1;
end ttstrord;
^ permalink raw reply [flat|nested] only message in thread