(* ==================================================== *) (* Copyright (C) 1990-1992 Clarion Software Corporation *) (* ==================================================== *) IMPLEMENTATION MODULE Table; IMPORT Lib; FROM Storage IMPORT ALLOCATE, DEALLOCATE; CLASS IMPLEMENTATION Element; VIRTUAL PROCEDURE Compare( p : ElementPtr ) : INTEGER; (* It is an error not to supply an implementation of this method. The client MUST supply a method to compare 'THIS' with 'p'. *) BEGIN Lib.FatalError(' implemeted by client '); RETURN 0; END Compare; BEGIN END Element ; CLASS GenElem (Element) ; GenericData : CHAR; END GenElem; CLASS IMPLEMENTATION GenElem; BEGIN END GenElem; TYPE GenElemPtr = POINTER TO GenElem; (* The above definitions are a skeleton for all the implementation of the 'Element' CLASS. This enables the 'TABLE' class to successfully copy any client implementation of 'Element' *) CLASS IMPLEMENTATION TABLE; PROCEDURE Insert( VAR x : Element ); (* Insert a new element 'x' in 'THIS' table *) PROCEDURE Search( VAR p : ElementPtr; VAR h : BOOLEAN); (* Searches a tree 'p' for the element 'x'. If it is found then the new value replaces the old. If 'x' is not in the tree, then 'x' becomes a new leaf of the tree. *) VAR p1 : ElementPtr; p2 : ElementPtr; BEGIN IF (p = NIL) THEN (* Create new leaf *) ALLOCATE(p,SIZE(x)); Lib.Move(ADR(x),p,SIZE(x)); p^.Bal := 0; p^.Left := NIL; p^.Right := NIL; h := TRUE; (* Tree requires balancing *) ELSE IF (x.Compare(p) < 0) THEN (* 'THIS' is < 'p' *) (* Search the 'Left' branch of 'p' recursively until 'x' is either found or created. *) Search(p^.Left,h); IF h THEN (* i.e. requires balancing *) CASE p^.Bal OF | 1 : p^.Bal := 0; h := FALSE; | 0 : p^.Bal := -1; | -1 : p1 := p^.Left; IF (p1^.Bal = -1) THEN p^.Left := p1^.Right; p1^.Right := p; p^.Bal := 0; p := p1; ELSE p2 := p1^.Right; p1^.Right := p2^.Left; p2^.Left := p1; p^.Left := p2^.Right; p2^.Right := p; IF (p2^.Bal = -1) THEN p^.Bal := 1; ELSE p^.Bal := 0; END; IF (p2^.Bal = 1) THEN p1^.Bal := -1; ELSE p1^.Bal := 0; END; p := p2; END; p^.Bal := 0; h := FALSE; (* Balancing done *) END (* CASE *); END (* of balancing 'Left' sub-tree *); ELSIF (x.Compare(p) > 0) THEN (* 'THIS' > 'p' *) (* Search the 'Right' branch of 'p' recursively until 'x' is either found or created. *) Search( p^.Right,h); IF h THEN (* i.e. tree needs balancing *) CASE p^.Bal OF | -1 : p^.Bal := 0; h := FALSE; | 0 : p^.Bal := 1; | 1 : p1 := p^.Right; IF (p1^.Bal = 1) THEN p^.Right := p1^.Left; p1^.Left := p; p^.Bal := 0; p := p1; ELSE p2 := p1^.Left; p1^.Left := p2^.Right; p2^.Right := p1; p^.Right := p2^.Left; p2^.Left := p; IF (p2^.Bal = 1) THEN p^.Bal := -1; ELSE p^.Bal := 0; END; IF (p2^.Bal = -1) THEN p1^.Bal := 1; ELSE p1^.Bal := 0; END; p := p2; END; p^.Bal := 0; h := FALSE; (* Tree balanced *) END (* CASE *); END (* Balancing 'Right' sub-tree *); ELSE (* 'THIS' and 'p' are the same *) h := FALSE; Lib.Move(ADR(GenElemPtr(ADR(x))^.GenericData), ADR(GenElemPtr(p)^.GenericData), SIZE(x)-VSIZE(Element.Bal)); END (* Possible comaprison results *); END; END Search; VAR h : BOOLEAN; BEGIN IF (Root # NIL) AND (ADR(Root^.Compare) # ADR(x.Compare)) THEN (* All table elements must be homogeneous; i.e. they must be of the same CLASS *) Lib.FatalError('object not compatible with table'); END; Search(Root,h); END Insert; PROCEDURE Find( VAR x : Element ) : BOOLEAN; (* Search for 'x' in 'THIS' tree; if 'x' is found in 'THIS' tree then the function returns 'TRUE' and 'x' is set to the mathing element. Otherwise the method returns 'FALSE'. *) PROCEDURE _Find( r : ElementPtr ) : ElementPtr; (* Implements the search algorithm *) BEGIN LOOP IF (r = NIL) THEN (* No match *) RETURN r; ELSIF (x.Compare(r) < 0) THEN (* 'THIS' < r *) r := r^.Left; ELSIF (x.Compare(r) > 0) THEN (* 'THIS' > r *) r := r^.Right; ELSE (* FOUND IT! *) RETURN r; END; END (* LOOP *); END _Find; VAR p : ElementPtr; BEGIN p := _Find(Root); IF (p # NIL) THEN (* Element Located *) Lib.Move(p,ADR(x),SIZE(x)); RETURN TRUE; ELSE RETURN FALSE; END; END Find; PROCEDURE Delete( VAR x : Element ); (* Locate the element 'x' in 'THIS' tree and delete it *) VAR q : ElementPtr; PROCEDURE r_Balance( VAR p : ElementPtr; VAR h : BOOLEAN); (* Blance a right sub-tree *) VAR p1 : ElementPtr; p2 : ElementPtr; b1 : BalanceFlag; b2 : BalanceFlag; BEGIN CASE p^.Bal OF | -1 : p^.Bal := 0; | 0 : p^.Bal := 1; h := FALSE; | 1 : p1 := p^.Right; b1 := p1^.Bal; IF (b1 >= 0) THEN p^.Right := p1^.Left; p1^.Left := p; IF (b1 = 0) THEN p^.Bal := 1; p1^.Bal := -1; h := FALSE ELSE p^.Bal := 0; p1^.Bal := 0; END; p := p1; ELSE p2 := p1^.Left; b2 := p2^.Bal; p1^.Left := p2^.Right; p2^.Right := p1; p^.Right := p2^.Left; p2^.Left := p; IF (b2 = 1) THEN p^.Bal := -1; ELSE p^.Bal := 0; END; IF (b2 = -1) THEN p1^.Bal := 1; ELSE p1^.Bal := 0; END; p := p2; p2^.Bal := 0; END; END (* CASE *); END r_Balance; PROCEDURE l_Balance( VAR p : ElementPtr; VAR h : BOOLEAN); (* Balance a left sub-tree *) VAR p1 : ElementPtr; p2 : ElementPtr; b1 : BalanceFlag; b2 : BalanceFlag; BEGIN CASE p^.Bal OF | 1 : p^.Bal := 0; | 0 : p^.Bal := -1; h := FALSE; | -1 : p1 := p^.Left; b1 := p1^.Bal; IF (b1 <= 0) THEN p^.Left := p1^.Right; p1^.Right := p; IF (b1 = 0) THEN p^.Bal := -1; p1^.Bal := 1; h := FALSE ELSE p^.Bal := 0; p1^.Bal := 0; END; p := p1; ELSE p2 := p1^.Right; b2 := p2^.Bal; p1^.Right := p2^.Left; p2^.Left := p1; p^.Left := p2^.Right; p2^.Right := p; IF (b2 = -1) THEN p^.Bal := 1; ELSE p^.Bal := 0; END; IF (b2 = 1) THEN p1^.Bal := -1; ELSE p1^.Bal := 0; END; p := p2; p2^.Bal := 0; END; END (* CASE *); END l_Balance; PROCEDURE DeleteLeaf( VAR r : ElementPtr; VAR h : BOOLEAN ); (* Recursively search for extreme right-hand node of the sub-tree 'r' and move data into 'q' *) BEGIN IF (r^.Right # NIL) THEN DeleteLeaf(r^.Right,h); IF h THEN l_Balance(r,h); END; ELSE Lib.Move(ADR(GenElemPtr(r)^.GenericData), ADR(GenElemPtr(q)^.GenericData), SIZE(x)-VSIZE(Element.Bal)); q := r; r := r^.Left; h := TRUE; END; END DeleteLeaf; PROCEDURE _Delete( VAR p : ElementPtr; VAR h : BOOLEAN ); (* Main recursive deletion procedure *) BEGIN IF (p = NIL) THEN (* Not found *) h := FALSE; ELSIF (x.Compare(p) < 0) THEN (* 'THIS' < 'p' *) _Delete(p^.Left,h); IF h THEN r_Balance(p,h); END; ELSIF (x.Compare(p) > 0) THEN (* 'THIS' > 'p' *) _Delete(p^.Right,h); IF h THEN l_Balance(p,h); END; ELSE (* Found it! *) q := p; IF (q^.Right = NIL) THEN p := q^.Left; h := TRUE; ELSIF (q^.Left = NIL) THEN p := q^.Right; h := TRUE; ELSE DeleteLeaf(q^.Left,h); IF h THEN r_Balance(p,h); END; END; DISPOSE(q); END; END _Delete; VAR h : BOOLEAN; BEGIN IF (Root = NIL) THEN RETURN; END; IF (Root # NIL) AND (ADR(x.Compare) # ADR(Root^.Compare)) THEN (* 'x' is not the same type as tree members *) Lib.FatalError('object not compatible with table'); END; _Delete(Root,h); END Delete; PROCEDURE Apply( p : Action ); (* Apply a procedure to all table elements in order *) PROCEDURE ApplyToElement( s : ElementPtr ); (* Apply 'p' to left sub-tree of s, then s, then the right sub-tree of s. *) BEGIN IF (s = NIL) THEN RETURN; ELSE ApplyToElement(s^.Left); p(s); ApplyToElement(s^.Right); END; END ApplyToElement; BEGIN ApplyToElement(Root); END Apply; PROCEDURE Init; (* Initialise a tree *) BEGIN Root := NIL; END Init; PROCEDURE Eq( t2 : TABLE ) : INTEGER; (* Compare 'THIS' to 't2'. Return values: <0 'THIS' is less than 't2' 0 'THIS' is equal to 't2' >0 'THIS' is greater than 't2' The trees are searched from the bottom up (i.e. in order) and the elements compared. The procedure returns immediately a difference is detected or when both trees are exhausted (and, therefore, they must be equal). This process is implemented iteratively rather than recursively. *) VAR S1, S2 : ARRAY [1..32] OF ElementPtr; r1, r2 : ElementPtr; sp1, sp2 : CARDINAL; res : INTEGER; BEGIN r1 := Root; r2 := t2.Root; IF (r1 # NIL) AND (r1 # r2) AND (ADR(r1^.Compare) # ADR(r2^.Compare)) THEN (* Both trees must contain the same sort of element *) Lib.FatalError(' not compareable '); END; sp1 := 0; sp2 := 0; LOOP WHILE (r1 # NIL) DO (* Build left edge array for 'THIS' *) INC(sp1); S1[sp1] := r1; r1 := r1^.Left; END; WHILE (r2 # NIL) DO (* Build left edge array for 't2' *) INC(sp2); S2[sp2] := r2; r2 := r2^.Left; END; IF (sp1 = 0) THEN (* No left sub-tree for 'THIS' *) IF (sp2 = 0) THEN (* No left sub-tree for 't2' *) RETURN 0; (* Implies they are equal *) ELSE RETURN -1; (* 'THIS' < 't2' *) END; ELSIF (sp2 = 0) THEN (* No left sub-tree for 't2' *) RETURN 1; (* 'THIS' > 't2' *) ELSE r1 := S1[sp1]; DEC(sp1); r2 := S2[sp2]; DEC(sp2); END; res := r1^.Compare(r2); (* Compare extreme left of both *) IF (res # 0) THEN (* These are different! *) RETURN res; (* Return how they are different *) END; r1 := r1^.Right; r2 := r2^.Right; END (* LOOP *); END Eq; PROCEDURE SubSet( t2 : TABLE ) : BOOLEAN; (* Are the elements of 'THIS' table a sub set of the elements of the table 't2'? The procedure scans scans the trees in order looking for an initial point of equality. Then 'THIS' is compared to this sub-tree of 't2' until either an element greater than the current 'THIS' element is found, or 'THIS' is exhuasted. The process is implemented iteratively rather than recursively. *) VAR S1, S2 : ARRAY [1..32] OF ElementPtr; r1, r2, cr : ElementPtr; sp1, sp2 : CARDINAL; res : INTEGER; BEGIN IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN (* Both trees must contain the same type of element *) Lib.FatalError('different types'); END; r1 := Root; r2 := t2.Root; sp1 := 0; sp2 := 0; LOOP WHILE (r1 # NIL) DO INC(sp1); S1[sp1] := r1; r1 := r1^.Left; END; IF (sp1 = 0) THEN (* End of 'THIS' => is a sub-tree *) RETURN TRUE; END; r1 := S1[sp1]; DEC(sp1); cr := r1; r1 := r1^.Right; LOOP WHILE (r2 # NIL) DO INC(sp2); S2[sp2] := r2; r2 := r2^.Left; END; IF (sp2 = 0) THEN (* End of 't2' => not a sub-tree *) RETURN FALSE; ELSE r2 := S2[sp2]; DEC(sp2); END; res := cr^.Compare(r2); r2 := r2^.Right; IF (res < 0) THEN RETURN FALSE; ELSIF (res = 0) THEN EXIT; END; END (* LOOP *); END (* LOOP *); END SubSet; PROCEDURE Copy() : TABLE; (* Make a copy of 'THIS' *) PROCEDURE _Copy( r : ElementPtr ) : ElementPtr; (* Recursively generate a copy of 'r' *) VAR x : ElementPtr; BEGIN IF (r # NIL) THEN ALLOCATE(x,SIZE(r^)); Lib.Move(r,x,SIZE(r^)); x^.Left := _Copy(r^.Left); x^.Right := _Copy(r^.Right); RETURN x; ELSE RETURN r; END; END _Copy; VAR NewTree : TABLE; BEGIN NewTree.Root := _Copy(Root); RETURN NewTree; END Copy; PROCEDURE Incl( t2 : TABLE); (* Include 't2' in 'THIS' tree *) PROCEDURE _Incl( r : ElementPtr ); (* Recursively insert 'r' into 'THIS' *) BEGIN IF (r # NIL) THEN _Incl(r^.Left); _Incl(r^.Right); Insert(r^); END; END _Incl; BEGIN IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN Lib.FatalError('different types'); END; _Incl(t2.Root); END Incl; PROCEDURE Excl( t2 : TABLE); (* Exclude elements of 't2' from 'THIS' *) PROCEDURE _Excl( r: ElementPtr ); (* Recursively exclude 'r' from 'THIS' *) BEGIN IF (r # NIL) THEN _Excl(r^.Left); _Excl(r^.Right); Delete(r^); END; END _Excl; BEGIN IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN Lib.FatalError('different types'); END; _Excl(t2.Root); END Excl; PROCEDURE Empty() : BOOLEAN; (* Is 'THIS' empty? *) BEGIN RETURN (Root = NIL); END Empty; PROCEDURE Dispose; (* Dispose of entire tree *) PROCEDURE _Dispose( r : ElementPtr ); (* Recursively dispose of each element of 'r' *) BEGIN IF (r # NIL) THEN _Dispose(r^.Left); (* Delete left sub-tree *) _Dispose(r^.Right); (* Delete right sub-tree *) DISPOSE(r); END; END _Dispose; BEGIN _Dispose(Root); END Dispose; BEGIN END TABLE ; END Table.