Enough pseudocode was given in section 15.3.2 to allow the following heavily commented implementation to stand on its own.
IMPLEMENTATION MODULE Heaps;
(******************
Design by R. Sutcliffe copyright 1996
Modified 1996 10 16
This module provides a Heap ADT.
******************)
FROM Storage IMPORT
ALLOCATE, DEALLOCATE;
FROM DataADT IMPORT
DataType, Assign, GetKey, ActionProc, Compare, CompareResults;
TYPE
NodePointer = POINTER TO TreeNode;
TreeNode =
RECORD
dataItem : DataType;
leftPoint, rightPoint, parent, (* binary tree linkage *)
next, prev : NodePointer; (* linear linkage across rows *)
END;
Heap = POINTER TO TreeData;
TreeData =
RECORD
root, (* first node *)
last, (* last node *)
lowerLeft (* first node in last row; helps for adding linkage to next row *)
: NodePointer;
state : HeapState; (* stores error conditions *)
travKind : TraverseKind; (* inOrder, preOrder, postOrder or rowOrder *)
travDirIsForward : BOOLEAN;
room, (* how many could be stored if last row full *)
numItems (* how many are actually stored *)
: CARDINAL;
END;
PROCEDURE MakeNode () : NodePointer;
(* set up one new node with all nil pointers and no data; return a pointer to the new node. *)
VAR
temp : NodePointer;
BEGIN
NEW (temp); (* get node memory *)
IF temp # NIL
THEN
temp^.leftPoint := NIL;
temp^.rightPoint := NIL;
temp^.parent := NIL;
temp^.next := NIL;
temp^.prev := NIL;
END;
RETURN temp;
END MakeNode;
PROCEDURE KillNode (VAR node : NodePointer);
(* give back all memory associated with node *)
BEGIN
IF node # NIL
THEN
DISPOSE (node);
END;
END KillNode;
PROCEDURE Erase (VAR r : NodePointer);
(* Pre: r is the root of a subtree
Post: recursive post traverse killing all nodes below as well as the one passed in *)
BEGIN
IF r # NIL
THEN
Erase (r^.leftPoint);
Erase (r^.rightPoint);
KillNode (r);
END;
END Erase;
(* It turned out the following was not needed, but who knows; why not leave it. *)
PROCEDURE IsLeaf (VAR node : NodePointer) : BOOLEAN;
BEGIN
RETURN (node # NIL) AND (node^.leftPoint = NIL); (* don't care about right *)
END IsLeaf;
PROCEDURE FindKey (node : NodePointer; key : KeyType;
VAR result : NodePointer) : BOOLEAN;
(* start at the given node and go looking for the data with the given key. If found, return both a pointer to it and TRUE; if not found, return FALSE.
Recursive preorder traversal *)
BEGIN
IF node = NIL (* safety measure *)
THEN
RETURN FALSE;
(* look at node data first *)
ELSIF Compare (GetKey(node^.dataItem), key) = equal THEN
result := node;
RETURN TRUE;
(* then at the left subtree *)
ELSIF FindKey (node^.leftPoint, key, result) THEN
RETURN TRUE;
(* and at the right one *)
ELSE
RETURN FindKey (node^.rightPoint, key, result)
END;
END FindKey;
PROCEDURE TraverseRows (heap : Heap; Proc : ActionProc);
(* Traverse the tree row by row, that is, using the linear linkage doing the procedure on each data item *)
VAR
count : CARDINAL;
node: NodePointer;
BEGIN
IF heap^.travDirIsForward
THEN (* start at the root *)
count := 0;
node := heap^.root;
(* and work consecutively through the noides *)
WHILE count < heap^.numItems
DO
INC (count);
Proc (node^.dataItem);
node := node^.next;
END; (* while *)
ELSE (* go in reverse order *)
count := heap^.numItems;
node := heap^.last;
WHILE count > 0
DO
DEC (count);
Proc (node^.dataItem);
node := node^.prev;
END; (* while *)
END (*if *)
END TraverseRows;
PROCEDURE ForwardTraverseNodes (node : NodePointer; tKind : TraverseKind; Proc : ActionProc);
(* These are the forward recursive tree traverse routines. Call with the root to traverse the whole tree. *)
BEGIN
IF node = NIL (* safety measure *)
THEN
RETURN
(* if at leaf then process it and report up *)
ELSIF node^.leftPoint = NIL THEN
Proc (node^.dataItem);
RETURN;
(* not at leaf so kick in recursion *)
ELSE
CASE tKind
OF
inOrder:
ForwardTraverseNodes (node^.leftPoint, tKind, Proc);
Proc (node^.dataItem);
ForwardTraverseNodes (node^.rightPoint, tKind, Proc);|
preOrder:
Proc (node^.dataItem);
ForwardTraverseNodes (node^.leftPoint, tKind, Proc);
ForwardTraverseNodes (node^.rightPoint, tKind, Proc);|
postOrder:
ForwardTraverseNodes (node^.leftPoint, tKind, Proc);
ForwardTraverseNodes (node^.rightPoint, tKind, Proc);
Proc (node^.dataItem);
ELSE
(* row order is handled elsewhere *)
END; (* case *)
END; (* if *)
END ForwardTraverseNodes;
PROCEDURE ReverseTraverseNodes (node : NodePointer; tKind : TraverseKind; Proc : ActionProc);
(* These are the reverse recursive tree traverse routines. Call with the root to traverse the whole tree. *)
BEGIN
IF node = NIL (* safety measure *)
THEN
RETURN
(* if at leaf then process it and report up *)
ELSIF node^.leftPoint = NIL THEN
Proc (node^.dataItem);
RETURN;
(* not at leaf so kick in recursion *)
ELSE
CASE tKind
OF
inOrder:
ReverseTraverseNodes (node^.rightPoint, tKind, Proc);
Proc (node^.dataItem);
ReverseTraverseNodes (node^.leftPoint, tKind, Proc);|
preOrder:
Proc (node^.dataItem);
ReverseTraverseNodes (node^.rightPoint, tKind, Proc);
ReverseTraverseNodes (node^.leftPoint, tKind, Proc);|
postOrder:
ReverseTraverseNodes (node^.rightPoint, tKind, Proc);
ReverseTraverseNodes (node^.leftPoint, tKind, Proc);
Proc (node^.dataItem);
ELSE
(* row order is handled elsewhere *)
END; (* case *)
END; (* if *)
END ReverseTraverseNodes;
PROCEDURE SiftUp (node : NodePointer);
(* Sift a data item up through heap until it is a proper parent. If it is already in the right place, nothing happens. *)
VAR
data : DataType;
BEGIN
(* set data item from node aside *)
Assign (node^.dataItem, data);
(* see if it needs to go up the tree *)
WHILE (node^.parent # NIL)
AND (Compare (data, node^.parent^.dataItem) = less)
DO
(* yes, so move parent down and look higher *)
Assign (node^.parent^.dataItem, node^.dataItem);
node := node^.parent;
END;
(* put data into proper place *)
Assign (data, node^.dataItem);
END SiftUp;
PROCEDURE SiftDown (node : NodePointer);
(* Sift data item down through heap until it is a proper child. If it is already in the right place, nothing happens. *)
VAR
data : DataType;
BEGIN
(* set data item from node aside *)
Assign (node^.dataItem, data);
(* see if it needs to go down the tree *)
WHILE ((node^.leftPoint # NIL) AND (Compare (data, node^.leftPoint^.dataItem) = greater))
OR ((node^.rightPoint # NIL) AND (Compare (data, node^.rightPoint^.dataItem) = greater))
DO (* pull up smaller child until it is a proper child *)
(* yes, so move smaller child up and look lower *)
IF (node^.rightPoint = NIL)
OR (Compare (node^.leftPoint^.dataItem, node^.rightPoint^.dataItem) # greater)
THEN
Assign (node^.leftPoint^.dataItem, node^.dataItem);
node := node^.leftPoint;
ELSE
Assign (node^.rightPoint^.dataItem, node^.dataItem);
node := node^.rightPoint;
END;
END;
(* put data into proper place *)
Assign (data, node^.dataItem);
END SiftDown;
(************************************
Exported Procedures
************************************)
PROCEDURE Status (heap : Heap) : HeapState;
(* Pre : t is a valid initialized heap
Post : The State of the heap is returned *)
BEGIN
RETURN heap^.state;
END Status;
PROCEDURE Init (VAR heap : Heap);
(* Allocates memory for a new heap sets state to allRight *)
BEGIN
NEW (heap);
IF heap # NIL
THEN
heap^.state := allRight;
heap^.root := NIL;
heap^.last := NIL;
heap^.lowerLeft := NIL;
heap^.numItems := 0;
heap^.room := 0;
heap^.travKind := inOrder;
heap^.travDirIsForward := TRUE;
END;
END Init;
PROCEDURE Destroy (VAR heap : Heap);
(* disposes the whole heap *)
BEGIN
Erase (heap^.root); (* all nodes *)
DISPOSE (heap); (* tree data *)
END Destroy;
PROCEDURE Add (VAR heap : Heap; data : ItemType);
(* Adds a new item to the heap. If successful sets state to allRight, else to enheapFailed *)
VAR
temp, mom : NodePointer;
BEGIN
IF heap # NIL
THEN
(* make a new node to hold the data *)
temp := MakeNode();
IF temp # NIL
THEN
(* stuff data in node *)
Assign (data, temp^.dataItem);
INC (heap^.numItems);
IF heap^.numItems = 1
THEN (* we just made a root *)
heap^.root := temp;
heap^.lowerLeft := temp;
heap^.last := temp;
heap^.room := 1;
RETURN;
ELSIF heap^.numItems > heap^.room THEN (* need to make new row *)
mom := heap^.lowerLeft;
heap^.lowerLeft := temp;
heap^.room := 2*heap^.room + 1;
ELSE (* continue on the same row *)
(* either the parent can take a new right child *)
mom := heap^.last^.parent;
IF mom ^.rightPoint # NIL
THEN (* or the next one on the row can -- not at end *)
mom := mom^.next;
END;
END; (* if heap *)
(* now set up all the rest of the linkage *)
temp^.parent := mom;
IF mom ^.leftPoint = NIL
THEN
mom^.leftPoint := temp;
ELSE
mom^.rightPoint := temp;
END; (* if mom *)
heap^.last^.next := temp;
temp^.prev := heap^.last;
heap^.last := temp;
(* ensure data goes to right ancestral node *)
SiftUp (temp);
heap^.state := allRight;
ELSE (* couldn't get node room *)
heap^.state := enheapFailed;
END (* if temp *)
ELSE (* heap itself is NIL *)
heap^.state := enheapFailed;
END; (* if heap *)
END Add;
PROCEDURE Delete (VAR heap : Heap; key : KeyType);
(* deletes an item whose key is defined equal to _key_ from the heap. If successful sets state to allRight; if heap was empty sets state to empty *)
VAR
targetNode, temp : NodePointer;
lastData : DataType;
BEGIN
(* find the node with the data if it is there *)
IF heap^.numItems = 0
THEN (* can't delete from an empty heap so set flag *)
heap^.state := empty;
RETURN;
ELSE (* whether we find an item to delete does not matter *)
heap^.state := allRight;
END;
(* ok so go out and look for it *)
IF FindKey (heap^.root, key, targetNode)
THEN
temp := heap^.last; (* save data from end of heap *)
(* now fix all the pointers at the end to delete that last node *)
lastData := temp^.dataItem;
heap^.last := temp^.prev;
IF temp^.parent^.leftPoint = temp
THEN
temp^.parent^.leftPoint := NIL;
ELSE
temp^.parent^.rightPoint := NIL;
END; (* if temp^ *)
DEC (heap^.numItems);
(* check to see if must shrink number of levels *)
IF heap^.numItems = heap^.room DIV 2
THEN (* must have killed first item in row, so *)
heap^.lowerLeft := temp^.parent;
heap^.room := heap^.numItems;
END; (* if heap^ *)
IF temp # targetNode (* if it is, we're done *)
THEN
(* pop the data item from last into node of data to delete *)
Assign (lastData, targetNode^.dataItem);
(* then see if it needs moving up or down *)
(* only one of the following will do anything *)
SiftDown (targetNode);
SiftUp (targetNode);
END; (* if temp *)
(* finally, dump memory from the last node *)
KillNode (temp);
ELSE (* if FindKey *)
(* nothing. If data not found we just don't care.*)
END; (* if FindKey *)
END Delete;
PROCEDURE Search (heap : Heap; key : KeyType; VAR data : ItemType) : BOOLEAN;
(* if found, returns TRUE and _data_ returns item at that point *)
VAR
temp : NodePointer;
BEGIN
IF (heap^.root # NIL) AND (heap^.numItems # 0)
AND (FindKey (heap^.root, key, temp))
THEN
data := temp^.dataItem;
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END Search;
PROCEDURE SetTraverseKind (heap : Heap; tKind : TraverseKind);
(* The default is inorder *)
BEGIN
IF heap # NIL
THEN
heap^.travKind := tKind;
END;
END SetTraverseKind;
PROCEDURE ReverseTraverseDirection (heap : Heap);
(* The default is forward, but this can be changed to and fro. The user has to keep track. *)
BEGIN
IF heap # NIL
THEN
heap^.travDirIsForward := ~heap^.travDirIsForward;
END;
END ReverseTraverseDirection;
PROCEDURE Size (heap : Heap) : CARDINAL;
(* Pre : heap is a valid initialized Heap
Post: The number of data items in the heap is returned *)
BEGIN
RETURN heap^.numItems
END Size;
PROCEDURE Traverse (heap : Heap; Proc : ActionProc);
(* Pre : heap is a valid initialized Heap
Post : the nodes are traversed inorder and Proc is performed on each data item. *)
VAR
temp : NodePointer;
BEGIN
IF (heap^.root # NIL) AND (heap^.numItems # 0)
THEN
(* special case the linear, nonrecursive traverses *)
IF heap^.travKind = rowOrder
THEN
TraverseRows (heap, Proc);
ELSIF heap^.travDirIsForward THEN
ForwardTraverseNodes (heap^.root, heap^.travKind, Proc);
ELSE
ReverseTraverseNodes (heap^.root, heap^.travKind, Proc);
END;
END;
END Traverse;
END Heaps.
The same cardinal ADT was used in the testing of this module as in the testing of the B-tree module. In addition, the following program module was written to check the implementation and ensure that it was correct. It should be studied carefully for completeness. The data used is that shown above in the discussion of heaps.
MODULE TestHeaps;
(* A simple program to test the Heaps library module.
by R. Sutcliffe
last modified 1996 10 18 *)
IMPORT Heaps, DataADT, SWholeIO, STextIO;
FROM Heaps IMPORT
TraverseKind;
VAR
theHeap : Heaps.Heap;
sum : CARDINAL;
dataRet: DataADT.DataType;
PROCEDURE Summit (item : DataADT.DataType);
(* a procedure to use in a test traverse *)
BEGIN
sum := sum + DataADT.GetKey (item)
END Summit;
(* The following procedures are used to print out the tree looking a little like a tree *)
PROCEDURE WriteSpace (n:CARDINAL);
(* write a specified number of spaces *)
VAR
count : CARDINAL;
BEGIN
FOR count := 1 TO n
DO
STextIO.WriteChar (" ");
END;
END WriteSpace;
(* these need to be global as both procs manipulate them *)
VAR
count, rowEnd, space : CARDINAL;
PROCEDURE AltWriteData ( item : DataADT.DataType);
(* write out a heap item followed by some space.
If at row end, start a new row and adjust spacing for that row. *)
BEGIN
IF count = rowEnd
THEN
STextIO.WriteLn;
space := space DIV 2;
IF space # 0
THEN
WriteSpace (space-1);
END;
rowEnd := rowEnd*2 +1;
END;
DataADT.WriteData (item);
INC (count);
IF (space # 0) AND (count # rowEnd)
THEN
WriteSpace (2*space-1);
END;
END AltWriteData;
PROCEDURE WriteHeap ( heap : Heaps.Heap);
(* Writes a heap in a way that resembles a tree.
Won't work very well except to write a number, say a key. *)
VAR
size : CARDINAL;
BEGIN
Heaps.SetTraverseKind (theHeap,rowOrder);
(* compute spacing parameters based on size of heap *)
size := Heaps.Size(heap);
space := 1;
WHILE space <= size
DO
space := 2 * space;
END;
(* so, it's empirical. Experiment. *)
space := 2 * space - 1;
count := 0;
rowEnd := 0;
Heaps.Traverse (heap, AltWriteData);
STextIO.WriteLn;
STextIO.WriteLn;
END WriteHeap;
BEGIN
Heaps.Init (theHeap);
Heaps.Add (theHeap, 54);WriteHeap (theHeap);
Heaps.Add (theHeap, 87);WriteHeap (theHeap);
Heaps.Add (theHeap, 27);WriteHeap (theHeap);
Heaps.Add (theHeap, 67);WriteHeap (theHeap);
Heaps.Add (theHeap, 19);WriteHeap (theHeap);
Heaps.Add (theHeap, 31);WriteHeap (theHeap);
Heaps.Add (theHeap, 29);WriteHeap (theHeap);
Heaps.Add (theHeap, 18);WriteHeap (theHeap);
Heaps.Add (theHeap, 32);WriteHeap (theHeap);
Heaps.Add (theHeap, 56);WriteHeap (theHeap);
Heaps.Add (theHeap, 7);WriteHeap (theHeap);
Heaps.Add (theHeap, 12);WriteHeap (theHeap);
Heaps.Add (theHeap, 31);WriteHeap (theHeap);
STextIO.WriteString ("*****forward traverses****"); STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,inOrder);
STextIO.WriteString ("in :");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,preOrder);
STextIO.WriteString ("pre :");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,postOrder);
STextIO.WriteString ("post:");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,rowOrder);
STextIO.WriteString ("row :");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,inOrder);
STextIO.WriteString ("****end forward traverses*****"); STextIO.WriteLn;STextIO.WriteLn;
Heaps.ReverseTraverseDirection(theHeap);
STextIO.WriteString ("*****reverse traverses****"); STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,inOrder);
STextIO.WriteString ("in :");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,preOrder);
STextIO.WriteString ("pre :");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,postOrder);
STextIO.WriteString ("post:");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,rowOrder);
STextIO.WriteString ("row :");
Heaps.Traverse (theHeap, DataADT.WriteData);STextIO.WriteLn;
Heaps.SetTraverseKind (theHeap,inOrder);
STextIO.WriteString ("****end reverse traverses*****"); STextIO.WriteLn;STextIO.WriteLn;
(* look for something that is supposed to be there *)
IF Heaps.Search (theHeap,31,dataRet)
THEN
STextIO.WriteString ("data found OK as ");
DataADT.WriteData (dataRet);
ELSE
STextIO.WriteString ("31 not found");
END;
STextIO.WriteLn; STextIO.WriteLn;
(* and for something that is not *)
IF Heaps.Search (theHeap,100,dataRet)
THEN
STextIO.WriteString ("data found OK as ");
DataADT.WriteData (dataRet);
ELSE
STextIO.WriteString ("100 not found");
END;
STextIO.WriteLn;STextIO.WriteLn;
(* now traverse the heap and add everything up *)
sum := 0;
Heaps.Traverse (theHeap, Summit);
STextIO.WriteLn;
STextIO.WriteString ("Sum is ");
SWholeIO.WriteCard (sum, 10);
STextIO.WriteLn;STextIO.WriteLn;
(* now, try a few deletes *)
Heaps.ReverseTraverseDirection(theHeap);
Heaps.Delete (theHeap, 31);WriteHeap (theHeap);
Heaps.Delete (theHeap, 67);WriteHeap (theHeap);
Heaps.Delete (theHeap, 19);WriteHeap (theHeap);
Heaps.Delete (theHeap, 7);WriteHeap (theHeap);
Heaps.Delete (theHeap, 42);WriteHeap (theHeap);
Heaps.Add (theHeap, 12); WriteHeap (theHeap);
END TestHeaps
When this program was run, the following output was collected. The reader should verify that the traverses are in fact all correct.
54
54
87
27
87 54
27
67 54
87
19
27 54
87 67
19
27 31
87 67 54
19
27 29
87 67 54 31
18
19 29
27 67 54 31
87
18
19 29
27 67 54 31
87 32
18
19 29
27 56 54 31
87 32 67
7
18 29
27 19 54 31
87 32 67 56
7
18 12
27 19 29 31
87 32 67 56 54
7
18 12
27 19 29 31
87 32 67 56 54 31
*****forward traverses****
in : 87 27 32 18 67 19 56 7 54 29 31 12 31
pre : 7 18 27 87 32 19 67 56 12 29 54 31 31
post: 87 32 27 67 56 19 18 54 31 29 31 12 7
row : 7 18 12 27 19 29 31 87 32 67 56 54 31
****end forward traverses*****
*****reverse traverses****
in : 31 12 31 29 54 7 56 19 67 18 32 27 87
pre : 7 12 31 29 31 54 18 19 56 67 27 32 87
post: 31 31 54 29 12 56 67 19 32 87 27 18 7
row : 31 54 56 67 32 87 31 29 19 27 12 18 7
****end reverse traverses*****
data found OK as 31
100 not found
Sum is 470
7
18 12
27 19 29 31
87 32 67 56 54
7
18 12
27 19 29 31
87 32 54 56
7
18 12
27 54 29 31
87 32 56
12
18 29
27 54 56 31
87 32
12
18 29
27 54 56 31
87 32
12
12 29
27 18 56 31
87 32 54