From mboxrd@z Thu Jan 1 00:00:00 1970 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me X-Spam-Level: X-Spam-Status: No, score=1.0 required=5.0 tests=BAYES_00,FILL_THIS_FORM_LOAN autolearn=no autolearn_force=no version=3.4.4 X-Google-Language: ENGLISH,ASCII-7-bit X-Google-Thread: 103376,119e48152a817dff X-Google-Attributes: gid103376,public From: mfb@mbunix.mitre.org (Michael F Brenner) Subject: Re: Need B-Tree Source..... Date: 1998/04/04 Message-ID: <6g5sq4$i36@top.mitre.org> X-Deja-AN: 340868090 References: <6g0bfm$jt6@ecuador.earthlink.net> <199804031451.QAA09698@basement.replay.com> Summary: Yes, skip lists are good and here is one Organization: The MITRE Corporation, Bedford Mass. Keywords: skip list Newsgroups: comp.lang.ada Date: 1998-04-04T00:00:00+00:00 List-Id: -- 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 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 ' '); 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) 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("abc")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;