home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fresh Fish 10
/
Fresh_Fish_10_2352.bin
/
new
/
dev
/
obero
/
oberon
/
projectoberonsrc
/
btree.mod
(
.txt
)
< prev
next >
Wrap
Oberon Text
|
1994-10-18
|
7KB
|
195 lines
Syntax10.Scn.Fnt
MODULE BTree;
IMPORT Texts, Oberon;
CONST N = 3;
TYPE Page = POINTER TO PageRec;
Entry = RECORD
key, count: INTEGER;
p: Page
END ;
PageRec = RECORD
m: INTEGER; (*no. of entries on page*)
p0: Page;
e: ARRAY 2*N OF Entry
END ;
VAR root: Page;
W: Texts.Writer;
PROCEDURE search(x: INTEGER; a: Page; VAR cnt: INTEGER);
VAR i, L, R: INTEGER;
BEGIN (*a # NIL*)
LOOP L := 0; R := a.m; (*binary search*)
WHILE L < R DO
i := (L+R) DIV 2;
IF x <= a.e[i].key THEN R := i ELSE L := i+1 END
END ;
IF (R < a.m) & (a.e[R].key = x) THEN (*found*)
INC(a.e[R].count); cnt := a.e[R].count; EXIT
END ;
IF R = 0 THEN a := a.p0 ELSE a := a.e[R-1].p END ;
IF a = NIL THEN (*not found*) cnt := 0; EXIT END
END search;
PROCEDURE insert(x: INTEGER; a: Page; VAR h: BOOLEAN; VAR v: Entry);
(*a # NIL. Search key x in B-tree with root a; if found, increment counter.
Otherwise insert new item with key x. If an entry is to be passed up,
assign it to v. h := "tree has become higher"*)
VAR i, L, R: INTEGER;
b: Page; u: Entry;
BEGIN (*a # NIL & ~h*)
L := 0; R := a.m; (*binary search*)
WHILE L < R DO
i := (L+R) DIV 2;
IF x <= a.e[i].key THEN R := i ELSE L := i+1 END
END ;
IF (R < a.m) & (a.e[R].key = x) THEN (*found*) INC(a.e[R].count)
ELSE (*item not on this page*)
IF R = 0 THEN b := a.p0 ELSE b := a.e[R-1].p END ;
IF b = NIL THEN (*not in tree, insert*)
u.count := 0; u.p := NIL; h := TRUE; u.key := x
ELSE insert(x, b, h, u)
END ;
IF h THEN (*insert u to the left of a.e[R]*)
IF a.m < 2*N THEN
h := FALSE; i := a.m;
WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ;
a.e[R] := u; INC(a.m)
ELSE NEW(b); (*overflow; split a into a,b and assign the middle entry to v*)
IF R < N THEN (*insert in left page a*)
i := N-1; v := a.e[i];
WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ;
a.e[R] := u; i := 0;
WHILE i < N DO b.e[i] := a.e[i+N]; INC(i) END
ELSE (*insert in right page b*)
DEC(R, N); i := 0;
IF R = 0 THEN v := u
ELSE v := a.e[N];
WHILE i < R-1 DO b.e[i] := a.e[i+N+1]; INC(i) END ;
b.e[i] := u; INC(i)
END ;
WHILE i < N DO b.e[i] := a.e[i+N]; INC(i) END
END ;
a.m := N; b.m := N; b.p0 := v.p; v.p := b
END
END
END insert;
PROCEDURE underflow(c, a: Page; s: INTEGER; VAR h: BOOLEAN);
(*a = underflowing page, c = ancestor page,
s = index of deleted entry in c*)
VAR b: Page;
i, k: INTEGER;
BEGIN (*h & (a.m = N-1) & (c.e[s-1].p = a) *)
IF s < c.m THEN (*b := page to the right of a*)
b := c.e[s].p; k := (b.m-N+1) DIV 2; (*k = nof items available on page b*)
a.e[N-1] := c.e[s]; a.e[N-1].p := b.p0;
IF k > 0 THEN (*balance by moving k-1 items from b to a*) i := 0;
WHILE i < k-1 DO a.e[i+N] := b.e[i]; INC(i) END ;
c.e[s] := b.e[k-1]; b.p0 := c.e[s].p;
c.e[s].p := b; DEC(b.m, k); i := 0;
WHILE i < b.m DO b.e[i] := b.e[i+k]; INC(i) END ;
a.m := N-1+k; h := FALSE
ELSE (*merge pages a and b, discard b*) i := 0;
WHILE i < N DO a.e[i+N] := b.e[i]; INC(i) END ;
i := s; DEC(c.m);
WHILE i < c.m DO c.e[i] := c.e[i+1]; INC(i) END ;
a.m := 2*N; h := c.m < N
END
ELSE (*b := page to the left of a*) DEC(s);
IF s = 0 THEN b := c.p0 ELSE b := c.e[s-1].p END ;
k := (b.m-N+1) DIV 2; (*k = nof items available on page b*)
IF k > 0 THEN i := N-1;
WHILE i > 0 DO DEC(i); a.e[i+k] := a.e[i] END ;
i := k-1; a.e[i] := c.e[s]; a.e[i].p := a.p0;
(*move k-1 items from b to a, one to c*) DEC(b.m, k);
WHILE i > 0 DO DEC(i); a.e[i] := b.e[i+b.m+1] END ;
c.e[s] := b.e[b.m]; a.p0 := c.e[s].p;
c.e[s].p := a; a.m := N-1+k; h := FALSE
ELSE (*merge pages a and b, discard a*)
c.e[s].p := a.p0; b.e[N] := c.e[s]; i := 0;
WHILE i < N-1 DO b.e[i+N+1] := a.e[i]; INC(i) END ;
b.m := 2*N; DEC(c.m); h := c.m < N
END
END underflow;
PROCEDURE delete(x: INTEGER; a: Page; VAR h: BOOLEAN);
(*search and delete key x in B-tree a; if a page underflow arises,
balance with adjacent page or merge; h := "page a is undersize"*)
VAR i, L, R: INTEGER; q: Page;
PROCEDURE del(p: Page; VAR h: BOOLEAN);
VAR k: INTEGER; q: Page; (*global a, R*)
BEGIN k := p.m-1; q := p.e[k].p;
IF q # NIL THEN del(q, h);
IF h THEN underflow(p, q, p.m, h) END
ELSE p.e[k].p := a.e[R].p; a.e[R] := p.e[k];
DEC(p.m); h := p.m < N
END
END del;
BEGIN (*a # NIL*)
L := 0; R := a.m; (*binary search*)
WHILE L < R DO
i := (L+R) DIV 2;
IF x <= a.e[i].key THEN R := i ELSE L := i+1 END
END ;
IF R = 0 THEN q := a.p0 ELSE q := a.e[R-1].p END ;
IF (R < a.m) & (a.e[R].key = x) THEN (*found*)
IF q = NIL THEN (*a is leaf page*)
DEC(a.m); h := a.m < N; i := R;
WHILE i < a.m DO a.e[i] := a.e[i+1]; INC(i) END
ELSE del(q, h);
IF h THEN underflow(a, q, R, h) END
END
ELSE delete(x, q, h);
IF h THEN underflow(a, q, R, h) END
END delete;
PROCEDURE PrintTree(p: Page; level: INTEGER);
VAR i: INTEGER;
BEGIN
IF p # NIL THEN i := 0;
WHILE i < level DO Texts.WriteString(W, " "); INC(i) END ;
i := 0;
WHILE i < p.m DO Texts.WriteInt(W, p.e[i].key, 5); INC(i) END ;
Texts.WriteLn(W);
PrintTree(p.p0, level+1); i := 0;
WHILE i < p.m DO PrintTree(p.e[i].p, level+1); INC(i) END
END PrintTree;
PROCEDURE Search*;
VAR cnt: INTEGER; S: Texts.Scanner;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
Texts.WriteString(W, "search"); Texts.Scan(S);
WHILE S.class = Texts.Int DO
Texts.WriteInt(W, S.i, 4); search(SHORT(S.i), root, cnt); Texts.WriteInt(W, cnt, 4)
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END Search;
PROCEDURE Insert*;
VAR S: Texts.Scanner;
h: BOOLEAN; u: Entry; q: Page;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
Texts.WriteString(W, "insert"); Texts.Scan(S);
WHILE S.class = Texts.Int DO
Texts.WriteInt(W, S.i, 4); h := FALSE; insert(SHORT(S.i), root, h, u);
IF h THEN (*insert new base page*)
q := root; NEW(root);
root.m := 1; root.p0 := q; root.e[0] := u
END ;
Texts.Scan(S)
END ;
Texts.WriteLn(W); PrintTree(root, 0); Texts.Append(Oberon.Log, W.buf)
END Insert;
PROCEDURE Delete*;
VAR S: Texts.Scanner;
h: BOOLEAN;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
Texts.WriteString(W, "delete"); Texts.Scan(S);
WHILE S.class = Texts.Int DO
Texts.WriteInt(W, S.i, 4); h := FALSE; delete(SHORT(S.i), root, h);
IF h THEN (*base page size underflow*)
IF root.m = 0 THEN root := root.p0 END
END ;
Texts.Scan(S)
END ;
Texts.WriteLn(W); PrintTree(root, 0); Texts.Append(Oberon.Log, W.buf)
END Delete;
PROCEDURE Init*;
BEGIN NEW(root); root.m := 0
END Init;
BEGIN Init; Texts.OpenWriter(W)
END BTree.