Personal tools
You are here: Home Projects SETL SETL2 Source code DB_database.stl
Document Actions

DB_database.stl

by Paul McJones last modified 2021-02-25 11:33

The main big strings and database implementation, with test.

--files: string_utility_pak.stl,sort_pak.stl,get_lines_pak.stl,random_pak.stl
--			disk_records_refct.stl, B_tree_for_bigs_refct.stl, B_tree_for_bigs_wdix.stl, B_tree_for_bigs_wdoc.stl,
--			B_tree_for_bigs_dbix.stl, Big_stg_for_wdoc.stl
--file database_top.stl  test_bs
package big_string_pak;

const bs_code_pts := {"copy", "simple", "optimized", "chop", "tree", "concat_join", "concat_balance", "concat_chop", 	
	"nocon_opt", "nocon", "nocon_left", "nocon_right", "nocon_iter", "nocon_del", "nocon_ins", 	"nocon_to_simp"};
			-- code points to be traversed

	procedure bs_from_stg(stg);				-- create a big string from a string
	procedure stg_from_bigstg(rec);			-- make a string from a big_string
	procedure bs_slice(rec,i,j);			-- the slice extraction operation
	procedure bs_length(rec);				-- length of a bigstring
	procedure bs_set_slice(rw rec,i,j,stg);	-- the slice assignment operation
												
												-- (PUBLIC FOR DEBUGGING ONLY)
	procedure stg_past(j,rec);				-- make a string from a the part of a big_string from j onward
	procedure stg_till(j,rec);				-- make a string from a the part of a big_string up to j
	procedure chop_up(first,mid,last);		-- chop the concatenation of three strings into a tuple of string records
	procedure print_raw(); 					-- raw print for debugging
	procedure bnr_voc(rec,j);				-- j'th member of vector of children for B_tree_for_bigstring records
	procedure bs_check_leaves(rec);			-- leaf consistency check

end big_string_pak;

package body big_string_pak;

use setldb,byteutil,disk_records_pak,db_records,B_tree_for_bigstring,string_utility_pak;

procedure bs_from_stg(stg);					-- make a big_string from a string

												-- we first chop up the string into a tuple of string records
	if #(pieces_tup := chop_up("",stg,"")) = 1 then return make_record(pieces_tup(1)); end if;
						-- see comment on the 'chop_up' routine, below. If the whole string fits in 
						-- just one string record, we simply return that record.
--print("#pieces_tup: ",#pieces_tup);
--print("Total len ",+/[#y:y in pieces_tup]);

	return bnr_make_from_tuple(pieces_tup);		-- otherwise convert the list of sections returned into a tree

end bs_from_stg;

procedure stg_from_bigstg(rec);					-- make a string from a big_string

	if dr_load(rec)(type_byte) = string_record then return sr_slice(rec,1,sr_length(rec)); end if;
		-- get string from record

	if not dr_is_compound(rec) then 			-- concatenate strings from records
		return  "" +/ [sr_slice(ch,1,sr_length(ch)): j in [1..num_childr(rec)] | (ch := bnr_voc(rec,j)) /= OM];
	end if;

	return "" +/ [stg_from_bigstg(bnr_voc(rec,j)): j in [1..num_childr(rec)]];	-- else proceed recursively
	
end stg_from_bigstg;

procedure stg_past(j,rec);					-- make a string from a the part of a big_string from j onward

	if dr_load(rec)(type_byte) = string_record then			-- get string from record

		if j > (sl := sr_length(rec)) then 
			abort("Illegal character index in simple stg_past operation: " + str(j) + ", " + sl);
		end if;

		return sr_slice(rec,j,sl); 		-- return slice from j onward 

	end if;
	
							-- get the child containing the first character past j 
	if not (exists chix in [1..nc := num_childr(rec)] | bnr_get_ch_cum(rec,chix) >= j) then 
		abort("Illegal character index in stg_past operation: " + str(j) + ", " + nc);
	end if;
	
	prev_cum := if chix = 1 then 0 else bnr_get_ch_cum(rec,chix - 1) end if;	-- the previous cumulant

	return stg_past(j - prev_cum,bnr_voc(rec,chix)) 
							+/ [stg_from_bigstg(bnr_voc(rec,j)): j in [chix + 1..nc]];
	
end stg_past;

procedure stg_till(j,rec);					-- make a string from a the part of a big_string up to j
		
	if dr_load(rec)(type_byte) = string_record then		-- simple string record case

		if j > (sl := sr_length(rec)) then 
			abort("Illegal character index in simple stg_past operation: " + str(j) + ", " + sl);
		end if;
		
		return sr_slice(rec,1,j); 			-- return slice up to j

	end if;
	
							-- get the child containing the first character past j 
	if not (exists chix in [1..nc := num_childr(rec)] | bnr_get_ch_cum(rec,chix) >= j) then 
		abort("Illegal character index in stg_past operation: " + str(j) + ", " + nc);
	end if;
	
	prev_cum := if chix = 1 then 0 else bnr_get_ch_cum(rec,chix - 1) end if;	-- the previous cumulant

	return  ("" +/ [stg_from_bigstg(bnr_voc(rec,j)): j in [1..chix - 1]]) 
												+ stg_till(j - prev_cum,bnr_voc(rec,chix));
	
end stg_till;

procedure bs_slice(rec,i,j);		-- the slice extraction operation concatenates all the characters
									-- between the two indicated positions. the 'node' can be either 
									-- the top of a tree, or can be a simple string_record
				-- for a tree, we locate the sections F, L containing the first and last characters, and
				-- return the concatenation of the part of F past i, the part of L up to j,
				-- and the concatenation of the strings associated with all intermediate child trees
--print("bs_slice: ",i," ",j);	
	if i < 1 or j < i - 1 then 
		abort("Illegal second and/or first parameters in string extraction operation" + str(j) + ", " + str(i));
	end if;
			
	if dr_load(rec)(type_byte) = string_record then		-- simple string record case

		sl := sr_length(rec);
		if j > sl then 				-- get string from record
			print("bs_slice: Illegal character index in simple string extraction operation: " + str(j) + ", " + str(sl)); stop;
		end if;
--print("bs_slice bottom: ",i," ",j," ",sr_slice(rec,i,j));		
		return sr_slice(rec,i,j); 

	end if;

							-- get the child containing the first character past i 
	if not (exists chixi in [1..nc := num_childr(rec)] | bnr_get_ch_cum(rec,chixi) >= i) then 
		abort("Illegal first character index in string extraction operation: " + str(i) + ", " + str(nc));
	end if;
							-- get the child containing the first character past j 
	if not (exists chixj in [1..nc := num_childr(rec)] | bnr_get_ch_cum(rec,chixj) >= j) then 
		abort("Illegal second character index in string extraction operation: " + str(j) + ", " + str(nc));
	end if;
	
	prev_cumi := if chixi = 1 then 0 else bnr_get_ch_cum(rec,chixi - 1) end if;	-- the cumulant previous to i
	prev_cumj := bnr_get_ch_cum(rec,chixj - 1);									-- the cumulant previous to j
	
	if chixi = chixj then 				-- proceed recursively
		return bs_slice(bnr_voc(rec,chixi),i - prev_cumi,j - prev_cumi); 
	end if;

	xxx:=(stg_past(i - prev_cumi,bnr_voc(rec,chixi)) +/[stg_from_bigstg(bnr_voc(rec,k)): k in [chixi + 1..chixj - 1]]) 
					+ stg_till(j - prev_cumj,bnr_voc(rec,chixj));	-- proceed recursively: from, middle, end


	return xxx;
	return (stg_past(i - prev_cumi,bnr_voc(rec,chixi)) +/[stg_from_bigstg(bnr_voc(rec,k)): k in [chixi + 1..chixj - 1]]) 
					+ stg_till(j - prev_cumj,bnr_voc(rec,chixj));	-- proceed recursively: from, middle, end

end bs_slice;

procedure bnr_voc(rec,j);					-- j'th member of vector of children for B_tree_for_bigstring records

	stg := dr_load(rec);					-- load this string
	cjstrt := (j - 1) * 4 + bnr_ch_start; 
	return stg(cjstrt..cjstrt + 3);		-- return child rec
	
end bnr_voc;

procedure bnr_get_ch_cum(rec,j);	-- get the cum value for the j-th child of this node
	
	return int_of_5(dr_load(rec)(bnr_cum_start + (j - 1) * 5..bnr_cum_start + j * 5 - 1));
	
end bnr_get_ch_cum;

procedure chop_up(first,mid,last);		-- chop the concatenation of three strings into a tuple of string records

	-- if all three pieces fit into one, two or three sections, return these. Otherwise join as much as possible of the 
	-- middle into two pieces, and then the reminder of the middle into approximately equal-sized pieces.
	-- first and lat are assumed to be no more than one record size each

	if (total := (nf := #first) + (nm := #mid) + (nl := #last)) <= sr_hi_lim then 		-- put all into one piece
		return [first + mid + last]; 
	end if;

	if total < 2 * sr_hi_lim then		-- two pieces are enough

		center := total/2;		-- half the total
		
		if center <= nf then 
			return [first(1..center), first(center + 1..) + mid + last]; 
		end if;

		if center <= nf + nm then 
			return [first + mid(1..used := center - nf), mid(used + 1..) + last]; 
		end if;

		return [first  + mid + last(1..used := center - nf - nm), last(used + 1..)]; 

	end if;			-- otherwise first + mid cannot fit into one piece
			
	if total <= 3 * sr_hi_lim then 			-- if they fit into 3 pieces, put as much as possible 
												-- of first and mid into one piece, and chop up the remainder
	 	return [first + mid(1..used := sr_hi_lim - nf)] + chop_up("",mid(used + 1..),last);

	end if;			-- otherwise put as much as possible of mid together with first and last, and
					-- cut the reminder of the middle into approximately equal-sized pieces.
	first := first + mid(1..used := sr_hi_lim - nf);
	last := mid((new_end := nm - (sr_hi_lim - nl)) + 1..) + last;
	
	npieces := (rem := new_end - used)/sr_hi_lim;		-- number of full-sized pieces
	psm1 := sr_hi_lim - 1;
	
	if (extra_part := rem mod sr_hi_lim) = 0 then		-- fits into a list of full pieces
	
		return [first] + [mid(j..j + psm1): j in [used + 1,used + sr_hi_lim + 1..new_end - psm1]] + [last];
	
	else												-- there is a bit left over

		start_last_2 := new_end - psm1 - extra_part;			-- starting character of last 2 sections
		mid_last_2 := start_last_2 + (psm1 + extra_part)/2;			-- middle character of last 2 sections
						
											-- use list of all but 1 full piece, plus two smaller pieces.
		return [first] + [mid(j..j + psm1): j in [used + 1,used + sr_hi_lim + 1..new_end - 2 * psm1 - extra_part]]
			 + [mid(start_last_2..mid_last_2),mid(mid_last_2 + 1..new_end)] + [last];
	
	end if;
	
end chop_up;

procedure make_record(stg);		-- creates one record from string

	rec := set_type(dr_new_rec(),string_record); sr_set_slice(rec,1,0,stg);
	return rec;
	
end make_record;

procedure pass_pass(stg); print(stg); pass(stg); end pass_pass;		-- print and pass for debugging

procedure bs_set_slice(rw rec,i,j,stg);		-- the slice assignment operation
--print("bs_set_slice: ",i," ",j," ",#stg," ",abs(dr_load(rec)(type_byte)));
	if i < 1 or j < i - 1 then 
		abort("Illegal second and first parameters in string extraction operation" + str(j) + ", " + str(i));
	end if;
											-- since rec will change, ensure that it has just one copy. 
											-- This will up the refcounts of its children if necessary
	if refcount(int_of_4(rec)) > 1 then						-- must copy
pass("copy");
		stgg := dr_load(rec); new_r := dr_new_rec(); 
		dr_setrecbuf(new_r,stgg);
		dr_dirtify(new_r);
		increfs(new_r,1); incref(rec,-1); rec := new_r;		-- substitute copy for original
	end if;

	if (contents := dr_load(rec))(type_byte) = string_record then		-- simple string record case
			-- in the simple string record case we extract the un-written-over portions of the string, 
			-- and chop up F + stg + L to get a new list of leaves, which are made into a node or a tree.
pass("simple");
--print("simple: ",i," ",j," ",#stg);
		if j > (sl := sr_length(rec)) then 				-- get string from record
			abort("bs_set_slice: Illegal character index in simple string extraction operation: " + str(j) + ", " + str(sl));
		end if;
					-- if F + stg + L fits in just one section, we perform the operation as a string slice assignment,
					-- to avoid string copying where unnecessary 

		if (new_len := (i - 1) + (lstg := #stg) + (sl - j)) <= sr_hi_lim then				-- handle as an optimized case
pass("optimized");
			sr_set_slice(rec,i,j,stg);		-- replace slice
--print("optimized case: ",i," ",j," ",sr_slice(rec,1,sr_length(rec)));			
			return;				-- done with this optimized case
			
		else 						-- we must actually chop up F + stg + L
pass("chop");					
			first := contents(sr_char_start..sr_char_start + i - 2); 	-- till the i-1-th character
			last := contents(sr_char_start + j..sr_char_start + sl - 1);		-- from the j + 1-st character
			pieces_tup := chop_up(first,stg,last);

		end if;
		
		incref(rec,-1);		-- the old form of the record will lose one reference
		
		rec := bnr_make_from_tuple(pieces_tup);		-- convert the list of sections returned into a tree
	
		return;
		
	end if;		-- otherwise we deal with the B-tree case
pass("tree");
	if i > (len_this := bnr_get_cum(rec)) + 1 or j > len_this then 
		abort("Out of range first parameter or second in string assignment operation " + str(j) + ", " + str(i) + " Length is " + str(len_this));
	end if;

	if i = len_this + 1 then		-- we have a simple concatenation operation
		
		if (lstg := #stg) < sr_low_lim then			-- balance or join with last node
		
			[last_node,lcum] := bnr_comp_cum(rec,OM);			-- get the last node, and its string contents
			ln_stg := sr_slice(last_node,1,lln := sr_length(last_node));

			if lln + lstg <= sr_hi_lim then	-- join with last node
pass("concat_join");	
				
				old_last_node := last_node;
				incref(old_last_node,1);			-- must increment to prevent length of referenced node from changing
							-- ********** TOTO: FIX THIS IN YOUR BIG_STRING CODE **********			
				sr_set_slice(last_node,lln + 1,lln,stg);		-- last_node is copied and old_last_node loses a ref
				bnr_set_comp(rec,lcum,last_node);		-- insert the (new) last node; old_last_node loses another ref
				incref(last_node,-1);				-- the variable 'last_node' is now dead

				return;									-- done with this optimized case
			end if;										-- otherwise we will balance
pass("concat_balance");
			old_last_node := last_node;
			incref(old_last_node,1);			-- must increment to prevent length of referenced node from changing
							-- ********** TOTO: FIX THIS IN YOUR BIG_STRING CODE **********			
			[new_ln_stg,stg] := chop_up(ln_stg,stg,"");	-- cut into two string sections
			sr_set_slice(last_node,1,lln,new_ln_stg);
			bnr_set_comp(rec,lcum,last_node);			-- insert the (possibly new) last node
			incref(last_node,-1);						-- the variable 'last_node' is now dead
			bnr_insert(rec,OM,leaf := make_record(stg));	-- insert extra part at the end
			incref(leaf,-1);							-- the variable 'leaf' is now dead
			return;										-- done with this optimized case
			
		end if;
pass("concat_chop");		
		pieces_tup := chop_up("",stg,"");
--print("concatenation: ",pieces_tup);		
		for piece in pieces_tup loop		-- append all these pieces to the existing record
			bnr_insert(rec,OM,leaf := make_record(piece));			-- at the end
			incref(leaf,-1);	-- the variable 'leaf' is now dead
		end loop;		-- note that the first insert may copy rec and decrement its refcount if it is shared;
						-- in this case, ref will correctly be repaced by the new copy 
				
		return;		-- done with this case

	end if;		-- end of the case in which insertion is at the very end
	
		-- otherwise we need to make an insertion into the middle of an existing big_string
	-- we extract the un-written-over portions F and L of the first and last sections affected,
	-- and chop up F + stg + L to get a new list of leaves. These replace the leaves 
	-- of the original tree, running from the first to the last section affected.
							-- get the child containing the first character past i 
	[leafi,cumi] := bnr_comp_cum(rec,i);		-- get the leaf containing the first character past i, and its cumulant 
	[leafj,cumj] := bnr_comp_cum(rec,j);		-- get the leaf containing the first character past j, and its cumulant 
--print("insertion in middle: ",cumi," ",cumj);	
			-- if cumi = cumj, and F + stg + L fits in just one section and does not fall beneath the required minimum 
			-- size, we perform the operation as a string slice assignment, to avoid string copying where unnecessary 

	if cumi = cumj			-- we may be able to work in an existing section
		and (new_len := (lstg := #stg) + (sli := sr_length(leafi)) - (j - i + 1)) <= sr_hi_lim 
			and new_len >= sr_low_lim then
pass("nocon_opt");
		prev_cum := cumi - sli;			-- cumulated length before the i-th (= j-th) leaves
		old_leafi := leafi;
		incref(old_leafi,1);			-- must increment to prevent length of referenced node from changing
							-- ********** TOTO: FIX THIS IN YOUR BIG_STRING CODE **********			

		sr_set_slice(leafi,i - prev_cum,j - prev_cum,stg);
											-- replace slice; leafi is copied, so its old version will lose 1 ref
		bnr_set_comp(rec,i,leafi);			-- reset set the leaf of rec, since it will have changed
											-- the old version now loses another ref
		incref(leafi,-1);					-- the variable leafi is now dead (compensate for extra ref added by set_comp)
		return;								-- done with this optimized case

	end if;
	
	contentsi := dr_load(leafi); sli := sr_length(leafi); irel := i - (cumi - sli);
	first := contentsi(sr_char_start..sr_char_start + irel - 2); 	-- till the i-1-th character
	
	contentsj := dr_load(leafj); slj := sr_length(leafj); jrel := j - (cumj - slj);
	last := contentsj(sr_char_start + jrel..sr_char_start + slj - 1);		-- from the j + 1-st character

	pieces_tup := chop_up(first,stg,last);

	-- now the strings in pieces_tup must be turned into leaves which replace the leaves of the tree,
	-- starting from leafj and ending with leafi. This iteration uses the cumulants and works backwards,
	-- testing for the appearance of leafi. If this is encountered before pieces_tup is exhausted, the 
	-- reminming elements of pieces_tup are inserted at the appropriate position. If pieces_tup
	-- is exhausted before leafi is encountered, the leaves forward from the one replaced up
	-- to and including leafi is deleted.
	
	-- however, the case in which pieces_tup contins just one element may be special, since this may fall below the 
	-- minimum number of characters wanted for a leaf
pass("nocon");
	if #pieces_tup = 1 and #(all := pieces_tup(1)) < sr_low_lim then
			-- we balance or join the short string we have with any left or right neighbor leaf 

		if cumi > sli then		-- there is a left neighbor
pass("nocon_left");
			[left_neighbor,-] := left_pair := bnr_comp_cum(rec,cumi - sli);	-- get the left neighbor and its cumulant
			left_neighbor_stg := sr_slice(left_neighbor,1,sr_length(left_neighbor));
			pieces_tup := chop_up(left_neighbor_stg,all,"");		-- use this as the new pieces_tup
			[leafi,cumi] := left_pair;								-- use left_neighbor as the leafi 
			
		elseif cumj < len_this then 						-- there is a right neighbor
pass("nocon_right");
			[right_neighbor,-] := right_pair := bnr_comp_cum(rec,cumj + 1);	-- get the right neighbor and its cumulant
			right_neighbor_stg := sr_slice(right_neighbor,1,sr_length(right_neighbor));
			pieces_tup := chop_up("",all,right_neighbor_stg);		-- use this as the new pieces_tup
			[leafj,cumj] := right_pair;								-- use left_neighbor as the leafi 
		end if;
		
	end if;		-- after this the treatment is like that of all other cases
	
	cum_now := cumj;						-- the following iteration is governed by the cumulants
	pieces_tup_ix_now := #pieces_tup;		-- start at the end of pieces_tup

	while cum_now >= cumi and pieces_tup_ix_now >= 1 loop
pass("nocon_iter");		
		oll := sr_length(bnr_comp(rec,cum_now));		-- the leaf which will be replaced
		
		bnr_set_comp(rec,cum_now,leaf := make_record(pieces_tup(pieces_tup_ix_now)));
		incref(leaf,-1);	-- the variable 'leaf' is now dead
--print("chopping up: ",#pieces_tup," ",hexify(leaf));			
		pieces_tup_ix_now -:= 1;		-- backwards in pieces_tup
		cum_now -:= oll;			-- backwards in the sequence of leaves
		
	end loop;

	while cum_now >= cumi loop			-- may need to make extra deletions
pass("nocon_del");		
		oll := sr_length(bnr_comp(rec,cum_now));		-- the leaf which will be replaced
		bnr_set_comp(rec,cum_now,OM);
		cum_now -:= oll;			-- backwards in the sequence of leaves
	end loop;
	
	just_past_prev := cum_now + 1;		-- just past the leaf previous to leafi
	
	while pieces_tup_ix_now >= 1 loop		-- may need to make extra insertions
pass("nocon_ins");		
		bnr_insert(rec,just_past_prev,leaf := make_record(pieces_tup(pieces_tup_ix_now)));
		incref(leaf,-1);	-- the variable 'leaf' is now dead
		
		pieces_tup_ix_now -:= 1;		-- backwards in pieces_tup
		
	end loop;
	
	if num_childr(old_rec := rec) = 1 then			-- move from tree to simple string record representation
pass("nocon_to_simp");
		rec := bnr_voc(rec,1); incref(rec,1); incref(old_rec,-1);
				-- the child inherits one reference from its parent, so its refcount does not change
	end if;
--print("tree_dump after: ",str(bnr_dump(rec)));

end bs_set_slice;

procedure bs_length(rec);		-- length of a bigstring = string record length or tree length

	return if dr_load(rec)(type_byte) = string_record then sr_length(rec) else bnr_get_cum(rec) end if;

end bs_length;
	
procedure print_raw(); print(big_ix); end print_raw;			-- raw print for debugging

procedure bs_check_leaves(rec);		-- checks that leaves have required maximum and minimum lengths
	
	if (refcount(int_of_4(rec)) <= 0) then
		print("**** MEMORY ERROR **** node with zero refcount in tree: ",hexify(rec)); return false;
	end if;

	if (contents := dr_load(rec))(type_byte) = string_record then	-- node is a leaf

		if (srl := sr_length(rec)) > sr_hi_lim then 
			print("EXCESSIVE STRING LENGTH DETECTED IN NODE ",hexify(rec)," ",hexify(contents));
			return false;
		end if;
		
		return true;		-- node is ok
	end if;		-- otherwise we proceed recursively
	
	if (bsl := bs_length(rec)) /= (ls := #stg_from_bigstg(rec)) then 
		print("***** Length Discrepancy ***** ",bsl," - ",ls," -> ",hexify(rec)," ",hexify(dr_load(rec))); stop;
	end if; 

	return forall j in [1..num_childr(rec)] | bs_check_leaves_in(bnr_voc(rec,j));

procedure bs_check_leaves_in(rec);		-- inner workhorse
	
	if (refcount(int_of_4(rec)) <= 0) then
		print("**** MEMORY ERROR **** node with zero refcount in subtree: ",hexify(rec)); return false;
	end if;

	if (contents := dr_load(rec))(type_byte) = string_record then	-- node is a leaf

		if (srl := sr_length(rec)) > sr_hi_lim then 
			print("EXCESSIVE STRING LENGTH DETECTED IN LEAF ",hexify(rec)," ",srl," ",hexify(contents));
			return false;
		end if;

		if srl < sr_low_lim then 
			print("INSUFFICIENT STRING LENGTH DETECTED IN LEAF ",hexify(rec)," ",srl," ",hexify(contents));
			return false;
		end if;

		return true;		-- leaf is ok

	end if;		-- otherwise we proceed recursively
	
	if (bsl := bs_length(rec)) /= (ls := #stg_from_bigstg(rec)) then 
		print("***** Length Discrepancy In Leaf***** ",bsl," ",ls); stop;
	end if; 

	return forall j in [1..num_childr(rec)] | bs_check_leaves_in(bnr_voc(rec,j));

end bs_check_leaves_in;

end bs_check_leaves;

end big_string_pak;

class big_string;				-- simple wrapper object for big_string_pak

	var rec;	-- disk record for big_string; this is either as simple string record or a B-tree root record 
				-- (MADE PUBLIC FOR MEMORY USAGE DEBUGGING ONLY)

	procedure create(stg);		-- create a big string from a string
	procedure print_raw(); 			-- raw print for debugging
end big_string;

class body big_string;			-- simple wrapper object for big_string_pak

use setldb,big_string_pak;
	
	procedure create(stg); rec := bs_from_stg(stg); end create;		-- create a big string from a string

	procedure selfstr; return stg_from_bigstg(rec);	end;	-- string form of  a big string

	procedure self(i..j);		-- the slice extraction operation concatenates 
								-- all the characters between the two indicated positions
		return bs_slice(rec,i,j);
	end;
	
	procedure self(i..j) := stg;		-- slice assignment operation

		bs_set_slice(rec,i,j,stg);		-- this can change rec; when the refcount of this object goes to 0, 
										-- rec should be erased
	end;
	
	procedure #self; return bs_length(rec);	end;	-- length of this string
	
	
	procedure print_raw(); print(big_ix); end print_raw;
			-- raw print for debugging
end big_string;

program test_bs;		-- test program for big_string package and its associated class
use setldb,big_string_pak,big_string;
use byteutil,disk_records_pak,db_records,B_tree_for_bigstring,string_utility_pak;
				
var orig := "123456789a123456789b123456789c" + "123456789d123456789e123456789f" + "123456789g123456789h123456789i"
			 + "123456789j123456789k123456789lABCDE";		-- string for tests
var orig2 := "ABCDEFGHIaABCDEFGHIbABCDEFGHIc" + "ABCDEFGHIdABCDEFGHIeABCDEFGHIf" + "ABCDEFGHIg1ABCDEFGHIhABCDEFGHIi"
			 + "ABCDEFGHIjABCDEFGHIkABCDEFGHIzZZZZZ";		-- string for tests

code_pts := bs_code_pts + bnr_code_pts;		-- code points to be traversed

database_file_name := "bs_test_file";		-- set the name of the file to be used

package_tests;					-- test the underlying package
big_string_class_test;			-- test the class version

report_points_passed();			-- get traversal report

procedure check_mem(caption,rec);		-- memory check utility
	incref(rec,-1); print(caption," ",str(if is_tuple(cm := check_memory()) then cm(1) else cm end if));
end check_mem;

procedure package_tests;		-- tests of the underlying package

s2 := stg_from_bigstg(rc := bs_from_stg(s1 := orig)); print("short reconstruction: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 1",rc);
s2 := stg_from_bigstg(rc := bs_from_stg(s1 := orig + orig(1..10))); print("long reconstruction: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 2",rc);
s2 := stg_from_bigstg(rc := bs_from_stg(s1 := 5 * orig + orig(1..10))); print("longer reconstruction: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 3",rc);
s2 := stg_from_bigstg(rc := bs_from_stg(s1 := 5 * orig)); print("longer reconstruction 2: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 4",rc);
s2 := stg_from_bigstg(rc := bs_from_stg(s1 := 2 * orig + orig(1..10))); print("longer reconstruction 3: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 5",rc);

s2 := stg_past(5,rc := bs_from_stg(s1 := orig)); print("end of short reconstruction: ",s1(5..) = s2);
check_mem("memcheck 6",rc);
s2 := stg_past(5,rc := bs_from_stg(s1 := orig + orig(1..10))); print("end of long reconstruction: ",s1(5..) = s2);
check_mem("memcheck 7",rc);
s2 := stg_past(5,rc := bs_from_stg(s1 := 5 * orig + orig(1..10))); print("end of longer reconstruction: ",s1(5..) = s2);
check_mem("memcheck 8",rc);
s2 := stg_past(5,rc := bs_from_stg(s1 := 5 * orig)); print("end of longer reconstruction 2: ",s1(5..) = s2);
check_mem("memcheck 9",rc);
s2 := stg_past(5,rc := bs_from_stg(s1 := 2 * orig + orig(1..10))); print("end of longer reconstruction 3: ",s1(5..) = s2);
check_mem("memcheck 10",rc);

s2 := stg_till(95,rc := bs_from_stg(s1 := orig)); print("start of short reconstruction: ",s1(1..95) = s2);
check_mem("memcheck 11",rc);
s2 := stg_till(130,rc := bs_from_stg(s1 := orig + orig(1..10))); print("start of long reconstruction: ",s1(1..130) = s2);
check_mem("memcheck 12",rc);
s2 := stg_till(630,rc := bs_from_stg(s1 := 5 * orig + orig(1..10))); print("start of longer reconstruction: ",s1(1..630) = s2);
check_mem("memcheck 13",rc);
s2 := stg_till(620,rc := bs_from_stg(s1 := 5 * orig)); print("start of longer reconstruction 2: ",s1(1..620) = s2);
check_mem("memcheck 14",rc);
s2 := stg_till(255,rc := bs_from_stg(s1 := 2 * orig + orig(1..10))); print("start of longer reconstruction 3: ",s1(1..255) = s2);
check_mem("memcheck 15",rc);

s2 := bs_slice(rc := bs_from_stg(s1 := orig),5,95); print("short slice: ",s1(5..95) = s2);
check_mem("memcheck 16",rc);
s2 := bs_slice(rc := bs_from_stg(s1 := orig + orig(1..10)),5,130); print("long slice: ",s1(5..130) = s2);
check_mem("memcheck 17",rc);
s2 := bs_slice(rc := bs_from_stg(s1 := 5 * orig + orig(1..10)),5,630); print("longer slice: ",s1(5..630) = s2);
check_mem("memcheck 18",rc);
s2 := bs_slice(rc := bs_from_stg(s1 := 5 * orig),5,620); print("longer slice 2: ",s1(5..620) = s2);
check_mem("memcheck 19",rc);
s2 := bs_slice(rc := bs_from_stg(s1 := 2 * orig + orig(1..10)),5,255); print("longer slice 3: ",s1(5..255) = s2);
check_mem("memcheck 20",rc);

rc := bs_from_stg(s1 := 4 * orig + orig(1..10)); 
bs_set_slice(rc,3,500,"");	s1(3..500) := "";	-- test slice insertion operation, long form
s2 := stg_from_bigstg(rc); print("long slice shortening insert: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 21",rc);

rc := bs_from_stg(s1 := orig + orig(1..10)); 
bs_set_slice(rc,3,2,"XX");	s1(3..2) := "XX";	-- test slice insertion operation, long form
s2 := stg_from_bigstg(rc); print("long slice insert: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 22",rc);

rc := bs_from_stg(s1 := orig + orig(1..10)); 
bs_set_slice(rc,3,2,3 * orig2);s1(3..2) := 3 * orig2;		-- test slice insertion operation, long form
s2 := stg_from_bigstg(rc); print("long slice long insert: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 23",rc);

rc := bs_from_stg(s1 := orig);
bs_set_slice(rc,1,3,"XX");	s1(1..3) := "XX";	-- test slice assignment operation, short form
s2 := stg_from_bigstg(rc); print("short slice shrink-a-bit: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 24",rc);

rc := bs_from_stg(s1 := orig);
bs_set_slice(rc,1,3,""); s1(1..3) := "";		-- test slice assignment operation, short form
s2 := stg_from_bigstg(rc); print("short slice shrinkage: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 25",rc);

rc := bs_from_stg(s1 := orig);
bs_set_slice(rc,1,3,"YYYYY");	s1(1..3) := "YYYYY";	-- test slice assignment operation, short form
s2 := stg_from_bigstg(rc); print("short slice expand: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 26",rc);

rc := bs_from_stg(s1 := orig);
bs_set_slice(rc,1,0,"ZZZZZ");	s1(1..0) := "ZZZZZ";	-- test slice assignment operation, short form
s2 := stg_from_bigstg(rc); print("short slice insert: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 27",rc);

rc := bs_from_stg(s1 := orig + orig(1..10)); rl := bs_length(rc);
bs_set_slice(rc,rl + 1,rl,"XX"); s1(rl + 1..rl) := "XX";		-- test slice append operation, short form
s2 := stg_from_bigstg(rc); print("long slice append: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 28",rc);

rc := bs_from_stg(s1 := 2 * orig + orig(1..10)); rl := bs_length(rc);
bs_set_slice(rc,rl + 1,rl,"WWWWWWW"); s1(rl + 1..rl) := "WWWWWWW";		-- test slice append operation, long form
s2 := stg_from_bigstg(rc); print("long slice append 2: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 29",rc);

rc := bs_from_stg(s1 := 5 * orig + orig(1..10)); rl := bs_length(rc);
bs_set_slice(rc,rl + 1,rl,"YYYYY"); s1(rl + 1..rl) := "YYYYY";		-- test slice append operation, longer form
s2 := stg_from_bigstg(rc); print("long slice append 3: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 30",rc);

rc := bs_from_stg(s1 := 5 * orig + orig(1..10)); rl := bs_length(rc);
bs_set_slice(rc,rl + 1,rl,3 * orig); s1(rl + 1..rl) := 3 * orig;		-- test slice append operation, longer form
s2 := stg_from_bigstg(rc); print("long slice long append: ",s1 = s2 and bs_check_leaves(rc));
check_mem("memcheck 30A",rc);

-- additional tests of the slice assignment operations, to proble all the special cases
-- in the code, and verify the absence of memory leaks or faulty deallocations

end package_tests;

procedure big_string_class_test;		-- test program for big_string class

the_stg := big_string(s1 := orig);
print("string length and selfstr: ",#the_stg = #s1," ",str(the_stg) = s1);
print("short slice class: ",the_stg(5..95) = s1(5..95) and bs_check_leaves(the_stg.rec));
check_mem("memcheck 31",the_stg.rec);

the_stg := big_string(s1 := orig + orig(1..10));
print("long slice class: ",the_stg(5..130) = s1(5..130) and bs_check_leaves(the_stg.rec));
check_mem("memcheck 32",the_stg.rec);

the_stg := big_string(s1 := 5 * orig + orig(1..10));
print("longer slice class: ",the_stg(5..630) = s1(5..630) and bs_check_leaves(the_stg.rec));
check_mem("memcheck 33",the_stg.rec);

the_stg := big_string(s1 := 5 * orig);
print("longer slice class 2: ",the_stg(5..620) = s1(5..620) and bs_check_leaves(the_stg.rec));
check_mem("memcheck 34",the_stg.rec);

the_stg := big_string(s1 := 2 * orig + orig(1..10));
print("longer slice class 3: ",the_stg(5..255) = s1(5..255) and bs_check_leaves(the_stg.rec));
check_mem("memcheck 35",the_stg.rec);

the_stg := big_string("");
the_stg(1..0) := 5 * "abcde"; print("insert from null: ",str(the_stg) = 5 * "abcde"); 
the_stg(26..25) := 5 * orig; print("tail insert from null: ",
				str(the_stg) = (5 * "abcde" + 5 * orig) and bs_check_leaves(the_stg.rec)); --
check_mem("memcheck 36",the_stg.rec);

the_stg := big_string(ori := ori_copy := 5 * "abcde" + 5 * orig);
--print("the_stg after creation: ",str(the_stg)," --- the_stg: ",the_stg); -- ?????????? SETL PRINT BUG ??????????
--print("the_stg after creation: ",str(the_stg)); -- THIS WORKS OK; PREVIOUS LINE DOES NOT
print("string length, selfstr, length check,selfstr check: ",#the_stg = #ori," ",str(the_stg) = ori);
stg_copy := the_stg; incref(the_stg.rec,1);		-- note that an extra copy has been created

print("slice extraction and original: ",the_stg(1..10) = ori(1..10) and bs_check_leaves(the_stg.rec)); 

print("second slice extraction and original: ",the_stg(10..20) = ori(10..20));
print("slice extraction check: ",the_stg(1..10) = ori(1..10)); 
print("second slice extraction check: ",the_stg(10..20) = ori(10..20));
print("tail slice check: ",the_stg(10..#ori) = ori(10..#ori));

the_stg(1..0) := (extra := "XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX."); ori2 := ori;
ori(1..0) :=  extra;
print("concatenation of 50 characters at start: ",#the_stg," ",str(the_stg) = ori and bs_check_leaves(the_stg.rec)); 

print("the_stg: ",str(the_stg)); print(); print(str(stg_copy));
incref(the_stg.rec,-1);		-- delete the string

	-- we must try long and short pure insertions, long and short impure insertions 
	-- into a single section, and long and short insertions which erase longer 
	-- runs
the_stg := stg_copy; incref(stg_copy.rec,1); ori := ori_copy; ori(1..0) := "XXX";
the_stg(1..0) := "XXX"; print("insertion of 3 characters at start: ",#the_stg," ",str(the_stg) = ori);
		-- pure short insertion case
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(21..20) := "XXX";
the_stg(21..20) := "XXX"; print("insertion of 3 characters after position 20: ",#the_stg," ",str(the_stg) = ori);		-- pure short insertion case
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(10..12) := "XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.";
the_stg(10..12) := "XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX."; 
print("50 Xs replace chars 10 thru 12: ",#the_stg," ",str(the_stg) = ori);
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; 
the_stg(10..400) := "XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.";  ori(10..400) := "XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.XXXX.";
print("50 Xs replace chars 10 thru 400: ",#the_stg," ",str(the_stg) = ori);		--the_stg.print_raw();
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(10..12) := "XXX";
the_stg(10..12) := "XXX"; print("3 Xs replace chars 10 thru 12: ",#the_stg," ",str(the_stg) = ori);
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(150..625) := "XXX";
the_stg(150..625) := "XXX"; print("3 Xs replace chars 150 thru 625: ",#the_stg," ",str(the_stg) = ori);
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(10..400) := "XXX";
the_stg(10..400) := "XXX"; print("3 Xs replace chars 10 thru 40: ",#the_stg," ",str(the_stg) = ori);
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(10..12) := "";
the_stg(10..12) := ""; print("chars 10 thru 12 deleted: ",#the_stg," ",str(the_stg) = ori);		-- pure deletion case
incref(the_stg.rec,-1);		-- delete the string

the_stg := stg_copy;  incref(stg_copy.rec,1); ori := ori_copy; ori(10..400) := "";
the_stg(10..400) := ""; print("chars 10 thru 40 deleted: ",#the_stg," ",str(the_stg) = ori);		-- pure long deletion case
incref(the_stg.rec,-1);			-- delete the string

print("first character deletion test"); ori := ori_copy; 
the_stg1 := stg_copy; incref(stg_copy.rec,1); the_stg1(1..1) := ""; ori(1..1) := ""; print(str(the_stg1) = ori);
the_stg2 := the_stg1; incref(the_stg1.rec,1); the_stg2(1..1) := ""; ori(1..1) := ""; print(str(the_stg2) = ori);
the_stg3 := the_stg2; incref(the_stg2.rec,1); the_stg3(1..1) := ""; ori(1..1) := ""; print(str(the_stg3) = ori);
incref(the_stg3.rec,-1); incref(the_stg2.rec,-1); incref(the_stg1.rec,-1); 
 		-- delete the string copy

check_mem("memcheck 37",stg_copy.rec);		-- final erasure

end big_string_class_test;

end test_bs;
	
--	************** THE MAIN DATABASE CLASS AND ITS AUXILIARY CLASSES **************

	-- Internally, the database 'records' are long string sections, defined 
	-- by their start, end characters [start, the_end]. These are accessed through an index, 
	-- which is a cumulating vector of pairs [record_id, rec_len] with both record_id and cum_len
	-- in increasing order. record_id cumulates using the maximum function, and rec_len by integer addition.
	
	-- Each database has a to_string method which can be applied to each of its 
	-- records, which in turn generates word_list(record); This word list is 
	-- used to insert all the word occurences in the record into a 'word index' 
	-- associated with the database.
	
	-- To find a record in the database given its key, we write  
	-- 		[[key,rec_len],key_ix,cum] := big_ix{key..key_cum}; 
	--		start := cum - rec_len + 1;
		
	-- Insertions of new records into the database are simply 
	--		start := #db_record_string; db_record_string(start + 1..start) := binstr(record); 
	-- where 'record' is the new record, followed by 
	-- 		id_ctr +:= 1; db_index{OM} := [hex_rep(id_ctr),#db_record_string];
	-- and then by insertion of the word occurences in the record
	-- into the word index.
	
	-- To over_write a record within the database string db, we write
	-- db_record_string(start..the_end) := x := binstr(record), followed by
	-- db_index(key_ix) := [key,#x]; and by appropriate revision of the word index.
	
	-- Database deletions are then db_record_string(start..the_end) := "", followed by 
	-- big_ix(key_ix) := OM; and by deletion of the word occurences in the record
	-- from the word index.

package db_iterator_pak;		-- contains_iterator package for the SETL database class

	const 
		simple := 1, union := 2, difference := 3, intersection := 4;
	
	sel iterator_kind(1);			-- can be simple, union, difference, unstarted intersection,
										-- started intersection 
					-- components of simple iterators
	sel occs_tree(2);				-- big tuple containing the record keys referencing the words in the_word_ix
	sel current_occ_ptr(3);			-- pointer to index of current occurence
	sel occs_start(4);				-- first item of occurence list
	sel occs_end(5);				-- last item of occurence list
	
					-- components of compound iterators
	sel L1_child(2),L2_child(3); 	-- sub-iterators if compound iteration
	sel last_L1(4),last_L2(5); 	-- items previously obtained for this cycle of 
										-- compound iteration

	var written_refcount,written_free_list,written_in_use;		-- DEBUGGING QUANTITIES, PALCED HER FOR CONVENIENCE
	
	procedure itr_create(occs_tup,beg,nd);			-- create a simple contains_iterator for a SETL database
	procedure itr_union(iter1,iter2);				-- iterator union
	procedure itr_intersection(iter1,iter2);		-- iterator intersection
	procedure itr_diff(iter1,iter2);				-- iterator difference
	procedure itr_start(tup);						-- begin iterating over records containing word
	procedure itr_next(tup);						-- continue iterating over records containing word
	procedure itr_number(tup);						-- count operator
	procedure itr_arb(tup);							-- arb operator; returns first element
	procedure itr_destroy(tup);						-- destructor routine; eliminates reference to occs_tup

end db_iterator_pak;

package body db_iterator_pak;	-- contains_iterator package for the SETL database class

use setldb,B_tree_for_wdocstring,big_stg_for_wdoc_pak,byteutil,disk_records_pak,db_records;
						-- the underlying record and paging libraries 

procedure itr_create(occs_tup,beg,nd);		-- create a simple contains_iterator for a SETL database
--print("itr_create: ",beg," ",nd);
	tup := [1..3];				-- create the representing tuple. The last 2 components, occs_start and occs_end, are OM
	tup.iterator_kind := simple;
	tup.current_occ_ptr := newat();		-- initial reference is to OM
	tup.occs_tree := occs_tup;			-- retain occurence list identity, and create an extra reference to it
	incref(occs_tup,1);		--  add one reference to occs_tup
	if beg = OM then return tup; end if;		-- return a null iterator
	
			-- search for the desired word. If it is not found, set current_oc = OM;
			-- this will terminate iteration as soon as it begins. Otherwise set ^current_occ_ptr 
			-- to point to the first identifier in the identifiers list following the 
			-- word (or to OM if this list is empty.) Iteration will terminate as soon as
			-- the next word item in the word index is encountered.
			
			-- The word index is maintained as a vector of items word, num_occs, ...
			-- etc. with the number of words as a cumulant
	tup.occs_end := nd;
	^tup.current_occ_ptr := (tup.occs_start := beg) - 1;	-- first item of occurence list
	
--print("created iterator: ",tup);
	return tup;

end itr_create;

procedure itr_destroy(tup);						-- destructor routine; eliminates a reference to occs_tup
	incref(tup.occs_tree,-1);		-- eliminate one reference to occs_tup
	tup.current_occ_ptr := OM;		-- prevent subsequent iteration
end itr_destroy;

procedure itr_union(iter1,iter2);		-- iterator union
										-- last_L1(4),last_L2(5) are initialized to pointer atoms
	new_iter := [OM,OM,OM,newat(),newat()]; 	-- create an uninitialized new iterator
	new_iter.iterator_kind := union;
	new_iter.L1_child := iter1;		-- set the two children
	new_iter.L2_child := iter2;
	
	return new_iter;

end itr_union;

procedure itr_intersection(iter1,iter2);		-- iterator intersection
										-- last_L1(4),last_L2(5) are initialized to pointer atoms
	
	new_iter := [OM,OM,OM,newat(),newat()];			-- create an uninitialized new iterator
	new_iter.iterator_kind := intersection;
	new_iter.L1_child := iter1;		-- set the two children
	new_iter.L2_child := iter2;
	
	return new_iter;

end itr_intersection;

procedure itr_diff(iter1,iter2);		-- iterator difference
										-- last_L1(4),last_L2(5) are initialized to pointer atoms
	
	new_iter := [OM,OM,OM,newat(),newat()];	 	-- create an uninitialized new iterator
	new_iter.iterator_kind := difference;

	new_iter.L1_child := iter1;		-- set the two children
	new_iter.L2_child := iter2;
	
	return new_iter;

end itr_diff;

procedure itr_start(tup);			-- begin iterating over records containing word

	case tup.iterator_kind

	when simple =>		-- restart the iteration if possible

		if tup.occs_start /= OM then ^(tup.current_occ_ptr) := tup.occs_start - 1; end if;

	when union,difference,intersection =>	-- for the compound cases, just set up both values

		itr_start(tup.L1_child); itr_start(tup.L2_child);			-- start both children

		^(tup.last_L1) := itr_next(tup.L1_child);					-- set up both initial values
		^(tup.last_L2) := itr_next(tup.L2_child);
	end case;

end itr_start;

procedure itr_next(tup);			-- continue iterating over records containing word
	
	case tup.iterator_kind

	when simple =>
						-- if uninitialized or terminated, return OM
		if (tcop := tup.current_occ_ptr)  = OM or ^tcop = OM then return OM; end if;

		if (current_ix := (^tcop +:= 1)) > tup.occs_end  then 
			^tcop := OM; return OM;		 -- iteration ends at occs_end
		end if;
			
		return int_of_4(bswo_comp(tup.occs_tree,current_ix));
						-- otherwise return the current record identifier, as an integer

	when union =>	-- for the union, we simply return the smaller of the two 
					-- items, and advance it

		if (las_1 := ^(tup.last_L1)) = OM then
		
			if ^(tup.last_L2) = OM then return OM; end if;		-- iteration is finished
			to_return := ^(tup.last_L2);
			^(tup.last_L2) := itr_next(tup.L2_child);	-- advance the L2 iteration
			return to_return;		-- return the L2 iterator
			
		elseif (las_2 := ^(tup.last_L2)) = OM then

			to_return := ^(tup.last_L1);
			^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the L1 iteration
			return to_return;		-- return the L1 iterator

		elseif las_1 <= las_2 then

			to_return := las_1;		-- return the smaller

			if las_1 = las_2 then ^(tup.last_L2) := itr_next(tup.L2_child); end if;
				-- advance L2 if it equals the L1 being returned
				
			^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the smaller iteration 
			return to_return;		-- return the L1 iterator

		else

			to_return := las_2;		-- return the smaller
			^(tup.last_L2) := itr_next(tup.L2_child);	-- advance the smaller iteration
			return to_return;		-- return the L2 iterator

		end if;
		
	when difference =>	-- for the difference L1 - L2, we return and advance the L1 item if 
						-- it is the smaller of the two; otherwise we advance the L2 item
						-- until it becomes equal to or greater than the L1 item. At each
						-- equality, the L1 item is also increased.
--print("difference iter; last_L1,last_L2: ",^(tup.last_L1)," ",^(tup.last_L2));

		if (las_1 := ^(tup.last_L1)) = OM then return OM; end if;		-- iteration is finished
		
		if (las_2 := ^(tup.last_L2)) = OM or las_1 < las_2 then

			to_return := las_1;		-- return the L1 iterator
			^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the L1 iteration 
			return to_return;		-- return the L1 iterator

		elseif las_1 = las_2 then	-- bypass common element

			^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the L1 iteration 
			
		end if;		-- now last_L1 is larger
		
		while (las_1 := ^(tup.last_L1)) /= OM loop	-- we move forward (in both lists if necessary)
									-- till last_L2 exceeds last_L1

			while (las_2 := ^(tup.last_L2)) /= OM and las_1 > las_2 loop
				^(tup.last_L2) := itr_next(tup.L2_child);
			end loop;

			if las_1 = las_2 then 	-- must advance last_L1 again
				^(tup.last_L1) := itr_next(tup.L1_child);
				continue; 
			end if;	
			
			to_return := las_1;		-- return the L1 iterator
			^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the L1 iteration 
			return to_return;		-- return the L1 iterator

		end loop;

		return OM;		-- iteration is finished

	when intersection =>	-- for the intersection, we advance the smaller of the two 
							-- items until a common value is found, when we advance both

		while (las_1 := ^(tup.last_L1)) /= OM and (las_2 := ^(tup.last_L2)) /= OM loop
			
			if las_1 = las_2 then -- we have an intersection element
			
				to_return := las_1;		-- return the L1 iterator
				^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the L1 iteration 
				return to_return;		-- return the L1 iterator
			
			end if;
			
			if las_1 < las_2 then -- advance the smaller element
				^(tup.last_L1) := itr_next(tup.L1_child);	-- advance the L1 iteration 
			else
				^(tup.last_L2) := itr_next(tup.L2_child);	-- advance the L2 iteration 
			end if;
			
		end loop;

		return OM;		-- iteration is finished

	end case;

end itr_next;

procedure itr_number(tup);		-- count operator

	case tup.iterator_kind

	when simple =>

		if tup.occs_start = OM then return 0; end if;		-- word not found
		
		return tup.occs_end - tup.occs_start + 1;
	
	when union,difference,intersection =>
		-- count occurences matching criterion
		
		num := 0; itr_start(tup);
		while itr_next(tup) /= OM loop num +:= 1; end loop;
		return num;

	end case;

end itr_number;

procedure itr_arb(tup);		-- arb operator; returns first element

--print("itr_arb: ",tup.iterator_kind);	
	case tup.iterator_kind

	when simple =>		-- restart the iteration if necessary

		if (tos := tup.occs_start) = OM then return OM; end if;	
		iof := int_of_4(bswo_comp(tup.occs_tree,tos));
		
		return iof;
				-- otherwise return the first record identifier from the sequence for this word

	when union,difference,intersection =>	-- for the compound cases, just set up both values

		itr_start(tup);			-- begin iterating over records containing word
		item := itr_next(tup);		-- take the first item
		
		return if item = OM then OM else item end if;	-- return the first item
		
	end case;

end itr_arb;

end db_iterator_pak;

class contains_iterator;		-- contains_iterator for the SETL database class
	-- these iterators represent the set of all database records which 
	-- contain a given word. They support iteration and the count operation; 
	-- along with intersection, union, and difference.

procedure create(the_tup);		-- create contains_iterator for a SETL database

end contains_iterator;

class body contains_iterator;		-- contains_iterator for the SETL database class

use setldb,byteutil,disk_records_pak,db_records,db_iterator_pak;		-- for preliminary testing

var tuple;				-- representing quintuple for the iteration

procedure create(the_tup);		-- create contains_iterator for a SETL database
	-- tuple is [iterator_kind = kind,occs_tree,current_occ_ptr = OM,start,end] if simple;
	-- (but [kind,L1_child,L2_child,last_L1,last_L2] if compound)
	
	tuple := if the_tup.iterator_kind = simple then itr_create(the_tup(2),the_tup(4),the_tup(5)) else the_tup end if;
						-- use the package in the simple case; otherwise just save

end create;

procedure #self; return itr_number(tuple); end;				-- count operator; use the package
procedure self + x; return contains_iterator(itr_union(tuple,x.tuple)); end;			-- iterator union
procedure self * x; return contains_iterator(itr_intersection(tuple,x.tuple)); end;		-- iterator intersection
procedure self - x; return contains_iterator(itr_diff(tuple,x.tuple)); end;				-- iterator difference
procedure arb self; return if (res := itr_arb(tuple)) = OM then OM else stg_of_4(res) end if; end;
				-- select an arbitrary record id which references this word or words
				-- Note that itr_arb returns OM  or an integer

procedure iterator_start; itr_start(tuple); end;		-- begin iterating over records containing word
procedure iterator_next; return if (res := itr_next(tuple)) = OM then OM else [stg_of_4(res)] end if; end;
							-- continue iterating over records containing word

end contains_iterator;

-- The operations supported by the SETL database class seen below are as follows:

-- db(key);				-- find a database record given its key
-- db(key) := x;		-- store a database record, associating it with the specified key
-- db with x			-- create a new record and put x into it. db is returned.
-- db.to_string;		-- database-associated mapping of records to strings; see comment below

-- db.contains(wd);		-- creates and returns an iterator object for the given word
	-- iterations 'x in iter_obj' over these objects return the sequence of 
	-- keys of all records containing the specified words. These iteration 
	-- objects support the operations: #iter_obj (number of keys in the iteration group)
	-- arb iter_obj (first item int the iteration group, or OM if none)
	-- iter_obj + iter_obj (union iteration), iter_obj * iter_obj (intersection),
	-- iter_obj - iter_obj (iterate over difference)

class database;		-- SETL database class

var what_tree;				-- tree name for debugging
var to_string := OM;		-- database-associated mapping of records to strings
							-- this public variable should be set just once, immediately after the 
							-- database is created.
var words_just_changed;		-- words affected in last database operation 

var record_string;		-- the big string of all the records
var record_index;		-- maps record identifiers into record ends
	-- this is a big tuple consisting of record identifiers and record lengths, 
	-- with the identifiers in order. The identifiers cumulate as strings, the lengths as integers.
var identifier_generator := 0;		-- cumulating generator for record identifiers
var words_index;
	-- this is a big tuple consisting of pairs [words,len_occ_rec], where len_occ_rec is 
	-- the length (in 'occ_rec_tup', see below) of the list of records which contain the word.
	-- the words are in order
var occ_rec_tup;		-- big tuple, containing lists of word occurences (one for each
						-- record in which a given word occurs. Each such list of words contains
						-- record identifiers in increasing order

procedure create(my_to_string,file_name);		-- create or reopen a SETL database
procedure write_db();							-- write database to its file
procedure contains(wd);
		-- returns the 'contains' iterator object for a given word

procedure dump();					-- dump of database (DEBUGGING ONLY)
procedure check_consistency(caption);		-- miscelaneous consistency checks (DEBUGGING ONLY)
procedure dump_recstring();			-- dump of database record_string (DEBUGGING ONLY)
procedure write_refcount_data();	-- write out the refcount data (PUBLIC FOR DEBUGGING ONLY)
procedure dump2(x);

end database;

class body database;		-- SETL database class

use setldb,string_utility_pak,sort_pak;	-- utilities, e.g. for breaking strings at whitespace, etc.
use contains_iterator;				-- the iterator objects
use byteutil,disk_records_pak,db_records;			-- the underlying record and paging libraries 
use B_tree_for_bigstring,B_tree_for_wdocstring,B_tree_for_dbix,B_tree_for_wdix,big_string_pak,big_stg_for_wdoc_pak;
use db_iterator_pak;
									-- the B_trees representing the principal database components and their indices

var num_refcount_items_in_rec := rec_size/4 - 1;		-- number of refcount items in a record	

procedure create(my_to_string,file_name);		-- create or reopen a SETL database
	-- if file_name starts with a minus sign, we strip of the minus sign and start a new database in the indicated file
	-- otherwise we read the file, which should contain a previously written database, and use its contents to 
	-- initialize the database
	
	may_minus := match(file_name,"-"); 
	database_file_name  := file_name;		-- the global database_file_name is set from file_name 

	if may_minus = "" then		-- read the file and use its contents to initialize the database
		read_db(file_name); 	
		to_string := my_to_string?lambda(rec); return ""; end lambda;
		return;	
	end if;

	-- otherwise the database (and its representing trees) are initially empty.
	
	close(open(file_name,"TEXT-OUT"));   -- delete the file if it already exists; othewise create it

	to_string := my_to_string?lambda(rec); return ""; end lambda;
	-- by default (since a default is required), all records map to the null string
	
	record_string := dr_new_rec();	dr_load(record_string); 		-- we start with an empty string of records
	srgg:=dr_load(record_string);
	srgg(type_byte) := string_record; 
	dr_setrecbuf(record_string,srgg);
	dr_dirtify(record_string);
	
	record_index := dbix_create();		-- we start with an empty index of records; accumulates rec_id and length
						
	occ_rec_tup := dr_new_rec();	
	srgg:=dr_load(occ_rec_tup);
	srgg(type_byte) := wdoccs_string_record; 
	dr_setrecbuf(occ_rec_tup,srgg);
	dr_dirtify(occ_rec_tup);
										-- initially no word has any occurence.
										-- the occurences tuple is a list of record identifiers, divided into sections 
										-- by the cumulative counts held in 'words_index'. Within each such section
										-- the record identifiers are in order; they cumulate as strings and by count

	words_index := wix_create();			-- we start with an empty index of word occurences
		-- the words index has 2 cumulants, namely the words themselves, 
		-- accumulated using 'max', and the total length of the occurence list for each word

end create;

procedure identity_map(x); return x; end identity_map;		-- identity mapping

procedure self(key);		-- find a database record given its key
				-- the database record index call dbix_comp_cum2(rec,x) returns values of the form [rid,len,cum_len]

	--print("Self [record_index,key]=",[record_index,int_of_4(key)]);
	
	if (found := dbix_comp_cum2(record_index,key)) = OM then return OM; end if;  -- item might not be found
	
	[key_in,rec_len,stg_end] := found;

	--print("Self(key)... [key_in,rec_len,stg_end]=",
        --       [int_of_4(key_in),rec_len,stg_end]);
	
	if key_in /= key then return OM; end if;		-- no such key found
	--print(stg_end-rec_len+1," ",stg_end," Rec ",hexify(record_string));
	return unbinstr(bs_slice(record_string,stg_end - rec_len + 1,stg_end));		-- otherwise decode the record
	--return bs_slice(record_string,stg_end - rec_len + 1,stg_end);		-- otherwise decode the record

end;

procedure self(key) := rec;		-- update a database record using its key
	-- if rec = OM we delete the database record with the given key

--	print("Self:= [record_index,key]=",[record_index,int_of_4(key)]);
	[key_in,rec_len,stg_end] := dbix_comp_cum2(record_index,key);
--	print("Self(key):=rec ... [key_in,rec_len,stg_end]=",
--		[int_of_4(key_in),rec_len,stg_end]);
	
	if rec = OM then -- deletion is desired

		if key_in /= key then return; end if;
						-- key not present so no deletion needed

		being_deleted := unbinstr(bs_slice(record_string,strt := stg_end - rec_len + 1,stg_end));	
				-- the record being deleted
		deleted_wds := {wd: wd in breakup(to_string(being_deleted),"\n\t\r ") | wd /= ""};
					-- set of words being deleted
		delete_wds(deleted_wds,key);
				-- delete these word occurences from the words_index

		bs_set_slice(record_string,strt,stg_end,"");
				-- delete the record from the record_string 

		dbix_set_comp2(record_index,key,OM);
				-- delete the record data from the record_index

		words_just_changed := { };		-- we don't count deletions as changes

		return;		-- done with this case
		
	end if;		-- otherwise a record is being changed

	start_m1 := stg_end - rec_len;		-- the record will be written after this position	
	added_wds := {wd: wd in breakup(to_string(rec),"\n\t\r ") | wd /= ""};
					-- set of words being added
	words_just_changed := added_wds;
	
	if key_in /= key then 
						-- key not present, so just insert new record, using key
						-- Note: this operation should be quite rare
			-- get the string start of the record before which the insertion will 
			-- take place
		bs_set_slice(record_string,start_m1 + 1,start_m1,bstr := binstr(rec));
				-- insert the record into the record_string 
		dbix_set_comp2(record_index,key_in,[key,#bstr]);
				-- insert the record data into the record_index, immediately prior to key_in
		add_wds(added_wds,key);	-- add these word occurences to the words_index

		return;		-- done with this case

	end if;
	
		-- otherwise a record is actually being changed. Find the new words being
		-- added, and the old words being subtracted

	old_record := unbinstr(bs_slice(record_string,start_m1 + 1,stg_end));	
				-- the record as it was
	deleted_wds := {wd: wd in breakup(to_string(old_record),"\n\t\r ") | wd /= ""};
					-- set of words being deleted
	new_wds := added_wds - deleted_wds;	-- the new words to be indexed
	add_wds(new_wds,key);	-- add these word occurences to the words_index
--print("new_wds,key,words_index: ",new_wds," ",key," ",words_index);

	deleted_wds -:= added_wds;		-- set of words really being deleted
	delete_wds(deleted_wds,key);
				-- delete these word occurences from the words_index

	bs_set_slice(record_string,start_m1 + 1,stg_end,bstr := binstr(rec));
				-- change the record in the record_string 

	dbix_set_comp2(record_index,key,[key,#bstr]);
				-- change the record data in the record_index	

	words_just_changed := added_wds;

end;

procedure delete_wds(wd_list,key);	-- delete word occurences from the words_index
--if "D_4" in wd_list then 
--	print(what_tree," delete_wds - wd_list,key: ",wd_list," ",hexify(key)," ",wix_dump(words_index)," ",
--				bswo_length(occ_rec_tup)," ",hexify(occ_rec_tup)," ",hexify(stg_from_bswostg(occ_rec_tup))); 
--end if;
	for wd in wd_list loop	-- search over the words in order
						-- find index of 'wd' in the words_index
		
		[-,occs_len,up_limix] := wix_comp_cum2(words_index,wd);		-- get boundaries of word occurences section
		
		[key_in,key_ix] := wo_first_past_to(occ_rec_tup,key,up_limix - occs_len + 1,up_limix);
					-- key_in must be identical with key

		bswo_set_comp(occ_rec_tup,key_ix,OM);		-- delete the key occurence
		
			-- if the last occurence of the word has just been deleted, then delete 
			-- the word itself
		if occs_len = 1 then wix_set_comp2(words_index,wd,OM); continue; end if;
					-- otherwise reduce the number of occurences in the words_index by 1
		wix_set_comp2(words_index,wd,[wd,occs_len - 1]);

	end loop;
--if "D_4" in wd_list then 
--	print(what_tree," at end of delete_wds: ",wix_dump(words_index)," ",bswo_length(occ_rec_tup)," ",
--									hexify(occ_rec_tup)," ",hexify(stg_from_bswostg(occ_rec_tup)));
--end if;
	
end delete_wds;

procedure add_wds(wd_list,key);	-- insert word occurences into the words_index
--print(what_tree," add_wds - wd_list,key: ",wd_list," ",hexify(key)); 

	for wd in wd_list loop	-- search over the words in order
						-- find index of 'wd' in the words_index
--print("adding: ",wd," ",hexify(key));
		if (item:= wix_comp_cum2(words_index,wd)) = OM then	-- wd not bounded; insert it at end
			wix_insert(words_index,OM,[wd,1]);		-- there is just one occurence
--print("not bounded: ",hexify(occ_rec_tup)," ",hexify(stg_from_bswostg(occ_rec_tup)));
			bswo_insert(occ_rec_tup,OM,key);			-- insert the occurence at the end of occ_rec_tup 
			continue; 		-- done with this case
		end if;
		
		[wd_there,occs_len,up_limix]:= item; 
				 -- get wd in position, and boundaries of word occurences section

		if wd_there /= wd then		-- word not present; insert before word found
--print("not present: ",wd_there);
			wix_insert2(words_index,wd_there,[wd,1]);					-- insert: there is just one occurence
			bswo_insert(occ_rec_tup,up_limix - occs_len + 1,key);	-- insert the occurence before all the priors

			continue; 		-- done with this case

		end if;

			-- otherwise the word already occurs in some record; but the new 
			-- occurence must be inserted

		low_limix := up_limix - occs_len + 1;		-- we search for the key in the indicated range
		poss_occ_key_ix := wo_first_past_to(occ_rec_tup,key,low_limix,up_limix);
								
		if poss_occ_key_ix = OM then	-- there is no later occurence on record for this
										-- word, so it should be inserted at the end of
										-- the occurence list section to which it belongs
			bswo_insert(occ_rec_tup,up_limix + 1,key);	-- insert the key occurence at section end
--print("already occurs: ",wd," ",[wd,occs_len + 1]); 
			wix_set_comp2(words_index,wd,[wd,occs_len + 1]);  -- note that there is one additional occurence

			continue;		-- done with this case
		end if;
		
		[-,next_key_ix] := poss_occ_key_ix;

		bswo_insert(occ_rec_tup,next_key_ix,key);	-- insert the key occurence before the following occurence
		wix_set_comp2(words_index,wd,[wd,occs_len + 1]);  -- note that there is one additional occurence

	end loop;
--print(what_tree," at end of add_wds: ",wix_dump(words_index)," ",bswo_length(occ_rec_tup)," ",hexify(occ_rec_tup)," ",hexify(stg_from_bswostg(occ_rec_tup)));
	
end add_wds;

procedure self with rec;		-- add a new record to a database

			-- put the record into the database, and get its new key
	nrs := bs_length(record_string); bs_set_slice(record_string,nrs + 1,nrs,bsr := binstr(rec));

		-- insert the new key at the end of the record index, with its length 
		-- for cumulation

	dbix_insert(record_index,OM,[key := stg_of_4(identifier_generator +:= 1),#bsr]);

		-- now calculate the string of the record and find the set of words
	wd_list := {wd: wd in breakup(to_string(rec),"\n\t\r ") | wd /= ""};

	add_wds(wd_list,key);	-- add these word occurences to the words_index
	
	words_just_changed := wd_list;
	
	return self;	-- return the database itself as the result of this operation
end;

procedure contains(wd);
		-- returns the 'contains' iterator object for a given word
	-- tuple to be supplied is [iterator_kind = kind,occs_tree,current_occ_ptr = OM,start,end] (since simple);
	-- (but [kind,L1_child,L2_child,last_L1,last_L2] if compound)
--print("creating 'contains' iterator: ",wd);

	if (initial_item := wix_comp_cum2(words_index,wd)) = OM or initial_item(1) /= wd then 
				-- the word index call wix_comp_cum2(rec,x) returns values of the form [rid,len,cum_len]
--print("iteration will terminate");
		return contains_iterator([simple,occ_rec_tup]); -- word does not occur, so iteration will terminate
	end if;
	
	[-,occ_section_len,the_occs_end] := initial_item;
--print("iteration tuple  is: ",[simple,occ_rec_tup,OM,the_occs_end - occ_section_len + 1,the_occs_end]);
if the_occs_end > bswo_length(occ_rec_tup) then
	print("CREATING BAD CONTAINS_ITERATOR: ",the_occs_end - occ_section_len + 1," ",the_occs_end," ",
														bswo_length(occ_rec_tup));
	stop;
end if;
	return contains_iterator([simple,occ_rec_tup,OM,the_occs_end - occ_section_len + 1,the_occs_end]);

end contains;

procedure write_db();		-- write database to its file
	-- we only need to flush_all, write the refcount data to the file, and write one additional record
	-- containing (i) the location of the roots of the various database trees; (ii) the value of recno_generator;
	-- (iii) the location of the first record containing the refcount data; since the remainder of the
	-- database is already present in the file
        dr_flush_all();

	--stg := dr_load(rec_one := "\x00\x00\x00\x01");		-- initialize the first record, which contains the needed locator data
        -- Don't load the record!
        -- Instead we pass a string containing the parameters.

        stg:=" "*32;

	stg(1..4) := record_string;						-- bigstring containing records
	stg(5..8) := record_index;						-- index for bigstring containing records
	stg(9..12) := occ_rec_tup;						-- big tuple containing word occurences
	stg(13..16) := words_index;						-- index for big tuple containing word occurences
 	stg(17..21) := stg_of_5(identifier_generator);	-- identifier_generator value; this is 5 bytes

        -- Recno generator is handled internally in the native package
        -- we don't have to save it.

 	--stg(22..25) := stg_of_4(dr_recno_generator());		-- recno_generator value (maximum record used) 

	--refcount_data_start := dr_write_refcount_data();	-- write out the refcount data
	
 	--stg(26..30) := stg_of_4(refcount_data_start);				-- location of the first record containing the refcount data

	
	--dr_load(rec_one);
	--dr_setrecbuf(rec_one,stg);
	--dr_dirtify(rec_one);
 	
	--dr_flush_all();									-- write eveything out
        db_close_db(stg); -- close database
				
end write_db;

procedure read_db(file_name);		-- read database from the indicated file
	-- we only need to reconstruct refcount data, free_list, and in_use data from the file,
	-- and set (i) the location of the roots of the various database trees; (ii) the value of recno_generator;
	-- since the remainder of the database is already present in the file
	print("reading database");
        db_open_db(file_name);
	stg:=db_read_param();

	record_string := stg(1..4);						-- bigstring containing records
	record_index := stg(5..8);						-- index for bigstring containing records
	occ_rec_tup := stg(9..12);						-- big tuple containing word occurences
	words_index := stg(13..16);						-- index for big tuple containing word occurences
 	identifier_generator := int_of_5(stg(17..21));	-- identifier_generator value; this is 5 bytes

	--read_refcount_data(refcount_data_start,recno_generator);	-- reconstruct the refcount data
--print("read_db check: ",written_refcount(2..recno_generator) = refcount(2..recno_generator)," ",written_free_list = free_list," ",written_in_use = in_use);
--print(str(written_refcount)," ",str(refcount));
--print(str([hexify(x) : x in written_free_list])," ",str([hexify(x) : x in free_list]));
--print(str([hexify(x) : x in (written_in_use - in_use)])," ",str([hexify(x) : x in (in_use - written_in_use)]));

end read_db;

procedure write_refcount_data();	-- write out the refcount data
	-- we group the refcount data into a series of 4-byte fields within a chained list of blocs, 
	-- fitting these into free-list elements where possible, but otherwise using new records.
	-- each block contains a pointer to the next block in the chain.
	
	if recno_generator = 1 then return; end if; 		-- no recno data to write
	written_refcount := refcount; written_free_list := free_list; written_in_use := in_use;
	
--print("recno_generator: ",recno_generator," ",#refcount," ",str(refcount)," ",str([hexify(x): x in free_list])," ",str([hexify(x): x in in_use]));
	current_stg := dr_load(current_record := dr_new_rec());		-- allocate a first record to hold refcount data
	ref_data_start := current_record;
	place_in_current_record := 1;

	for j in [1..recno_generator] loop

		if (place_in_current_record +:= 4) > rec_size then		-- must write another record
			-- SPAM dirty with:= current_record;						-- note that current record has ween written
			next_record := current_stg(1..4) := dr_new_rec();		-- allocate another record to hold refcount data
			dr_load(current_record); 								-- prepare to write the next record
			dr_setrecbuf(current_record,current_stg);
			dr_dirtify(current_record);
--print("record to be written: ",hexify(current_record)," ",hexify(current_stg));
			current_stg := dr_load(current_record := next_record); -- start on the new string
			place_in_current_record := 5;						-- restart the write-position index
		end if;
		
		current_stg(place_in_current_record..place_in_current_record + 3) := stg_of_4(refcount(j)?0);
		
	end loop;
	
			dr_setrecbuf(current_record,current_stg);
			dr_dirtify(current_record);
--print("record to be written: ",hexify(current_record)," ",hexify(current_stg));

--print(hexify(current_record)," ",hexify(current_stg));	
	
	return ref_data_start;
	
end write_refcount_data;

procedure read_refcount_data(refcount_data_start,recno_generator);	-- reconstruct the refcount data
	-- we read the refcount data into a series of 4-byte fields withing a chained list of blocs, 
	-- fitting these into free-list elements where possible, but otherwise using new records.
	-- each block contains a pointer to the next block in the chain.
	
	free_list := []; in_use := { };			-- this routine also reconstructs the free_list tuple and in_use set
	
	place_in_current_record := 1;
	rno := int_of_4(refcount_data_start);
	gets(file_handle,(rno - 1) * rec_size + 1,rec_size,current_stg);		-- read the current record
--print("first record read: ",hexify(refcount_data_start)," ",hexify(current_stg));
	next_record := current_stg(1..4);						-- prepare to read the next record
	
	records_containing_refcounts := [refcount_data_start];		-- we need to collect these records, and free them

	--SPAM refcount := [1..recno_generator];			-- allocate a vector; its components will be over-written 
	
	for j in [1..recno_generator] loop

		if (place_in_current_record +:= 4) > rec_size then		-- must read next record
			place_in_current_record := 5; current_record := next_record;
			rno := int_of_4(current_record);
			gets(file_handle,(rno - 1) * rec_size + 1,rec_size,current_stg);		-- read the current record
--print("record read: ",hexify(current_record)," ",hexify(current_stg));
			records_containing_refcounts with:= current_record;		-- we need to collect these records, and free them
			next_record := current_stg(1..4);						-- prepare to read the next record
		end if;
		
		-- SPAM refcount(j) := rcj := int_of_4(current_stg(place_in_current_record..place_in_current_record + 3));
		
		if rcj = 0 then 				-- record belongs to free list
			free_list with:= stg_of_4(j);
		else							-- record is in use
			in_use with:= stg_of_4(j);
		end if;

	end loop;

	for rec in records_containing_refcounts loop		-- we free all these records, and put them on the free list
		spam:=0;
		-- SPAM refcount(int_of_4(rec)) := 0; free_list with:= rec; in_use less:= rec;
	end loop;
	
	free_list := [rc: rc in {rec : rec in  free_list | (ir := int_of_4(rec)) <= recno_generator and ir /= 1}];
	
end read_refcount_data;

procedure dump2(x);
		print("***** Record  ***** ",hexify(x)," ",hexify(dr_load(x))); 
end;

procedure dump();		-- dump of database
		-- we dump the database by iterating over its record index,
		-- and printing each successive record; and also over the words index,
		-- and printing the list of records containing occurences of each word
		
	print(what_tree," DATABASE RECORDS:");
--print("record_string: ",bs_length(record_string)," ",stg_from_bigstg(record_string));	
--print("occ_rec_tup: ",hexify(stg_from_bswostg(occ_rec_tup)));	
	cur_cum := 1;							-- cumulant value of current record
	ril := dbix_get_cum(record_index);		-- final cumulant value for whole records index
	
	bs_check_leaves(record_string);			-- check the record string for consistency

	while cur_cum < ril loop		-- loop over all records

		[rid,rid_len] := dbix_comp_cum(record_index,cur_cum);
		print("record ",int_of_4(rid),": [",cur_cum,"..",cur_cum + rid_len - 1,"] ",
								unbinstr(bs_slice(record_string,cur_cum,cur_cum + rid_len - 1)));
		cur_cum +:= rid_len;			-- advance to the next record

	end loop;
	
	print("INDEXED WORDS AND WORD OCCURENCES:");
	cur_cum := 1;							-- cumulant value of current word
	wil := wix_get_cum(words_index);		-- final cumulant value for whole words index

	while cur_cum <= wil loop		-- loop over all words

		[word,num_occs,word_cum] := wix_comp_cum(words_index,cur_cum);
		word_tup := [int_of_4(bswo_comp(occ_rec_tup,j)): j in [cur_cum..word_cum]];		-- tuple of word occurences
		
		print(word,": (",cur_cum,"..",word_cum," )",word_tup);
		cur_cum := word_cum + 1;
	
	end loop;
	
	print();
	
	return "";
	
end dump;

procedure check_consistency(caption);		-- miscellaneous consistency checks (DEBUGGING ONLY)
	
	if bswo_length(occ_rec_tup) < wix_get_cum(words_index) then
		print(caption," DATABASE INCONSISTENCY: OCCURENCE STRING LENGTH IS LESS THAN TOTAL WORD INDEX CUMULANT ",
										hexify(stg_from_bswostg(occ_rec_tup)),"\n",wix_dump(words_index)); stop;
	end if;
	
end check_consistency;

procedure dump_recstring();		-- dump of database record_string (DEBUGGING ONLY)
	print(bnr_dump(record_string));
end dump_recstring;

end database;

class active_database;		-- 'active' database class, with hibernators

procedure create(my_to_string,my_do_transaction,file_name);		-- create or reopen an active database
procedure write_act();							-- write database to its file
procedure contains(wd);
		-- returns the 'contains' iterator object for a given word
procedure watch(Tid,word_list,transaction_state);
						-- 'watch' routine, which causes a hybernator to sleep, watching a list of words

procedure dump();							-- dump database (DEBUGGING)

end active_database;

class body active_database;		-- 'active' database class, with hibernators
	use setldb,database;			-- use the standard database class; there will be two of these
	use byteutil,disk_records_pak,db_records,db_iterator_pak;	
	use string_utility_pak;
	
	var inner_database,hibernators;		-- the actual database, and the hibernators watching and writing it
	var in_exec_loop := false;			-- flag indicating whether or not we are in the execution loop of 'alert_hibs'
	var line_to_stg,do_transaction; 	-- the two procedural parameters passed to 'create'
	
procedure create(my_to_string,my_do_transaction,file_name);		-- create or reopen an active database
		-- note that the following lines will read and existing database pair unless file_name starts with '-'
	
	line_to_stg := my_to_string; do_transaction := my_do_transaction;		-- save the procedure parameters
	
	inner_database := database(line_to_stg,file_name + ".db");	-- create an empty database, or read
	inner_database.what_tree := "inner";		-- for debugging
	hibernators := database(hiber_to_stg,file_name + ".hib");		-- create an empty hibernators database, or read
	hibernators.what_tree := "hibernators";		-- for debugging

end create;

procedure hiber_to_stg(tup);		-- convert a hibernator's state tuple to an index string 
	-- there are several cases. For 'newborn' hibernators, the tuple is [word_watched_for]  
	-- For 'hibernating' hibernators, the tuple is [word_watched_for,state].
	-- For active hibernators, the tuple is [".",wakeup_wd,state]
	-- For the currently executing hibernator (if any),  the tuple is ["",wakeup_wd,state]
	
	return tup(1);		-- we simply return the first component 

end hiber_to_stg;

procedure write_act();							-- write an active database to its file

	inner_database.write_db(); hibernators.write_db();		-- write both parts
	
end write_act;

procedure dump();							-- dump database (DEBUGGING)
	print("INNER_DATABASE"); inner_database.dump(); print("HIBERNATORS"); hibernators.dump();
end dump;

procedure contains(wd);					-- returns the 'contains' iterator object for a given word

	if is_tuple(wd) then return hibernators.contains(wd); end if;		-- iterate over the hibernators

	return inner_database.contains(wd);	-- iterate over the inner database

end contains;

procedure self(key);		-- find a database record or hibernator record given its key

	if is_tuple(key) then return hibernators(key(1)); end if;		-- reference the hibernators

	return inner_database(key);	-- get it from the inner database

end;

procedure self(key) := rec;		-- update a database record or hybernator record using its key
--print("assigning record: ",hexify(key)," ",rec);
	if is_tuple(key) then			-- assignment to the hibernators
		hibernators(key(1)) := rec; hibernators.check_consistency("hibernators"); return self; 
	end if;
			

	inner_database(key) := rec;				-- write the inner database
	inner_database.check_consistency("inner_database");
	alert_hibs();							-- alert the hibernators, which may modify the inner database

end;

procedure self with rec;		-- add a new record or hybernator to a database
		-- for external use, we encode additons to the hibernators by wrapping them into singleton sets
--print("new record: ",rec);
	if is_set(rec) and #rec = 1 then 		-- addition to the hibernators
		hibernators with:= arb(rec); hibernators.check_consistency("hibernators"); return self; 
	end if;

	inner_database with:= rec;				-- write the inner database
	inner_database.check_consistency("inner_database");
--print("after insertion of new record: "); inner_database.dump();
	alert_hibs();							-- alert the hibernators, which may modify the inner database

	return self; 
	
end;

procedure alert_hibs();		-- alert the hibernators, which may modify the inner database
	
	words_alerted := inner_database.words_just_changed;		-- words affected by the last operation
	
	for wd in words_alerted loop			-- alert all hibernators watching this word
		for hib in hibernators.contains(wd) loop
			hibernators(hib) := [".",wd,hibernators(hib)(2)];		-- those hibernating have '.' as first component
						-- save only the alerting word and the state, not the list of words being watched
		end loop;
	end loop;
	
	if in_exec_loop then return; end if;		-- to eliminate useless recursion

	in_exec_loop := true;		-- set the execution loop flag
	
	while (first_active := arb(hibernators.contains("."))) /= OM loop
					-- hibernators potentially active have '.' as first component

		hibernators(first_active) := [""] + hibernators(first_active)(2..);
				-- the hibernator which is executing has "" as first component, so is not sensitive to any word change 
				-- i.e. now hibernators(first_active) is ["",wd,transaction_state]
--print("activating: ",hexify(first_active)," ",hibernators(first_active)," ",hibernators.dump()); 
		
--		incref(old_inner_database := inner_database,1); incref(old_hibernators := hibernators,1);
																			-- note two more references
		modified_db := do_transaction(first_active,self);
					-- and call the transaction (cautiously); this will modify a copy of the database,
					-- but not the hibernators

		inner_database := modified_db.inner_database; hibernators := modified_db.hibernators; 
			-- copy the components of the modified database
--		incref(old_inner_database,-1); incref(old_hibernators,-1);			-- drop these two references
		
	end loop;

	in_exec_loop := false;		-- drop the execution loop flag

end alert_hibs;

procedure watch(Tid,word_list,transaction_state);		-- 'watch' routine, which causes a hybernator to sleep,
														-- watching a list of words
	-- As the Tid of a transaction (i.e. hibernator), it is best to use its record id.

		-- When the transaction is active but not running, its record is [".",transaction_state],
		-- and it is simply indexed by ".". When it is hibernating, and watching the words of word_list,
		-- it is indexed by all the words in word_list. To find all the transactions hibernating on the word wd,
		-- we examine the iterators 
	
		--					rid in in hibernators.contains(wd)
		
		--  and execute
		
		--	for rid in in hibernators.contains(wd) loop db(rid) := [".",[wd],hibernators(hib)(2)] end loop;
		
		-- which makes the transaction potentially active.
		-- To establish a 'watch', we simply execute
--print("watch: ",hexify(Tid)," ",word_list," ",transaction_state);	
	hibernators(Tid) := [word_list(1),transaction_state];		-- this drops the hibernator from active state
				-- a hibernator which is watching has the (unique) word for which it is watching as its first component
				
	return self;		-- return the database as it now is
	
end watch;

end active_database;

program test;		-- test program for SETL database class

	use database;		-- use the SETL database class
	use string_utility_pak;		

	db := database(pair_to_stg,"-disk_record_file");		-- create an empty database, to store test pairs

	db with:= ["Jack",68];	--print("first pair added\n",db.dump());		-- add a first pair
	db with:= ["Diana",41];	--print("second pair added\n",db.dump());		-- add a second pair
	db with:= ["Rachel",41]; --print("third pair added\n",db.dump());	-- add a third pair
	
	print("database with 3 records",db.dump());
	
	print("testing arb: list a record containing 'Jack': ",db(jack_key := arb(db.contains("N:Jack"))));
	print("testing arb: list a record containing 'Diana': ",db(arb(db.contains("N:Diana"))));
	print("testing arb: list a record containing 'A:68': ",db(arb(db.contains("A:68"))));
	print("testing arb: list a record containing 'A:41': ",db(arb(db.contains("A:41"))));
	print("testing arb: count records containing 'A:41': ",#db.contains("A:41"));

	print("testing change of record, set ['Jack',68] to ['Jack',69]");
	db(jack_key) := ["Jack",69];	-- another year gone by
	print(db.dump());
	print("testing arb after change: list a record containing 'N:Jack': ",db(arb(db.contains("N:Jack"))));
	print("testing arb after change: list a record containing 'A:68': ",a_rec := arb(db.contains("A:68"))," ",
		if a_rec /= OM then db(a_rec) else "Non-existent ****" end if);
	print("testing arb after change: list a record containing 'A:69': ",db(arb(db.contains("A:69"))));
	print("testing arb after change: list a record containing 'A:41': ",a_rec := arb(db.contains("A:41"))," ",if a_rec /= OM then db(a_rec) 
			else "Non-existent ****" end if);
	print("testing arb after change: list a record containing 'N:Diana': ",db(arb(db.contains("N:Diana"))));

			-- now start testing the basic iterators
	print("testing the basic iterators: list record keys containing 'Jack'");
	for key in (jack_recs := db.contains("N:Jack")) loop print(hexify(key)); end loop;
	print("testing the basic iterators2: list records containing 'Jack'");
	for key in (jack_recs := db.contains("N:Jack")) loop print(db(key)); end loop;
	print("testing the basic iterators3: list records containing 'Diana'");
	for key in (jack_recs := db.contains("N:Diana")) loop print(db(key)); end loop;
	print("testing the basic iterators4: list records containing '41'");
	for key in (jack_recs := db.contains("A:41")) loop print(db(key)); end loop;

	print("\n****** Union test - records containing 'Jack' or 'Diana' ******");

	for key in (jd_recs := (db.contains("N:Jack") + db.contains("N:Diana"))) loop 
	 	print(hexify(key)," ",db(key));
	end loop;

	print("\n****** Union test - records containing 'Rachel' or 'Diana' ******");

	for key in (jd_recs := (db.contains("N:Rachel") + db.contains("N:Diana"))) loop 
	 	print(hexify(key)," ",db(key));
	end loop;

	print("testing arb for union: list a record containing 'Jack' or 'Diana': ",key := arb jd_recs," ",db(key));

	print("\n****** Intersection test - records containing '41' and 'Diana' ******");

	for key in (jd_recs := (db.contains("A:41") * db.contains("N:Diana"))) loop 
	 	print(hexify(key)," ",db(key));
	end loop;

	print("\n****** Intersection test - records containing '41' and 'Rachel' ******");

	for key in (jd_recs := (db.contains("A:41") * db.contains("N:Rachel"))) loop 
	 	print(hexify(key)," ",db(key));
	end loop;

	print("testing arb for Intersection: list a record containing '41' and 'Rachel': ",key := arb jd_recs," ",db(key));

	print("\n****** Difference test - records containing '41' andnot  'Diana' ******");

	for key in (jd_recs := (db.contains("A:41") - db.contains("N:Diana"))) loop 
	 	print(hexify(key)," ",db(key));
	end loop;

	print("\n****** Difference test - records containing '41' andnot  'Rachel' ******");

	for key in (jd_recs := (db.contains("A:41") - db.contains("N:Rachel"))) loop 
	 	print(hexify(key)," ",db(key));
	end loop;
	
	db with:= ["Jack", 6];				-- add a younger jack
	
	print("testing the basic iterators5: list records containing '6'");
	for key in (jack_recs := db.contains("A:6")) loop print(db(key)); end loop;
	
	print("****** Print all records containing 'Jack' ******");
	for key in (jack_recs := db.contains("N:Jack")) loop print(db(key)); end loop;
	print("recs with Jack and '69': ",hexify(jack_rec69 := arb(db.contains("N:Jack") * db.contains("A:69"))));
	if jack_rec69 /= OM then print(db(jack_rec69)); end if;

	print("recs with Jack and '6': ",hexify(jack_rec6 := arb(db.contains("N:Jack") * db.contains("A:6"))));
	if jack_rec6 /= OM then print(db(jack_rec6)); end if;

	print("\n****** Difference test ******");
	print("recs with Jack but not '6'");
	for x in (jnd_recs := db.contains("N:Jack") - db.contains("A:6")) loop
		print(db(x)); 
	end loop;

	print("\n****** Intersection test ******");
	print("recs with Jack and '6'");
	for x in (jnd_recs := db.contains("N:Jack") * db.contains("A:6")) loop
		print(db(x)); 
	end loop;

	print("\n****** Deleting a record -- the 'Jack' with A:69 ******");
	jack_rec69 := jack_key := arb(db.contains("N:Jack") * db.contains("A:69")); db(jack_rec69) := OM;
	print(db.dump());
	
	print("remaining recs with Jack");
	for x in (jack_recs := db.contains("N:Jack")) loop print(db(x)); end loop;

	print("\n****** Restoration Test - Restoring ['Jack',68]; plus Difference Test ******");

	db with:= ["Jack",68];		-- the other Jack again
	print(db.dump()); print("Records with 'Jack' but not 'Diana'");
	for x in (jnd_recs := db.contains("N:Jack") - db.contains("N:Diana")) loop
		print(db(x)); 
	end loop;

	print("\n****** Deleting another record -- the 'Jack' with A:6 ******");
	print("Record identifier is: ",hexify(lit_jack_rec := arb(db.contains("N:Jack") * db.contains("A:6")))); 
	print("Deleting ",db(lit_jack_rec));
	db(lit_jack_rec) := OM;
	print(db.dump()); print("Records with 'Jack'");
	for x in (jack_recs := db.contains("N:Jack")) loop print(db(x)); end loop;

	for j in [1..20] loop 
		db with:= ["Jack",j]; db with:= ["Diana",j]; db with:= ["Rachel",j];
	end loop;
	print("pairs added\n",db.dump());

	print("records with 'A:3'");
	print(str([db(x): x in (jnd_recs := db.contains("A:3"))])); 
	print("records with 'N:Diana'");
	print(str([db(x): x in (jnd_recs := db.contains("N:Diana"))])); 
	print("records with 'A:3' but not 'N:Diana'");
	print(str([db(x): x in (jnd_recs := db.contains("A:3") - db.contains("N:Diana"))])); 
	print("records with 'N:Diana' but not 'A:3'");
	print(str([db(x): x in (jnd_recs := db.contains("N:Diana") - db.contains("A:3"))])); 
	print("records with 'N:Diana' and 'A:3'");
	print(str([db(x): x in (jnd_recs := db.contains("N:Diana") * db.contains("A:3"))])); 
	print("records with 'N:Diana' or 'A:3'");
	print(str([db(x): x in (jnd_recs := db.contains("N:Diana") + db.contains("A:3"))])); 

	print("\n Memory Leak Tests"); 
print("TO BE ADDED"); 

	print("\n Database Copy Tests"); 
print("TO BE ADDED"); 
	
	print("\n ***********END OF TESTS ***********"); 
	db.write_db();
stop;
	
	procedure pair_to_stg(p);	-- convert name, age pair to string

		[nm,age] := p; return " N:" + nm + " A:" + str(age);

	end pair_to_stg;

end test;
		
	-- Distributed versions of the proposed databases can be organized as sets of records
	-- maintained independently on multiple computers, each of which stores a section 
	-- of the big_string representing the database, and an index to the words 
	-- in this section of the big_string. parallel searches over these 
	-- separate sections generate sets, mustly null, which are combined into 
	-- larger sets. The search can be optimized by storing hints of the form
	-- wd:* on the processors which distribute the queries. If no word of this 
	-- form is present on a processor P when a search for a string starting in this way is 
	-- being distributed, P need not receive a copy of the query.

	
	-- if the free_list is empty when a section is requested, a 'space exhausted' 
	-- abort results.
	
program test2;		-- test program for SETL database class

	use database;		-- use the SETL database class
	use string_utility_pak;		

	db := database(pair_to_stg,"-disk_record_file");		-- create an empty database, to store test pairs

	db with:= ["King",212,"5001317"];
	db with:= ["Queen",718,"2681702"];
	db with:= ["Slave",212,"9983470"];
	
	print("database with 3 records",db.dump());
	stop;
	
stop;
	
	procedure pair_to_stg(p);	-- convert name, age pair to string

		[nm,ac,ph] := p; 
	return " N_" + nm + " AC_" + str(ac)+" P_"+ph;

	end pair_to_stg;

end test2;
« October 2024 »
Su Mo Tu We Th Fr Sa
1 2 3 4 5
6 7 8 9 10 11 12
13 14 15 16 17 18 19
20 21 22 23 24 25 26
27 28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: