🚀 go-pugleaf

In article, vixie@decwrl.dec.com (Paul A Vixie) writes:

> There are some B-tree routines in Wirth's "Algorythms and Data Structures"
> (second version, source code in M2 rather than P).  I converted them to C
> and posted them to comp.sources.unix a few years back, but the originals
> are still in the book :-)..

Yeah, I adapted Wirth's B-Tree routines from the 2nd edition.  His original
ones are reprinted below without permission (it helps if you buy/borrow a
copy of his book so you can follow what is going on as his variable names
are a little cryptic).

The Tab character size should be 4, so you will need to replace the tab
characters with 4 spaces below.

Create a file of integers, if an integer is -ve, then the code below will
try and delete the integer from the tree.  If the integer is +ve then
the code will insert the integer in the tree, if it's already in the tree
then it will INC(record.count).

pat  --  cs200cap@st1.vuw.ac.nz
---



MODULE BTree;
(* B-tree procedures by Niklaus Wirth *)

FROM InOut IMPORT	OpenInput, OpenOutput, CloseInput, CloseOutput, ReadInt,
					Done, WriteInt, WriteString, WriteLn, Write;

FROM Storage IMPORT ALLOCATE;

CONST n=9;  (* Order of b-tree *)

TYPE PPtr=POINTER TO Page;

Item=	RECORD
		  key	: INTEGER;
		  p		: PPtr;
		  count	: CARDINAL;
		END;

Page=	RECORD
		  m		: [0..2*n]; (* no. of items on page *)
		  p0	: PPtr;
		  e		: ARRAY[1..2*n] OF Item;
		END;
		
VAR root,q	: PPtr;
	x		: INTEGER;
	h		: BOOLEAN;
	u		: Item;
	

PROCEDURE search(x : INTEGER; a : PPtr; VAR h : BOOLEAN; VAR v :Item);
(* Search key x in B-tree with root a; if found, increment counter.
   Otherwise insert new item with key x.  If an item is passed up,
   assign it to v.  h = "tree has become higher" *)

	VAR i, L, R	: CARDINAL;
		b		: PPtr;
		u		: Item;
		
	BEGIN (* ~h *)
		IF a=NIL
		THEN
			h:=TRUE; (* not in tree *)
			WITH v DO
				key:=x;
				count:=1;
				p:=NIL;
			END; (* of WITH *)
		ELSE
			WITH a^ DO
				L:=1;
				R:=m+1; (* binary search *)
				WHILE L<R DO
					i:=(L+R) DIV 2;
					IF e[i].key<=x
					THEN
						L:=i+1;
					ELSE
						R:=i;
					END; (* of IF *)
				END; (* of WHILE *)
				R:=R-1;
				IF (R>0) & (e[R].key=x)
				THEN
					INC(e[R].count)
				ELSE (* item not on this page *)
					IF R=0
					THEN
						search(x,p0,h,u);
					ELSE
						search(x,e[R].p,h,u)
					END; (* IF *)
					IF h
					THEN (* insert u to the right of e[R] *)
						IF m<2*n
						THEN
							h:=FALSE;
							m:=m+1;
							FOR i:=m TO R+2 BY -1 DO
								e[i]:=e[i-1] END;
							e[R+1]:=u
						ELSE ALLOCATE(b, SIZE(Page)); (* overflow *)
						 (* split a into a,b and assign the middle item to v *)
						 IF R<=n
						 THEN
						 	IF R=n
						 	THEN
						 		v:=u
						 	ELSE
						 		v:=e[n];
						 		FOR i:=n TO R+2 BY -1 DO e[i]:=e[i-1] END;
						 		e[R+1]:=u
						 	END;
						 	FOR i:=1 TO n DO b^.e[i]:=a^.e[i+n] END
						 ELSE (* insert in riMODULE BTree;
(* B-tree procedures by Niklaus Wirth *)

FROM InOut IMPORT	OpenInpu	b^.e[i]:=a^.e[i+n+1]
						 	END; (* of FOR *)
						 	b^.e[R]:=u;
						 	FOR i:=R+1 TO n DO
						 		b^.e[i]:=a^.e[i+n]
						 	END; (* of for *)
						 END; (* of IF *)
						 m:=n;
						 b^.m:=n;
						 b^.p0:=v.p;
						 v.p:=b;
						END;
					END;
				END;
			END;
		END;
	END search;

PROCEDURE underflow(c, a:PPtr; s:CARDINAL; VAR h: BOOLEAN);
(*	a=underflowing page, c=ancestor page,
	s=index of deleted item in c, h:= *)
	
	VAR b:PPtr;
	VAR i,k,mb,mc: CARDINAL;
	
	BEGIN
		mc:=c^.m; (* h, a^.m=n-1 *)
		IF s<mc
		THEN
			(* b:=page to the right of a *)
			s:=s+1;
			b:=c^.e[s].p;
			mb:=b^.m;
			k:=(mb-n+1) DIV 2;
			(* k=no. of items available on page b *)
			a^.e[n]:=c^.e[s];
			a^.e[n].p:=b^.p0;
			IF k>0
			THEN
				(* move k items from b to a *)
				FOR i:=1 TO k-1 DO
					a^.e[i+n]:=b^.e[i]
					END;
				c^.e[s]:=b^.e[k];
				c^.e[s].p:=b;
				b^.p0:=b^.e[k].p;
				mb:=mb-k;
				FOR i:=1 TO mb DO
					b^.e[i]:=b^.e[i+k]
					END;
				b^.m:=mb;
				a^.m:=n-1+k;
				h:=FALSE
			ELSE (* merge pages a and b *)
				FOR i:=1 TO n DO
					a^.e[i+n]:=b^.e[i]
					END;
				FOR i:=s TO mc-1 DO
					c^.e[i]:=c^.e[i+1]
					END;
				a^.m:=2*n;
				c^.m:=mc-1;
				h:=mc<=n;
				(* Deallocate(b) *)
			END;
		ELSE (* b:= page to the left of a *)
			IF s=1
			THEN
				b:=c^.p0
			ELSE
				b:=c^.e[s-1].p
				END;
			mb:=b^.m+1;
			k:=(mb-n) DIV 2;
			IF k>0
			THEN
				(* move k items for page b to a *)
				FOR i:=n-1 TO 1 BY -1 DO
					a^.e[i+k]:=a^.e[i]
					END;
				a^.e[k]:=c^.e[s];
				a^.e[k].p:=a^.p0;
				mb:=mb-k;
				FOR i:=k-1 TO 1 BY -1 DO
					a^.e[i]:=b^.e[i+mb]
					END;
				a^.p0:=b^.e[mb].p;
				c^.e[s]:=b^.e[mb];
				c^.e[s].p:=a;
				b^.m:=mb-1;
				a^.m:=n-1+k;
				h:=FALSE
			ELSE
				(* merge pages a and b *)
				b^.e[mb]:=c^.e[s];
				b^.e[mb].p:=a^.p0;
				FOR i:=1 TO n-1 DO
					b^.e[i+mb]:=a^.e[i]
					END;
				b^.m:=2*n;
				c^.m:=mc-1;
				h:=mc<=n;
				(* Deallocate(a) *)
			END
		END
	END underflow;

PROCEDU	b^.e[i]:=a^.e[i+n+1]
						 	END; (* of FOR *)
						 	b^.e[R]:=u;
						 	FOR i: a; if a page underflow arises,
   balance with adjacent page or merge; h:= "page a is undersize" *)
   
   VAR i,L,R: CARDINAL;
   	q		: PPtr;
   	
   	PROCEDURE del(P:PPtr; VAR h:BOOLEAN);
   		VAR q:PPtr; (* global a,R *)
   		
   		BEGIN
   			WITH P^ DO
   				q:=e[m].p;
   				IF q # NIL
   				THEN
   					del(q,h);
   					IF h
   					THEN
   						underflow(P,q,m,h)
   					END
   				ELSE
   					P^.e[m].p:=a^.e[R].p;
   					a^.e[R]:=P^.e[m];
   					m:=m-1;
   					h:=m<n
   				END
   			END
   		END del;
   
   	BEGIN
   		IF a=NIL
   		THEN (* x not in tree *)
   			h:=FALSE;
   		ELSE
   			WITH a^ DO
   				L:=1;
   				R:=m+1; (* binary search *)
   				WHILE L<R DO
   					i:=(L+R) DIV 2;
   					IF e[i].key<x
   					THEN
   						L:=i+1;
   					ELSE
   						R:=i
   					END (* of IF *)
   				END; (* of WHILE *)
   				IF R=1
   				THEN
   					q:=p0
   				ELSE
   					q:=e[R-1].p
   				END; (* of IF *)
   				IF (R<=m) & (e[R].key=x)
   				THEN
   					(* found, now delete *)
   					IF q=NIL
   					THEN
   						(* a is a terminal page *)
   						m:=m-1;
   						h:=m<n;
   						FOR i:=R TO m DO
   							e[i]:=e[i+1]
   						END
   					ELSE
   						del(q,h);
   						IF h
   						THEN
   							underflow(a, q, R-1, h)
   						END
   					END
   				ELSE
   					delete(x, q, h);
   					IF h
   					THEN
   						underflow(a, q, R-1, h)
   					END
   				END
   			END
   		END
	END delete;
	
PROCEDURE PrintTree(p: PPtr; level: CARDINAL);
	VAR i: CARDINAL;
	
	BEGIN
		IF p#NIL
		THEN
			FOR i:=1 TO level DO WriteString("****") END;
			FOR i:=1 TO p^.m DO WriteInt(p^.e[i].key, 4) END;
			WriteLn;
			PrintTree(p^.p0, level+1);
			FOR i:=1 TO p^.m DO
				PrintTree(p^.e[i].p, level+1)
			END
		END
	END PrintTree;
	
BEGIN (* main program *)
	OpenInput("TXT");
	OpenOutput("TREE");
	root:=NIL;
	Write(">");
	ReadInt(x);
	WHILE Done DO
		WriteInt(x,5);
		WriteLn;
		IF x>=0
		THEN
			search(x, root, h, u); a; if a page underflow arises,
   balance with adjacent page or merge; h:= "page ZE(Page));
				WITH root^ DO
					m:=1;
					p0:=q;
					e[1]:=u
				END
			END
		ELSE
			delete(-x, root, h);
			IF h
			THEN
				(* base page size reduced *)
				IF root^.m=0
				THEN
					q:=root;
					root:=q^.p0; (* deallocate(q) *)
				END
			END
		END;
		PrintTree(root, 0);
		WriteLn;
		Write(">");
		ReadInt(x)
	END;
	CloseInput;
	CloseOutput
END BTree.