home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / MODULA2 / BTREE.MOD < prev    next >
Text File  |  2000-06-30  |  7KB  |  264 lines
  1. (* Insert and delete elements in a B-tree of page size 2n.
  2.    Read a sequence of keys positive values denote insertion,
  3.    negative ones deletion.  Print the resulting B-tree
  4.    after each operation. *)
  5.  
  6. MODULE btree;
  7.  
  8. FROM InOut   IMPORT WriteInt, WriteLn, WriteString, ReadInt;
  9. FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  10.  
  11. CONST n = 2;
  12.       nn = 4; (* page size *)
  13.  
  14. TYPE ref = POINTER TO page;
  15.  
  16.      item = RECORD
  17.               key: INTEGER;
  18.               p: ref;
  19.               count: INTEGER
  20.             END;
  21.      page = RECORD
  22.               m: [0..nn];  (* # of items *)
  23.               p0: ref;
  24.               e: ARRAY [1..nn] OF item;
  25.             END;
  26.  
  27. VAR root,q: ref;
  28.     x,i: INTEGER;
  29.     h: BOOLEAN;
  30.     u: item;
  31.  
  32. PROCEDURE printtree(p: ref; l: INTEGER);
  33. VAR i: INTEGER;
  34.  
  35. BEGIN
  36.   IF p # NIL THEN
  37.     WITH p^ DO
  38.       FOR i := 1 TO l DO WriteString('   ') END;
  39.       FOR i := 1 TO m DO WriteInt(e[i].key,4) END;
  40.       WriteLn;
  41.       printtree(p0,l+1);
  42.       FOR i := 1 TO m DO printtree(e[i].p,l+1) END;
  43.     END
  44.   END
  45. END printtree;
  46.  
  47. PROCEDURE search(x: INTEGER; a: ref; VAR h: BOOLEAN; VAR v: item);
  48.    (* search key x on B-tree with root a; if found, increment counter.  Otherwise
  49.        insert an item with key x and count 1 in tree.  If an item emerges to be
  50.        passed to a lower level, then assign it to v; h := "tree a has become higher" *)
  51. VAR k,l,r: INTEGER;
  52.     q: ref;
  53.     u: item;
  54.  
  55.   PROCEDURE insert;
  56.   VAR i: INTEGER;
  57.       b: ref;
  58.       
  59.   BEGIN             (* insert u to the right of a^.e[r] *)
  60.     WITH a^ DO
  61.       IF m < nn THEN
  62.         INC(m); h := FALSE;
  63.         FOR i := m TO r+2 BY -1 DO e[i] := e[i-1] END;
  64.         e[r+1] := u
  65.       ELSE          (* page a^ is full; split it and assign the emerging item to v *)
  66.         NEW(b);
  67.         (*FOR i := 1 TO nn DO b^.e[i].p := NIL END;*)
  68.         IF r <= n THEN
  69.           IF r = n THEN
  70.             v := u
  71.           ELSE
  72.             v := e[n];
  73.             FOR i := n TO r+2 BY -1 DO e[i] := e[i-1] END;
  74.             e[r+1] := u
  75.           END;
  76.           FOR i := 1 TO n DO b^.e[i] := a^.e[i+n] END
  77.         ELSE        (* insert u in right page *)
  78.           r := r - n;
  79.           v := e[n+1];
  80.           FOR i := 1 TO r-1 DO b^.e[i] := a^.e[i+n+1] END;
  81.           b^.e[r] := u;
  82.           FOR i := r+1 TO n DO b^.e[i] := a^.e[i+n] END
  83.         END;
  84.         m := n; b^.m := n;
  85.         b^.p0 := v.p; v.p := b
  86.       END
  87.     END
  88.   END insert;
  89.  
  90. BEGIN    (* search key x on page a^; h = FALSE *)
  91.   IF a = NIL THEN
  92.     h := TRUE;
  93.     WITH v DO      (* item with key x is not in tree *)
  94.       key := x;
  95.       count := 1;
  96.       p := NIL
  97.     END
  98.   ELSE
  99.     WITH a^ DO
  100.       l := 1; r := m;  (* binary array search *)
  101.       REPEAT
  102.         k := (l+r) DIV 2;
  103.         IF x <= e[k].key THEN r := k-1 END;
  104.         IF x >= e[k].key THEN l := k+1 END;
  105.       UNTIL r < l;
  106.       IF l-r > 1 THEN  (* found *)
  107.         INC(e[k].count);
  108.         h := FALSE
  109.       ELSE             (* item is not on this page *)
  110.         IF r = 0 THEN q := p0 ELSE q := e[r].p END;
  111.         search(x,q,h,u);
  112.         IF h THEN insert END
  113.       END
  114.     END
  115.   END
  116. END search;
  117.  
  118. PROCEDURE delete(x: INTEGER; a: ref; VAR h: BOOLEAN);
  119.     (* search and delete key x in B-tree a; if a page underlow is necessary,
  120.        balance with adjacent page if possible, otherwise merge; h := "page a
  121.        is undersize" *)
  122. VAR i,k,l,r: INTEGER;
  123.     q: ref;
  124.  
  125.   PROCEDURE underflow(c,a: ref; s: INTEGER; VAR h: BOOLEAN);
  126.       (* a = underflow page, c = ancestor page *)
  127.   VAR b: ref;
  128.       i,k,mb,mc: INTEGER;
  129.  
  130.   BEGIN
  131.     mc := c^.m;               (* h = TRUE, a^.m := n-1 *)
  132.     IF s < mc THEN
  133.       INC(s);
  134.       b := c^.e[s].p;
  135.       mb := b^.m;
  136.       k := (mb-n+1) DIV 2;    (* k = # of items available on adjacent page b *)
  137.       a^.e[n] := c^.e[s];
  138.       a^.e[n].p := b^.p0;
  139.       IF k > 0 THEN           (* move k items from b to a *)
  140.         FOR i := 1 TO k-1 DO a^.e[i+n] := b^.e[i] END;
  141.         c^.e[s] := b^.e[k];
  142.         c^.e[s].p := b;
  143.         b^.p0 := b^.e[k].p;
  144.         mb := mb - k;
  145.         FOR i := 1 TO mb DO b^.e[i] := b^.e[i+k] END;
  146.         b^.m := mb;
  147.         a^.m := n-1+k;
  148.         h := FALSE
  149.       ELSE                   (* merge pages a and b *)
  150.         FOR i := 1 TO n DO a^.e[i+n] := b^.e[i] END;
  151.         FOR i := s TO mc-1 DO c^.e[i] := c^.e[i+1] END;
  152.         a^.m := nn; c^.m := mc-1;
  153.         DISPOSE(b)
  154.       END
  155.     ELSE                     (* b := page to the left of a *)
  156.       IF s = 1 THEN b := c^.p0 ELSE b := c^.e[s-1].p END;
  157.       mb := b^.m + 1;
  158.       k := (mb-n) DIV 2;
  159.       IF k > 0 THEN          (* move k items from b to a *)
  160.         FOR i := n-1 TO 1 BY -1 DO a^.e[i+k] := a^.e[i] END;
  161.         a^.e[k] := c^.e[s];
  162.         a^.e[k].p := a^.p0;
  163.         mb := mb - k;
  164.         FOR i := k-1 TO 1 BY -1 DO a^.e[i] := b^.e[i+mb] END;
  165.         a^.p0 := b^.e[mb].p;
  166.         c^.e[s] := b^.e[mb];
  167.         c^.e[s].p := a;
  168.         b^.m := mb - 1;
  169.         a^.m := n - 1 + k;
  170.         h := FALSE
  171.       ELSE
  172.         b^.e[mb] := c^.e[s];
  173.         b^.e[mb].p := a^.p0;
  174.         FOR i := 1 TO n-1 DO b^.e[i+mb] := a^.e[i]; END;
  175.         b^.m := nn; c^.m := mc - 1;
  176.         DISPOSE(a)
  177.       END
  178.     END
  179.   END underflow;
  180.  
  181.   PROCEDURE del(p: ref; VAR h: BOOLEAN);
  182.   VAR q: ref;      (* global a.k *)
  183.  
  184.   BEGIN
  185.     WITH p^ DO
  186.       q := e[m].p;
  187.       IF q # NIL THEN
  188.         del(q,h);
  189.         IF h THEN underflow(p,q,m,h) END
  190.       ELSE
  191.         p^.e[m].p := a^.e[k].p;
  192.         a^.e[k] := p^.e[m];
  193.         DEC(m); h := m < n;
  194.       END
  195.     END
  196.   END del;
  197.  
  198. BEGIN
  199.   IF a = NIL THEN
  200.     WriteString('key is not in tree ');
  201.     WriteLn; h := FALSE
  202.   ELSE
  203.     WITH a^ DO
  204.       l := 1; r := m;     (* binary array search *)
  205.       REPEAT
  206.         k := (l+r) DIV 2;
  207.         IF x <= e[k].key THEN r := k-1 END;
  208.         IF x >= e[k].key THEN l := k+1 END
  209.       UNTIL l > r;
  210.       IF r = 0 THEN  q := p0 ELSE  q := e[r].p END;
  211.       IF l-r > 1 THEN
  212.         IF q = NIL THEN
  213.           DEC(m); h := m < n;
  214.           FOR i := k TO m DO e[i] := e[i+1] END;
  215.         ELSE
  216.           del(q,h);
  217.           IF h THEN underflow(a,q,r,h) END
  218.         END
  219.       ELSE
  220.         delete(x,q,h);
  221.         IF h THEN underflow(a,q,r,h) END;
  222.       END
  223.     END
  224.   END
  225. END delete;
  226.  
  227. BEGIN
  228.   root := NIL;
  229.   LOOP
  230.     WriteString('Enter key> ');
  231.     ReadInt(x);
  232.     IF x = 0 THEN WriteString(' Exiting Enter loop'); WriteLn; EXIT END;
  233.     WriteString(' search key '); WriteInt(x,6); WriteLn;
  234.     search(x,root,h,u);
  235.     IF h THEN
  236.       q := root;
  237.       NEW(root);
  238.       WITH root^ DO
  239.         m := 1;
  240.         p0 := q;
  241.         (*FOR i := 1 TO nn DO e[i].p := NIL END;*)
  242.         e[1] := u
  243.       END
  244.     END;
  245.     printtree(root,1);
  246.   END;
  247.   WriteString(' Key to delete> ');
  248.   ReadInt(x);
  249.   WHILE x # 0 DO
  250.     WriteString(' deleting key '); WriteInt(x,6); WriteLn;
  251.     delete(x,root,h);
  252.     IF h THEN
  253.       IF root^.m = 0 THEN
  254.         q := root;
  255.         root := q^.p0;
  256.         DISPOSE(q)
  257.       END
  258.     END;
  259.     printtree(root,1);
  260.     WriteString(' Key to delete> ');
  261.     ReadInt(x)
  262.   END
  263. END btree.
  264.