# pipe the following text through sh (the Bourne shell) to fill your # directory with the files you requested. The README file explains # what the files you get are supposed to do. cat > README <<\xxxxxxxxxx This directory contains the code discussed in 'An Empirical Comparison of Priority-Queue and Event-Set Implementations' in the April 1986 issue of Communications of the ACM. The code is divided into the following files: driver.9836 driver.hullv driver.vax The above three are test drivers. Each contains an include statement (or equivalent, whatever the Pascal compiler allows that serves that purpose) to include the type declarations for a priority queue implementation and second include statement for the code that operates in terms of those declarations. When compiling the drivers, it is conventional to simply create links binding the file names used in the drivers (xxx.h typically) to the actual .type and .code files. This avoids renaming files or editing the drivers in order to change what implementation is being tested. common.type This file contains the type declarations used for any queue implementation that works in terms of simple binary trees. Any implementation that does not work with this structure will have its own type declaration file. heap.code -- the implicit heap heap.type henrik.code -- Henriksen's algorithm henrik.type inomial.code -- Binomial queues inomial.type leftist.code -- Leftist trees leftist.type linked.code -- simple linked list linked.type pagoda.code -- Pagoda pair.code -- Pairing heap pair.type skewdn.code -- Top-down skew heap skewup.code -- Bottom-up skew heap skewup.type splay.code -- Splay trees twolist.code -- the two list algorithm twolist.type vaxprocs.h vaxtypes.h The above two files are needed by the Vax test driver under Berkeley Pascal on BSD UNIX. xxxxxxxxxx cat > common.type <<\xxxxxxxxxx { common.type: The following declarations provide the binary tree representation of priority queues used by skew trees, twisted trees, and pagodas. } noderef = ^node; node = record leftlink, rightlink: noderef; prio: real; aux: integer; end; queue = noderef; xxxxxxxxxx cat > driver.9836 <<\xxxxxxxxxx program driver(output); { driver.9836 } { Tests the implementation and performance of priority queues on the HP 9836 } { all comments containing the string *** should be inspected when moving this code to other machines in order find machine dependencies } { *** begin system specific code *** } import uio,,rnd,sysglobals; { disable range checking so that performance tests will look their best } $range off$ $stackcheck off$ { *** end system specific code *** } type { +++ replace these lines by the type declarations needed by the desired priority queue algorithms, or just use the standard HP Pascal directive } $include 'queue.type'$ { directive to put them here with the appropriate file name substituted for queue.type +++ } var freespace: noderef { free space list for nodes, see newnode }; { end of standard prefix to priority queue implementation tests } { +++ replace these lines by the procedures which implement the desired priority queue algorithms, or just use the standard HP Pascal directive } $include 'queue.code'$ { directive to put them here with the appropriate file name substituted for queue.code +++ } { standard suffix for queue implementation tests } { the following procedures maintain a private free space list so that the implementation of new and dispose does not interfere with the measurement process } function newnode: noderef; var n: noderef; begin if freespace = nil then begin new(n); end else begin n := freespace; freespace := freespace^.leftlink; end; newnode := n; end { newnode }; procedure dumpnode( n: noderef ); begin n^.leftlink := freespace; freespace := n; end { dumpnode }; procedure sqstest; { the primary queue text procedure } const trials = 1000 { how many trials should be run for performance measurement }; rseed = 5852883 { random number seed }; var i, j: integer { loop counters }; upper: integer { 2**upper is the largest queue size that will be tested }; elem: integer { count of elements in queue being tested }; target: real { desired queue length for next test }; q: queue { head of the queue under test }; n: noderef { node to be added or removed from queue }; oldprio: real { priority of previous node removed from queue }; bad: integer { count of times priorities are out of order }; overhead: real { measurement overhead, seconds per trial }; { *** system specific variables needed for performance measurement *** } seed: integer { random number seed for RAND procedure }; before: integer { time information at start of test (centiseconds) }; after: integer { time information at end of test (centiseconds) }; { *** end system specific code *** } function exponential: real; { returns a random number in [0..infinity] with an exponential distribution and a mean of ln(2) } begin { *** begin system specific code *** } random( seed ); { +++ this line can be changed to experiment with other priority increment distributions +++ } exponential := -ln( seed / (maxint - 1) ); { *** end system specific code *** } end; begin { sqstest } write('SQS algorithm test of: '); upper := message; writeln(' performance averaged over ', trials:1, ' trials, seed=', rseed:1); { *** begin system specific code *** } { initialize the random number generator seed } seed := rseed; { *** end system specific code *** } { basic correctness test: this test simply enqueues 1000 nodes with random priorities into an empty queue, then dequeues nodes until the queue is again empty, checking to see that 1000 nodes are indeed dequeued } initqueue(q); for i := 1 to 1000 do begin n := newnode; { *** begin system specific code *** } n^.prio := rand( seed, 32767 ) / 32767; { *** end system specific code *** } enqueue( n, q ); end; write( ' basic correctness test' ); bad := 0; i := 0; oldprio := -1.0; while not emptyqueue( q ) do begin i := i + 1; n := dequeue( q ); if oldprio > n^.prio then bad := bad + 1; oldprio := n^.prio; dumpnode( n ); end; { report the results of the correctness test } if ( (bad <> 0) or (i <> 1000) ) then begin writeln( ' failed' ); if bad <> 0 then writeln( ' Queue out of order ', bad:1, ' times'); if i < 1000 then writeln( ' Items in queue were lost'); if i > 1000 then writeln( ' Items in queue were duplicated'); halt; end else begin writeln( ' completed correctly, start overhead measurement'); end; { measure cost of testing the queue } n := newnode; { *** begin system specific code *** } before := sysclock; { *** end system specific code *** } for j := 1 to 10*trials do begin n^.prio := n^.prio + exponential; end; { *** begin system specific code *** } after := sysclock; overhead := (after - before) / (100.0 * 10.0 * trials); { *** end system specific code *** } writeln( ' Overhead measured as ', overhead:1:6, ' seconds per trial'); dumpnode( n ); { print report heading for tests of the performance of the queue implementation for various sized queues } writeln; { *** begin system specific code *** } { the report heading will vary depending on what can be measured } writeln( 'Elements Time (seconds)' ); writeln( '======== ==============' ); { *** end system specific code *** } target := 1.0 { initialize target element count }; { +++ note, in testing the two-list algorithm, the initial value of target should be significantly greater than 4 (8 works well) +++ } elem := 0 { record current element count }; initqueue( q ); oldprio := 0.0; while target <= upper do begin { put target elements in the queue } while elem < round(target) do begin { cook elements into the queue } { *** begin system specific code *** } if rand( seed, 10 ) > 6 then begin { *** end system specific code *** } if not emptyqueue( q ) then begin n := dequeue( q ); oldprio := n^.prio; dumpnode( n ); elem := elem - 1; end else begin { reset the priority since the queue is empty } oldprio := 0.0 end; end else begin { rand < 6, so add a node } n := newnode; n^.prio := oldprio + exponential; enqueue( n, q ); elem := elem + 1; end; end; { do trials enqueues and dequeues for target elements in queue } { *** begin system specific code *** } before := sysclock; { *** end system specific code *** } for j := 1 to trials do begin n := dequeue( q ); n^.prio := n^.prio + exponential; enqueue( n, q ); end; { *** begin system specific code *** } after := sysclock; writeln( elem:6 , (after - before) / (100.0 * trials) - overhead: 12 ); { *** end system specific code *** } {refigure the target number of elements in the queue} target := target * sqrt(2); end; { discard the elements in the queue } while not emptyqueue( q ) do dumpnode( dequeue( q ) ); writeln; end { sqstest }; begin { main program } { *** begin system specific code *** } { this directs the output to the spooler } rewrite( output, '/SPOOL/JONES.ASC' ); { *** end system specific code *** } freespace := nil; sqstest; end { main program }. xxxxxxxxxx cat > driver.hullv <<\xxxxxxxxxx program driver(output); { driver.hullv } { Tests the implementation and performance of priority queues on the Prime family of machines under Hull V-Mode Pascal. } { all comments containing the string *** should be inspected when moving this code to other machines in order to find machine dependencies } { *** begin system specific comment *** } {$ d-, h4 } {turn off all run-time checks, get 4*64k*16 bits heap} { *** end system specific comment *** } type { *** begin system specific code *** } { the following type declarations support access to Primos utilities under Hull V-Mode Pascal. } timblk = array[1..11]of integer; { *** end system specific code *** } { +++ replace these lines by the declarations of the types needed by the desried priority queue algorithms, or just use the directive } {$ s'file.type' } { with the appropriate file name substituted. } var freespace: noderef { free space list for nodes, see newnode }; { *** begin system specific code *** } { the following stubs give access to Primos utilities from Hull V-Mode Pascal. } procedure timdat/TIMDAT( var a: timblk short; var b: integer short ); extern; function random/RAND$A( var seed: integer ): real; extern; { the following function extracts the cpu time from data from timdat } function cputime( var a: timblk ): real; begin cputime := a[7] + a[8]/a[11]; end; { *** end system specific code *** } { end of standard prefix to priority queue implementation tests } { +++ replace these lines by the procedures which implement the desried priority queue algorithms, or just use the directive } {$ s'inomial.code' } { with the appropriate file name substituted. } { standard suffix for queue implementation tests } { the following procedures maintain a private free space list so that the implementation of new and dispose does not interfere with the measurement process } function newnode: noderef; var n: noderef; begin if freespace = nil then begin new(n); end else begin n := freespace; freespace := freespace^.leftlink; end; newnode := n; end { newnode }; procedure dumpnode( n: noderef ); begin n^.leftlink := freespace; freespace := n; end { dumpnode }; procedure sqstest; { the primary queue test procedure } const trials = 1000 { how many trials should be run for performance measurement }; rseed = 58528183 { initial random number seed }; var i, j: integer { loop counters }; upper: integer { 2**upper is the largest queue size that will be tested }; elem: integer { count of elements in queue being tested }; target: real { desired queue length for next test }; q: queue { head of the queue under test }; n: noderef { node to be added or removed from queue }; oldprio: real { priority of previous node removed from queue }; bad: integer { count of times priorities are out of order }; overhead: real { measurement overhead, seconds per trial }; { *** begin system specific code *** } seed: integer { random number generation seed }; { timblk is the parameter type for calling timdat under Primos } before: timblk { time information at start of test }; after: timblk { time information at end of test }; var22: integer{ a variable containing 22 needed by timdat }; { *** end system specific code *** } { *** begin system specific comment *** } { the real function 'random(x)' is defined by Primos as returning a random number between 0 and 1 (uniform distribution), the parameter passed to it is the seed. All calls to 'random' are flagged as system specific code } { *** end system specific comment *** } function exponential: real; { returns a random number in [0..infinity] with an exponential distribution and a mean of ln(2) } begin { *** begin system specific code *** } { +++ this line can be changed to experiment with other priority increment distributions +++ } exponential := -ln( random(seed) ) { Kingston's distribution 1 }; { exponential := 2 * random(seed) }{ Kingston's distribution 2 }; { exponential := 0.9 + 0.2*random(seed) }{ Kingston's distribution 3 }; { if random(seed) < 0.9 }{ Kingston's distribution 4 } { then exponential := random(seed) * 0.95238 } { else exponential := random(seed) * 0.95238 + 9.5238095; } { exponential := 1.5 * sqrt(random(seed))}{ Kingston's distribution 5 }; { *** end system specific code *** } end; begin { sqstest } write('SQS algorithm test of: '); upper := message; writeln(' performance averaged over ', trials:1, ' trials, seed=', rseed:1); { *** begin system specific code *** } seed := rseed { set the random number generation seed }; { *** end system specific code *** } { basic correctness test: this test simply enqueues 1000 nodes with random priorities into an empty queue, then dequeues nodes until the queue is again empty, checking to see that 1000 nodes are indeed dequeued. } initqueue(q); for i := 1 to 1000 do begin n := newnode; { *** begin system specific code *** } n^.prio := random( seed ); { *** end system specific code *** } enqueue( n, q ); end; write( ' basic correctness test' ); bad := 0; i := 0; oldprio := -1.0; while not emptyqueue( q ) do begin i := i + 1; n := dequeue( q ); if oldprio > n^.prio then bad := bad + 1; oldprio := n^.prio; dumpnode( n ); end; { report the results of the correctness test } if ( (bad <> 0) or (i <> 1000) ) then begin writeln( ' failed' ); if bad <> 0 then writeln( ' Queue out of order ', bad:1, ' times'); if i < 1000 then writeln( ' Items in queue were lost'); if i > 1000 then writeln( ' Items in queue were duplicated'); halt; end else begin writeln( ' completed correctly, start overhead measurement'); end; { measure cost of testing the queue } n := newnode; { *** begin system specific code *** } var22 := 22; timdat( before, var22 ); { *** end system specific code *** } for j := 1 to 10*trials do begin n^.prio := n^.prio + exponential; end; { *** begin system specific code *** } var22 := 22; timdat( after, var22 ); overhead := ( cputime( after ) - cputime( before ) ) / (10.0 * trials); { *** end system specific code *** } writeln( ' Overhead measured as ', overhead:1:6, ' seconds per trial' ); dumpnode( n ); { print report heading for tests of the performance of the queue implementation for various sized queues } writeln; { *** begin system specific code *** } { the report heading will vary depending on what can be measured } writeln( 'Elements Time (seconds)' ); writeln( '======== ==============' ); { *** end system specific code *** } target := 1.0 { initialize target element count }; { +++ note, in testing the two-list algorithm, the initial value of target should be significantly greater than 4 (8 works well) +++ } elem := 0 { record current element count }; initqueue( q ); oldprio := 0.0; while target <= upper do begin { put target elements in the queue } while elem < round(target) do begin { cook elements into the queue } { *** begin system specific code *** } if random(seed) > 0.6 then begin { remove a node } { *** end system specific code *** } if not emptyqueue( q ) then begin n := dequeue( q ); oldprio := n^.prio; dumpnode( n ); elem := elem - 1; end else begin { reset the priority since the queue is empty } oldprio := 0.0 end; end else begin { random < 0.6, so add a node } n := newnode; n^.prio := oldprio + exponential; enqueue( n, q ); elem := elem + 1; end; end; { do trials enqueues and dequeues for target elements in queue } { *** begin system specific code *** } var22 := 22; timdat( before, var22 ); { *** end system specific code *** } for j := 1 to trials do begin n := dequeue( q ); n^.prio := n^.prio + exponential; enqueue( n, q ); end; { *** begin system specific code *** } var22 := 22; timdat( after, var22 ); { the particular data reported will depend on what getrusage returns } writeln( elem:6 , ( cputime(after) - cputime(before) )/trials -overhead: 14:6 ); { *** end system specific code *** } {refigure the target number of elements in the queue} target := target * sqrt(2); end; { discard the elements in the queue, making sure right number were there } while not emptyqueue( q ) do begin dumpnode( dequeue( q ) ); elem := elem - 1; end; writeln; if elem > 0 then writeln('***** Data was lost during the above test *****') else if elem < 0 then writeln('***** Data was gained during the above test *****'); end { sqstest }; begin rewrite( output, 'data' ); freespace := nil; sqstest; end. xxxxxxxxxx cat > driver.vax <<\xxxxxxxxxx program driver(output); { driver.vax } { Tests the implementation and performance of priority queues on the VAX } { all comments containing the string *** should be inspected when moving this code to other machines in order to find machine dependencies } { *** begin system specific comment *** } { this code should be compiled using the -O option under the Berkeley Pascal compiler under Berkeley UNIX; note that the default under this compiler is to not generate any run-time checking, and that -O runs the output through a peep-hole optimizer } { *** end system specific comment *** } type { *** begin system specific code *** } { the following type declarations support access to Berkeley UNIX system calls used only for performance measurement, these declarations must be in an include file under Berkeley Pascal } #include "vaxtypes.h" { *** end system specific code *** } { +++ replace these lines by the declarations of the types needed by the desried priority queue algorithms, or just use the Berkeley Pascal } #include "qtypes.h" { directive to put them here with the appropriate file name substituted for qtypes.h +++ } var freespace: noderef { free space list for nodes, see newnode }; { *** begin system specific code *** } { the following procedure declarations give access to standard UNIX system calls, used only for performance measurement; note that these must be in an include file under Berkeley Pascal } #include "vaxprocs.h" { *** end system specific code *** } { end of standard prefix to priority queue implementation tests } { +++ replace these lines by the procedures which implement the desried priority queue algorithms, or just use the Berkeley Pascal } #include "qcode.h" { directive to put them here with the appropriate file name substituted for qcode.h +++ } { standard suffix for queue implementation tests } { the following procedures maintain a private free space list so that the implementation of new and dispose does not interfere with the measurement process } function newnode: noderef; var n: noderef; begin if freespace = nil then begin new(n); end else begin n := freespace; freespace := freespace^.leftlink; end; newnode := n; end { newnode }; procedure dumpnode( n: noderef ); begin n^.leftlink := freespace; freespace := n; end { dumpnode }; procedure sqstest; { the primary queue test procedure } const trials = 1000 { how many trials should be run for performance measurement }; rseed = 58528183 { initial random number seed }; var i, j: integer { loop counters }; upper: integer { 2**upper is the largest queue size that will be tested }; elem: integer { count of elements in queue being tested }; target: real { desired queue length for next test }; q: queue { head of the queue under test }; n: noderef { node to be added or removed from queue }; oldprio: real { priority of previous node removed from queue }; bad: integer { count of times priorities are out of order }; overhead: real { measurement overhead, seconds per trial }; { *** begin system specific code *** } { rusage is the parameter type for calling getrusage under BSD 4.2 UNIX } before: rusage { time information at start of test }; after: rusage { time information at end of test }; { *** end system specific code *** } { *** begin system specific comment *** } { the real function 'random(x)' is predefined by Berkeley Pascal as returning a random number between 0 and 1 (with uniform distribution), independent of the value of the parameter passed to it; all calls to 'random' are flagged as system specific code } { *** end system specific comment *** } function exponential: real; { returns a random number in [0..infinity] with an exponential distribution and a mean of ln(2) } begin { *** begin system specific code *** } { +++ this line can be changed to experiment with other priority increment distributions +++ } exponential := -ln( random(1.0) ) { Kingston's distribution 1 }; { exponential := 2 * random(1.0) }{ Kingston's distribution 2 }; { exponential := 0.9 + 0.2*random(1.0) }{ Kingston's distribution 3 }; { if random(1.0) < 0.9 }{ Kingston's distribution 4 } { then exponential := random(1.0) * 0.95238 } { else exponential := random(1.0) * 0.95238 + 9.5238095; } { exponential := 1.5 * sqrt(random(1.0))}{ Kingston's distribution 5 }; { *** end system specific code *** } end; begin { sqstest } write('SQS algorithm test of: '); upper := message; writeln(' performance averaged over ', trials:1, ' trials, seed=', rseed:1); { *** begin system specific code *** } i := seed(rseed) { set the random number generation seed }; { *** end system specific code *** } { basic correctness test: this test simply enqueues 1000 nodes with random priorities into an empty queue, then dequeues nodes until the queue is again empty, checking to see that 1000 nodes are indeed dequeued. } initqueue(q); for i := 1 to 1000 do begin n := newnode; { *** begin system specific code *** } n^.prio := random( 1.0 ); { *** end system specific code *** } enqueue( n, q ); end; write( ' basic correctness test' ); bad := 0; i := 0; oldprio := -1.0; while not emptyqueue( q ) do begin i := i + 1; n := dequeue( q ); if oldprio > n^.prio then bad := bad + 1; oldprio := n^.prio; dumpnode( n ); end; { report the results of the correctness test } if ( (bad <> 0) or (i <> 1000) ) then begin writeln( ' failed' ); if bad <> 0 then writeln( ' Queue out of order ', bad:1, ' times'); if i < 1000 then writeln( ' Items in queue were lost'); if i > 1000 then writeln( ' Items in queue were duplicated'); halt; end else begin writeln( ' completed correctly, start overhead measurement'); end; { measure cost of testing the queue } n := newnode; { *** begin system specific code *** } getrusage( 0, before ); { *** end system specific code *** } for j := 1 to 10*trials do begin n^.prio := n^.prio + exponential; end; { *** begin system specific code *** } getrusage( 0, after ); overhead := ( (after.utimes - before.utimes) + (after.utimeus - before.utimeus)*0.000001 ) / (10.0 * trials); { *** end system specific code *** } writeln( ' Overhead measured as ', overhead:1:6, ' seconds per trial' ); dumpnode( n ); { print report heading for tests of the performance of the queue implementation for various sized queues } writeln; { *** begin system specific code *** } { the report heading will vary depending on what can be measured } writeln( 'Elements Time (seconds) Faults and process switches' ); writeln( '======== ============== ===========================' ); { *** end system specific code *** } target := 1.0 { initialize target element count }; { +++ note, in testing the two-list algorithm, the initial value of target should be significantly greater than 4 (8 works well) +++ } elem := 0 { record current element count }; initqueue( q ); oldprio := 0.0; while target <= upper do begin { put target elements in the queue } while elem < round(target) do begin { cook elements into the queue } { *** begin system specific code *** } if random(1.0) > 0.6 then begin { remove a node } { *** end system specific code *** } if not emptyqueue( q ) then begin n := dequeue( q ); oldprio := n^.prio; dumpnode( n ); elem := elem - 1; end else begin { reset the priority since the queue is empty } oldprio := 0.0 end; end else begin { random < 0.6, so add a node } n := newnode; n^.prio := oldprio + exponential; enqueue( n, q ); elem := elem + 1; end; end; { do trials enqueues and dequeues for target elements in queue } { *** begin system specific code *** } getrusage( 0, before ); { *** end system specific code *** } for j := 1 to trials do begin n := dequeue( q ); n^.prio := n^.prio + exponential; enqueue( n, q ); end; { *** begin system specific code *** } getrusage( 0, after ); { the particular data reported will depend on what getrusage returns } writeln( elem:6 , ( (after.utimes - before.utimes) +(after.utimeus - before.utimeus)*0.000001)/trials -overhead: 14:6 , (after.minflt - before.minflt) +(after.majflt - before.majflt) +(after.nswap - before.nswap) +(after.nvcsw - before.nvcsw) +(after.nivcsw - before.nivcsw) : 12 ); { *** end system specific code *** } {refigure the target number of elements in the queue} target := target * sqrt(2); end; { discard the elements in the queue, making sure right number were there } while not emptyqueue( q ) do begin dumpnode( dequeue( q ) ); elem := elem - 1; end; writeln; if elem > 0 then writeln('***** Data was lost during the above test *****') else if elem < 0 then writeln('***** Data was gained during the above test *****'); end { sqstest }; begin freespace := nil; sqstest; end. xxxxxxxxxx cat > heap.code <<\xxxxxxxxxx { heap.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the implicit heap notation; see D. E. Knuth, The Art of Computer Programming, Vol. 3, Sorting and Searching, page 145 and onward. In this version, the heap consists only of pointers to records which contain, among other information, the priority of the node. These procedures assume the type declarations from file heap.type } procedure initqueue( var q: queue ); begin q.heapsize := 0; end { initqueue }; function emptyqueue( var q: queue ): boolean; begin emptyqueue := q.heapsize = 0; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); label 999{loop exit}; var i, j: 0..16384; temp: noderef; begin with q do begin if heapsize = 16384 then halt { queue full }; i := heapsize + 1; heapsize := i; repeat { there is a vacancy at heap[i] to be filled by either the new node or the parent of heap[i], whichever is lower priority } j := i div 2; if j = 0 then { parent does not exist } goto 999{loop exit}; temp := heap[j]; if n^.prio >= temp^.prio then { parent is higher } goto 999{loop exit}; { assert that parent is lower, move it down, shifting vacancy up } heap[i] := temp; i := j; until false; 999{loop exit}:; heap[i] := n; end; end { enqueue }; function dequeue( var q: queue ): noderef; label 999{loop exit}; var i: 0..16384; j: integer; temp, son, otherson: noderef; begin with q do begin dequeue := heap[1]; i := 1; temp := heap[heapsize]; heapsize := heapsize - 1; repeat { heap[i] is vacant and should be filled by the highest priority node of its sons (if any) or temp, if temp is higher } j := i + i; if j > heapsize then { no sons } goto 999{loop exit}; son := heap[j]; if j <> heapsize then begin otherson := heap[j+1]; if son^.prio > otherson^.prio then begin j := j + 1; son := otherson; end; end; { heap[j] is now the highest priority son } if temp^.prio < son^.prio then { sons are lower priority } goto 999{loop exit}; { son is higher priority, promote it and move vacancy down } heap[i] := son; i := j; until false; 999{loop exit}:; heap[i] := temp; end; end { dequeue }; function message: integer; { This function is included only for the use of the test driver } begin writeln('Implicit Heap, pointers only'); message := 16384; end { message }; xxxxxxxxxx cat > heap.type <<\xxxxxxxxxx { heap.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the implicit heap notation; see D. E. Knuth, The Art of Computer Programming, Vol. 3, Sorting and Searching, page 145 and onward. In this version, the heap consists only of pointers to records which contain, among other information, the priority of the node. } { note that these assume that the maximum queue capacity is 16384 elements; to change the capacity, globally change the constant 16384 throughout the declarations and code. } noderef = ^node; node = record leftlink: noderef { not needed by heap, used by test driver for free list link }; prio: real; aux: integer; end; queue = record heap: array[1..16384] of noderef; heapsize: 0..16384; end; xxxxxxxxxx cat > henrik.code <<\xxxxxxxxxx { henrik.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the indexed list representation described by J. O. Henriksen in 'An improved events list algorithm', Proc. Winter Simulation Conference, Dec. 1977, 547-557. This code is a modification by Douglas Jones of the Pascal code in J. H. Kingston's PhD thesis, 'Analysis of Algorithms for the Simulation Event List', University of Sydney, 1984. These procedures assume the type declarations from file henrik.type } procedure setvec( var q: queue; newsize: integer ); begin if newsize > 1024 then halt; q.vecsize := newsize; q.leftlim := 1024 - newsize; q.starti := 1024 - newsize div 2 - 1; q.startj := newsize div 4; end; procedure initqueue( var q: queue ); var n: noderef; i: integer; begin for i := 0 to 1023 do q.timevec[i] := 0.0; new(n); new(q.zero); q.zero^.leftlink := nil; q.zero^.rightlink := n; q.zero^.prio := 0.0; n^.leftlink := q.zero; n^.rightlink := nil; n^.prio := 1e38; q.timevec[1023] := 1e38; q.ptrvec[1023] := n; setvec( q, 1 ); end { initqueue }; function emptyqueue( var q: queue ): boolean; { q is a var parameter to avoid cumbersome copying; it is not modified } begin emptyqueue := q.zero^.rightlink = q.ptrvec[1023]; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); var i, j, count: integer; t: real; qq: noderef; begin { search setting i to index of right entry in ptrvec } i := q.starti; j := q.startj; t := n^.prio; while j > 0 do begin if q.timevec[i] <= t then i := i+j else i := i-j; j := j div 2; end; if q.timevec[i] <= t then i := i+1; { now do insertion in queue } qq := q.ptrvec[i]^.leftlink; count := 0; while n^.prio < qq^.prio do begin count := count + 1; if count = 4 then begin { pull } if i <= q.leftlim then setvec( q, q.vecsize*2 ); i := i-1; count := 0; q.ptrvec[i] := qq; q.timevec[i] := qq^.prio; end; qq := qq^.leftlink; end; n^.leftlink := qq; n^.rightlink := qq^.rightlink; n^.rightlink^.leftlink := n; qq^.rightlink := n; end { enqueue }; function dequeue( var q: queue ): noderef; begin if (q.timevec[q.starti] <= q.zero^.rightlink^.prio) and (q.vecsize > 2) then setvec( q, q.vecsize div 2 ); dequeue := q.zero^.rightlink; q.zero^.rightlink := q.zero^.rightlink^.rightlink; q.zero^.rightlink^.leftlink := q.zero; end { dequeue }; function message: integer; { This function is included only for the use of the test driver } begin writeln('Henriksen''s indexed list'); message := 5000; end { message }; xxxxxxxxxx cat > henrik.type <<\xxxxxxxxxx { henrik.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the indexed list representation described by J. O. Henriksen in 'An improved events list algorithm', Proc. Winter Simulation Conference, Dec. 1977, 547-557. These declarations are a modification by Douglas Jones of the Pascal code in J. H. Kingston's PhD thesis, 'Analysis of Algorithms for the Simulation Event List', University of Sydney, 1984. } { note that these assume that the maximum queue capacity is 4096 elements, or 4 times 1024; to change the capacity, globally change the constants 1023 and 1024 throughout the declarations and code. } noderef = ^node; node = record leftlink, rightlink: noderef; prio: real; aux: integer; end; queue = record ptrvec: array[0..1023] of noderef; zero: noderef; timevec: array[0..1023] of real; vecsize, leftlim, starti, startj: integer; end; xxxxxxxxxx cat > inomial.code <<\xxxxxxxxxx { inomial.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the binomial tree representation as described by J. Vuillemin in 'A Data Structure for Manipulating Priority Queues', CACM Vol. 21, No. 4, Apr. 1978, 309-315. This code is a modified translation by Douglas Jones of the SAIL code in M. R. Brown's PhD thesis, 'The Analysis of a Practical and Nearly Optimal Priority Queue', Stanford University, March 1977. The modifications involve eliminating Brown's assumption that the exchange operation is inexpensive and unrolling a loop to eliminate a goto. The global declarations from file inomial.type are assumed. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q.size := 0; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q.size = 0; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); var rtmrt, nxtrt: noderef; s: integer; begin s := q.size; n^.downlink := nil; if s <> 0 then rtmrt := q.leftmostroot^.leftlink; if odd(s) then begin { the rightmost tree in q consists of a single node; merge it into n. } nxtrt := rtmrt^.leftlink; if n^.prio > rtmrt^.prio then begin { exchange n and rtmrt } n^.leftlink := n; rtmrt^.downlink := n; n := rtmrt; end else begin n^.downlink := rtmrt; rtmrt^.leftlink := rtmrt; end; rtmrt := nxtrt; s := s div 2; while odd(s) do begin { the rightmost tree remaining is same size as n; merge with x } nxtrt := rtmrt^.leftlink; if n^.prio > rtmrt^.prio then begin { exchange n and rtmrt } n^.leftlink := rtmrt^.downlink^.leftlink; rtmrt^.downlink^.leftlink := n; rtmrt^.downlink := n; n := rtmrt; end else begin rtmrt^.leftlink := n^.downlink^.leftlink; n^.downlink^.leftlink := rtmrt; n^.downlink := rtmrt; end; rtmrt := nxtrt; s := s div 2; end { merge loop }; end; if s = 0 then begin { entire forest merged with n, size was power of 2 } n^.leftlink := n; q.leftmostroot := n; end else begin { some of orig .forest remains, n is rightmost in new one } q.leftmostroot^.leftlink := n; n^.leftlink := rtmrt; end; q.size := q.size + 1; end { enqueue }; function dequeue( var q: queue ): noderef; var lfmrt, rtmrt, smallest, pred, succ, smallestpred, rtmchild, newrtmrt, mrgtree, nxttree: noderef; s: integer; smallestkey: real; begin lfmrt := q.leftmostroot; rtmrt := lfmrt^.leftlink; s := q.size; if lfmrt = rtmrt then begin { there is only one tree in the forest } { return the root, make a new forest of its sons } smallest := lfmrt; q.leftmostroot := lfmrt^.downlink; end else begin { there are two or more trees in the forest } { search for the node containing the smallest key in the queue } lfmrt^.leftlink := nil { mark the leftmost node to stop search }; smallestkey := lfmrt^.prio; pred := lfmrt; succ := rtmrt; repeat if smallestkey >= succ^.prio then begin smallestkey := succ^.prio; smallestpred := pred; end; pred := succ; succ := succ^.leftlink; until succ = nil; smallest := smallestpred^.leftlink; if smallest = nil then begin { the rightmost root is the smallest } smallest := rtmrt; if odd(s) then begin { rightmost is single node, just remove it } lfmrt^.leftlink := smallest^.leftlink; end else begin { sons of rightmost become smallest in forest } lfmrt^.leftlink := smallest^.downlink^.leftlink; smallest^.downlink^.leftlink := smallest^.leftlink; end; end else begin { a root other than rightmost was smallest } { the tree containing this root must be replaced. A replacement is formed by mergint the rightmost tree with the children of the removed root. Children smaller than the rightmost tree become the smallest trees in the new forest } rtmchild := smallest^.downlink^.leftlink; smallest^.downlink^.leftlink := nil { mark leftmost child as end }; if not odd(s) then begin { queue size was even before deletion, children of removed root will move up to become smallest trees in new forest. Scan through children until mrgtree, the one which will merge with rightmost in forest } newrtmrt := rtmchild; s := s div 2; while not odd(s) do begin rtmchild := rtmchild^.leftlink; s := s div 2; end; mrgtree := rtmchild^.leftlink; if smallestpred = rtmrt { the tree to right of removed root is rightmost, will be consumed in building replacement tree; replacement's predicessor will be leftmost child which moves up } then smallestpred := rtmchild { link children into right of forest; their sibling is not the replacement and is therfore known } else rtmchild^.leftlink := rtmrt^.leftlink; end else begin { queue size is odd, children of removed root will be used to make replacement } newrtmrt := rtmrt^.leftlink; if smallestpred = rtmrt { the replacement will be the rightmost in the new forest; newrtmrt and smallestpred cannot be given values now; flag this with a nil value } then smallestpred := nil; { do first merge } mrgtree := rtmchild^.leftlink; if rtmrt^.prio > rtmchild^.prio then begin rtmchild^.downlink := rtmrt; rtmrt^.leftlink := rtmrt; rtmrt := rtmchild; end else begin rtmrt^.downlink := rtmchild; rtmchild^.leftlink := rtmchild; end; end; { complete the merge } while mrgtree <> nil do begin nxttree := mrgtree^.leftlink; if rtmrt^.prio > mrgtree^.prio then begin rtmrt^.leftlink := mrgtree^.downlink^.leftlink; mrgtree^.downlink^.leftlink := rtmrt; mrgtree^.downlink := rtmrt; rtmrt := mrgtree; end else begin mrgtree^.leftlink := rtmrt^.downlink^.leftlink; rtmrt^.downlink^.leftlink := mrgtree; rtmrt^.downlink := mrgtree; end; mrgtree := nxttree; end; { fixup links between roots in the forest: sibling link from leftmost to rightmost root, sibling link from replacement tree to next larger, and sibling link to replacement tree from next smaller } if smallest = lfmrt then begin { leftmost was replaced } q.leftmostroot := rtmrt; if smallestpred = nil then begin { replacement is only one } rtmrt^.leftlink := rtmrt; end else begin { more than one tree in forest } rtmrt^.leftlink := newrtmrt; smallestpred^.leftlink := rtmrt; end; end else begin { there is tree larger than replacement } rtmrt^.leftlink := smallest^.leftlink; if smallestpred = nil then begin { no tree smaller than repl } lfmrt^.leftlink := rtmrt; end else begin { there is tree smaller than replacement } lfmrt^.leftlink := newrtmrt; smallestpred^.leftlink := rtmrt; end; end; end; end; q.size := q.size - 1; dequeue := smallest; end { dequeue }; function message: integer; { *** this function is included only for the use of the test driver *** } begin writeln('Binomial Queue using structure R'); message := 16383; end { message }; xxxxxxxxxx cat > inomial.type <<\xxxxxxxxxx { inomial.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the binomial tree representation as described by J. Vuillemin in 'A Data Structure for Manipulating Priority Queues', CACM Vol. 21, No. 4, Apr. 1978, 309-315. These declarations are a translation by Douglas Jones of the SAIL code in M. R. Brown's PhD thesis, 'The Analysis of a Practical and Nearly Optimal Priority Queue', Stanford University, March 1977. } noderef = ^node; node = record leftlink, downlink: noderef; prio: real; aux: integer; end; queue = record leftmostroot: noderef; size: integer; end; xxxxxxxxxx cat > leftist.code <<\xxxxxxxxxx { leftist.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the leftist tree representation which Knuth credits to Clark A. Crane (see Knuth, Volume 3, Sorting and Searching, pages 150 to 153). Transcribed into Pascal by Douglas Jones and George Singer. The global declarations from file leftist.type are assumed. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; procedure merge( var p: queue; q: queue ); { merge two trees, either can be possibly a single node } var stay: boolean; d: integer; t, r: noderef; distance: integer; begin r := nil; stay := true; { merge the two trees, inserting upward right pointers } while stay do begin if q = nil then begin d := p^.dist; stay := false; end else if p = nil then begin p := q; d := p^.dist; stay := false; end else if p^.prio < q^.prio then begin t := p^.rightlink; p^.rightlink := r; r := p; p := t; end else begin t := q^.rightlink; q^.rightlink := r; r := q; q := t; end; end; { convert the tree to normal form } while r <> nil do begin if r^.leftlink = nil then distance := 0 else distance := r^.leftlink^.dist; q := r^.rightlink; if distance < d then begin d := distance + 1; r^.rightlink := r^.leftlink; r^.leftlink := p; end else begin d := d + 1; r^.rightlink := p; end; r^.dist := d; p := r; r := q; end; end { merge }; procedure enqueue( n: noderef; var q: queue ); begin n^.dist := 1; n^.leftlink := nil; n^.rightlink := nil; merge( q, n ); end { enqueue }; function dequeue( var q: queue ): noderef; begin dequeue := q; if (q^.leftlink <> nil) or (q^.rightlink <> nil) then merge( q^.leftlink, q^.rightlink ); q := q^.leftlink; end { dequeue }; function message: integer; { *** this function is included only for the use of the test drivers *** } begin writeln('Leftist Tree'); message := 4096; end { message }; xxxxxxxxxx cat > leftist.type <<\xxxxxxxxxx { leftist.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the leftist tree representation which Knuth credits to Clark A. Crane (see Knuth, Volume 3, Sorting and Searching, pages 150 to 153). Transcribed into Pascal by Douglas Jones and George Singer. } noderef = ^node; node = record leftlink, rightlink: noderef; prio: real; dist: integer; aux: integer; end; queue = noderef; xxxxxxxxxx cat > linked.code <<\xxxxxxxxxx { linked.code: The following procedures implement the enqueue and dequeue operations on a priority queue implemented as a simple linked list sorted in priority order. This code was written by Douglas Jones as an example of a typically naive implementation of priority queues. The declarations from file linked.type are assumed. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); label 1 { used for loop exit }; var p: noderef; begin if q = nil then begin { insert in empty queue } n^.leftlink := nil; q := n; end else begin { the queue isn't empty } if q^.prio > n^.prio then begin { insert before head of queue } n^.leftlink := q; q := n; end else begin { insert deeper into queue } p := q; while true do begin { search the queue } if (p^.leftlink = nil) then begin { insert at tail of queue } n^.leftlink := nil; p^.leftlink := n; goto 1; end else if p^.leftlink^.prio > n^.prio then begin { in middle } n^.leftlink := p^.leftlink; p^.leftlink := n; goto 1; end else begin { walk on down queue } p := p^.leftlink; end; end; 1: { loop exit label } end; end; end { enqueue }; function dequeue( var q: queue ): noderef; begin dequeue := q; q := q^.leftlink; end { dequeue }; function message: integer; { *** this function is included only for the use of the test driver *** } begin writeln('Linked List with sorting at enqueue'); message := 1024; end { message }; xxxxxxxxxx cat > linked.type <<\xxxxxxxxxx { linked.type: The following declarations are used by the enqueue and dequeue operations on a priority queue implemented as a simple linked list sorted in priority order. These declarations were written by Douglas Jones as an example of a typically naive implementation of priority queues. } noderef = ^node; node = record leftlink: noderef; prio: real; aux: integer; end; queue = noderef; xxxxxxxxxx cat > pagoda.code <<\xxxxxxxxxx { pagoda.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the pagoda representation invented by Francon, Viennot, and Vuillemin. This transcription into Pascal is based on the PDP-10 code on pages 42 through 47 of Robert P. Nix's "An Evaluation of Pagodas", Yale Computer Science Report #164 (undated). Transcription by Douglas Jones and George Singer. The declarations from file common.type are assumed. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); var p: noderef; begin n^.rightlink := n { point new nodes sons at itself }; n^.leftlink := n; if q = nil then begin { trivial insertion } q := n; end else begin { non-trivial insertion } p := q^.rightlink; if (n^.prio >= p^.prio) then begin { new node goes to the bottom } n^.rightlink := q^.rightlink; q^.rightlink := n; end else if (n^.prio <= q^.prio) then begin { new node replaces head } n^.leftlink := q^.leftlink; q^.leftlink := n; q := n; end else begin { new node goes somewhere in the middle } while n^.prio < p^.rightlink^.prio do p := p^.rightlink; n^.rightlink := p^.rightlink; p^.rightlink := q^.rightlink; q^.rightlink := n; n^.leftlink := p^.leftlink; p^.leftlink := n; end; end; end { enqueue }; function dequeue( var q: queue ): noderef; var lb, rb, f, tl: noderef; begin dequeue := q; lb := q^.rightlink; rb := q^.leftlink; if lb = rb then begin { there was only one node in the queue } q := nil; end else if lb = q then begin { there was no rightlink } repeat rb := rb^.leftlink; until rb^.leftlink = q; rb^.leftlink := q^.leftlink; q := rb; end else if rb = q then begin { there was no leftlink } repeat lb := lb^.rightlink; until lb^.rightlink = q; lb^.rightlink := q^.rightlink; q := lb; end else begin { non-trivial deletion } { compare left and right sons, prepare to merge sub-pagodas } if lb^.prio >= rb^.prio then begin f := lb; tl := lb^.rightlink; lb^.rightlink := lb; lb := tl; end else begin f := rb; tl := rb^.leftlink; rb^.leftlink := rb; rb := tl; end; { merge the left and right branches, bottom to top } while (lb <> q) and (rb <> q) do begin if lb^.prio >= rb^.prio then begin tl := lb^.rightlink; lb^.rightlink := f^.rightlink; f^.rightlink := lb; f := lb; lb := tl; end else begin tl := rb^.leftlink; rb^.leftlink := f^.leftlink; f^.leftlink := rb; f := rb; rb := tl; end; end; { put any leftovers from the merge at the top of the queue } if lb = q then begin tl := f^.leftlink; f^.leftlink := rb; while rb^.leftlink <> q do begin rb := rb^.leftlink; end; rb^.leftlink := tl; q := rb; end else begin tl := f^.rightlink; f^.rightlink := lb; while lb^.rightlink <> q do begin lb := lb^.rightlink; end; lb^.rightlink := tl; q := lb; end; end; end { dequeue }; function message: integer; { *** this function is included only for the use of the test driver *** } begin writeln('Pagoda'); message := 16384; end { message }; xxxxxxxxxx cat > pair.code <<\xxxxxxxxxx { pair.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the pairing heap representation (Fredman, Sedgewick, Sleator and Tarjan, "Pairing Heaps: A New Form of Self- Adjusting Heaps", Algorithmica, vol. 1, 111-129). The declarations from file pair.type are assumed. This code was written by Douglas Jones. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); begin if q = nil then begin { trivial enqueue } n^.downlink := nil; q := n; end else begin { consider n to be a minimal heap, pair it with q } if q^.prio < n^.prio then begin { q remains the root } n^.downlink := nil; n^.leftlink := q^.downlink; q^.downlink := n; end else begin { n becomes the new root } q^.leftlink := nil; n^.downlink := q; q := n; end; end; end { enqueue }; function dequeue( var q: queue ): noderef; var head: noderef { pointer to list of pairs }; next: noderef { pointer to next unpaired subtree }; a,b: noderef { working pointers for pairing operation }; begin dequeue := q; if q <> nil then begin { have work to do } next := q^.downlink; head := nil; while next <> nil do begin { make list of pairs } a := next; next := a^.leftlink; if next <> nil then begin b := next; next := b^.leftlink; { pair up a and b } if a^.prio < b^.prio then begin b^.leftlink := a^.downlink; a^.downlink := b; a^.leftlink := head; head := a; end else begin a^.leftlink := b^.downlink; b^.downlink := a; b^.leftlink := head; head := b; end; end else begin { put single left over node on pair list } a^.leftlink := head; head := a; end; end; { compute new head of queue } a := head; if a <> nil then begin head := a^.leftlink; while head <> nil do begin { link up list entries with a } b := head; head := b^.leftlink; if a^.prio < b^.prio then begin b^.leftlink := a^.downlink; a^.downlink := b; end else begin a^.leftlink := b^.downlink; b^.downlink := a; a := b; end; end; end; q := a; end; end { dequeue }; function message: integer; { *** this function is only included for the use of the test driver *** } begin writeln('Pairing Heap'); message := 16384; end { message }; xxxxxxxxxx cat > pair.type <<\xxxxxxxxxx { pair.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the pairing heap representation (Fredman, Sedgewick, Sleator and Tarjan, "Pairing Heaps: A New Form of Self- Adjusting Heaps", unpublished). These declarations were written by Douglas Jones. } noderef = ^node; node = record leftlink, downlink: noderef; prio: real; aux: integer; end; queue = noderef; xxxxxxxxxx cat > skewdn.code <<\xxxxxxxxxx { skewdn.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the skew heap representation (Sleator and Tarjan, Proc. ACM STOC, Feg. 14, 1983, 235-245.) This code was adapted by Douglas Jones from the code for imeld which uses what later came to be known as the top down variant of skew heaps. The declarations from file common.type are assumed. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; function meld( h1, h2: queue ): queue; { merge two skew heaps from the top down } var temp, y: noderef; begin if h1 = nil then begin meld := h2; end else if h2 = nil then begin meld := h1; end else begin if h1^.prio > h2^.prio then begin { swap } temp := h1; h1 := h2; h2 := temp; end; meld := h1; y := h1; h1 := y^.rightlink; y^.rightlink := y^.leftlink; while h1 <> nil do begin if h1^.prio > h2^.prio then begin { swap } temp := h1; h1 := h2; h2 := temp; end; y^.leftlink := h1; y := h1; h1 := y^.rightlink; y^.rightlink := y^.leftlink; end; y^.leftlink := h2; end; end { meld }; procedure enqueue( n: noderef; var q: queue ); begin n^.leftlink := nil; n^.rightlink := nil; q := meld( n, q ); end { enqueue }; function dequeue( var q: queue ): noderef; begin dequeue := q; q := meld( q^.leftlink, q^.rightlink ); end { dequeue }; function message: integer; { *** this function is only included for the use of the test driver *** } begin writeln('Skew Heap, top down representation'); message := 16384; end { message }; xxxxxxxxxx cat > skewup.code <<\xxxxxxxxxx { skewup.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the skew heap representation (Sleator and Tarjan, "Self-Adjusting Heaps", to appear in SIAM J. Computing) This code was adapted by Douglas Jones from the code in section 3 of the paper where the bottom up representation is used, as shown in figure 7 of the paper. The declarations from file skewup.type are assumed; the field leftlink in each queue node is used for the down pointer (to the rightmost descendant of the left subtree). This code has been modified to allow equal priorities; the original code assumed that all nodes had distinct priorities. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); var bound, lownode, temp: noderef; begin if q = nil then begin { trivial insertion in empty queue } q := n; q^.uplink := n; q^.leftlink := n; end else if n^.prio < q^.prio then begin { trivial insertion at head } n^.leftlink := q^.uplink; q^.uplink := n; n^.uplink := n; q := n; end else if n^.prio > q^.uplink^.prio then begin { trivial at tail } n^.uplink := q^.uplink; q^.uplink := n; n^.leftlink := n; end else begin { non-trivial insertion } bound := q^.uplink; lownode := bound; temp := bound^.uplink; while n^.prio < temp^.prio do begin bound := temp; temp := bound^.leftlink; bound^.leftlink := lownode; lownode := temp; temp := bound^.uplink; end; n^.uplink := temp; n^.leftlink := lownode; bound^.uplink := n; q^.uplink := n; end; end { enqueue }; function dequeue( var q: queue ): noderef; var major, minor, next, newq: noderef; begin dequeue := q { always return the head }; if q <> nil then begin { delete the head of the queue } major := q^.uplink; minor := q^.leftlink; if major^.prio < minor^.prio then begin { exchange major and minor } major := minor; minor := q^.uplink; end; if major = q then begin { unless priorities are equal, queue is empty } if minor = q then begin { queue really is empty } q := nil; end else begin { minor has prio equal to q } next := minor; while minor^.uplink <> q do minor := minor^.uplink; minor^.uplink := next; q := minor; end; end else begin { setup to do full scale merge of major and minor } newq := major; major := major^.uplink; newq^.uplink := newq; if major^.prio < minor^.prio then begin next := minor; minor := major; end else begin next := major; end; while next <> q do begin major := next^.uplink; next^.uplink := next^.leftlink; next^.leftlink := newq^.uplink; newq^.uplink := next; newq := next; if major^.prio < minor^.prio then begin next := minor; minor := major; end else begin next := major; end; end; { unless priorities are equal, merger is done } if minor = q then begin { merger is done } q := newq; end else begin { minor has prio equal to q } next := minor; while minor^.uplink <> q do minor := minor^.uplink; minor^.uplink := newq^.uplink; newq^.uplink := next; q := minor; end; end; end; end { dequeue }; function message: integer; { *** this function is only included for the use of the test driver *** } begin writeln('Skew Heap, bottom up representation'); message := 16384; end { message }; xxxxxxxxxx cat > skewup.type <<\xxxxxxxxxx { skewup.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the skew heap representation (Sleator and Tarjan, "Self-Adjusting Heaps", to appear in SIAM J. Computing) These declarations were adapted by Douglas Jones for the code in section 3 of the paper where the bottom up representation is used, as shown in figure 7 of the paper. } noderef = ^node; node = record uplink, leftlink: noderef; prio: real; aux: integer; end; queue = noderef; xxxxxxxxxx cat > splay.code <<\xxxxxxxxxx { splay.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the splay tree representation (Sleator and Tarjan, Proc. ACM STOC, Feg. 14, 1983, 235-245.) This code was adapted by Douglas Jones from the code for the top down version of splay. The declarations from file splaydel.type are assumed. } procedure initqueue( var q: queue ); { initialize a variable of type queue } begin q := nil; end { initqueue }; function emptyqueue( q: queue ): boolean; { test to see if a queue is empty } begin emptyqueue := q = nil; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); label 1, 2, 999; var left: noderef { the rightmost item in the left tree }; right: noderef { the leftmost item in the right tree }; next: noderef { the root of that part of the tree not yet split }; temp: noderef; nprio: real { the priority of n }; begin next := q; q := n; if next = nil then begin { trivial enqueue } n^.leftlink := nil; n^.rightlink := nil; end else begin { difficult enqueue } nprio := n^.prio; left := n; right := n; { n's left and right children will hold the right and left splayed trees resulting from splitting on n^.prio; note that the children will be reversed! } if next^.prio > nprio then goto 2; 1: { assert next^.prio <= nprio }; repeat { walk to the right in the left tree } temp := next^.rightlink; if temp = nil then begin left^.rightlink := next; right^.leftlink := nil; goto 999 { job done, entire tree split }; end; if temp^.prio > nprio then begin left^.rightlink := next; left := next; next := temp; goto 2 { change sides }; end; next^.rightlink := temp^.leftlink; left^.rightlink := temp; temp^.leftlink := next; left := temp; next := temp^.rightlink; if next = nil then begin right^.leftlink := nil; goto 999 { job done, entire tree split }; end; until next^.prio > nprio { change sides }; 2: { assert next^.prio > nprio }; repeat { walk to the left in the right tree } temp := next^.leftlink; if temp = nil then begin right^.leftlink := next; left^.rightlink := nil; goto 999 { job done, entire tree split }; end; if temp^.prio <= nprio then begin right^.leftlink := next; right := next; next := temp; goto 1 { change sides }; end; next^.leftlink := temp^.rightlink; right^.leftlink := temp; temp^.rightlink := next; right := temp; next := temp^.leftlink; if next = nil then begin left^.rightlink := nil; goto 999 { job done, entire tree split }; end; until next^.prio <= nprio { change sides }; goto 1; 999: { split is done, branches of n need reversal }; temp := n^.leftlink; n^.leftlink := n^.rightlink; n^.rightlink := temp; end; end { enqueue }; function dequeue( var q: queue ): noderef; label 999 { used for multiple exit loop }; var next: noderef { the next item to deal with }; left, farleft, farfarleft: noderef { nodes to the left of next or q }; begin if q = nil then begin dequeue := nil; end else begin next := q; left := next^.leftlink; if left = nil then begin dequeue := next; q := next^.rightlink; end else repeat { next is not it, left is not nil, might be it } farleft := left^.leftlink; if farleft = nil then begin dequeue := left; next^.leftlink := left^.rightlink; goto 999; end; { next, left are not it, farleft is not nil, might be it } farfarleft := farleft^.leftlink; if farfarleft = nil then begin dequeue := farleft; left^.leftlink := farleft^.rightlink; goto 999; end; { next, left, farleft are not it, rotate } next^.leftlink := farleft; left^.leftlink := farleft^.rightlink; farleft^.rightlink := left; next := farleft; left := farfarleft; until false; 999: { multiple loop exit }; end; end { dequeue }; function message: integer; { *** this function is only included for the use of the test driver *** } begin writeln('Splay Tree'); message := 16384; end { message }; xxxxxxxxxx cat > twolist.code <<\xxxxxxxxxx { twolist.code: The following procedures implement the enqueue and dequeue operations on a priority queue using the two list representation described by John H. Blackstone, Gary L. Hogg, and Don T. Phillips in 'A two-list synchronization procedure for discrete event simulation,' Comm. ACM 24, 12 (Dec. 81), pages 825-829. This code was written by Douglas Jones. This code assumes the declarations in file twolist.type } procedure initqueue( var q: queue ); begin q.sorted := nil; q.unsorted := nil; q.length := 0; q.cutoff := 1.0; q.delta := 2.0; end { initqueue }; function emptyqueue( var q: queue ): boolean; { q is a var param to avoid cumbersome copying; it is not modified } begin emptyqueue := q.length = 0; end { emptyqueue }; procedure enqueue( n: noderef; var q: queue ); label 1 { used for loop exit }; var p: noderef; begin if q.length = 0 then begin q.sorted := n; n^.leftlink := nil; q.cutoff := n^.prio; end else begin if n^.prio > q.cutoff then begin { put new node in unsorted list } n^.leftlink := q.unsorted; q.unsorted := n; end else if q.sorted = nil then begin { put new node in sorted list } q.sorted := n; n^.leftlink := nil; end else if q.sorted^.prio > n^.prio then begin n^.leftlink := q.sorted; q.sorted := n; end else begin { sift new node into sorted list } p := q.sorted; while true do begin if (p^.leftlink = nil) then begin p^.leftlink := n; n^.leftlink := nil; goto 1; end else if p^.leftlink^.prio > n^.prio then begin n^.leftlink := p^.leftlink; p^.leftlink := n; goto 1; end else begin p := p^.leftlink; end; end { while }; 1: { loop exit label } end; end; q.length := q.length + 1; end { enqueue }; function dequeue( var q: queue ): noderef; label 1 { loop exit }; var n, p, r: noderef; moved: integer; begin while q.sorted = nil do begin { unsorted queue must be scanned } q.cutoff := q.cutoff + q.delta; moved := 0; r := q.unsorted; q.unsorted := nil; repeat { scan down old unsorted list, picking out nodes to sort } n := r; r := r^.leftlink; if n^.prio > q.cutoff then begin { put back on unsorted list } n^.leftlink := q.unsorted; q.unsorted := n; end else begin { sift into sorted list } if q.sorted = nil then begin q.sorted := n; n^.leftlink := nil; end else if q.sorted^.prio > n^.prio then begin n^.leftlink := q.sorted; q.sorted := n; end else begin p := q.sorted; while true do begin if (p^.leftlink = nil) then begin p^.leftlink := n; n^.leftlink := nil; goto 1; end else if p^.leftlink^.prio > n^.prio then begin n^.leftlink := p^.leftlink; p^.leftlink := n; goto 1; end else begin p := p^.leftlink; end; end; 1: end; moved := moved + 1; end; until r = nil; if (moved > 0) and (q.length > 4) then q.delta := q.delta*(0.5 + 0.5*( (2*sqrt(q.length)) / moved )); end; p := q.sorted; dequeue := p; q.sorted := p^.leftlink; q.length := q.length - 1; end { dequeue }; function message: integer; { This function is included only for the use of the test driver } begin writeln('Two-List (Blackstone, et al)'); message := 5000; end { message }; xxxxxxxxxx cat > twolist.type <<\xxxxxxxxxx { twolist.type: The following declarations are used by the enqueue and dequeue operations on a priority queue using the two list representation described by John H. Blackstone, Gary L. Hogg, and Don T. Phillips in 'A two-list synchronization procedure for discrete event simulation,' Comm. ACM 24, 12 (Dec. 81), pages 825-829. These were written by Douglas Jones. } noderef = ^node; node = record leftlink: noderef; prio: real; aux: integer; end; queue = record sorted: noderef; unsorted: noderef; length: integer; cutoff: real; delta: real; end; xxxxxxxxxx cat > vaxprocs.h <<\xxxxxxxxxx { vaxprocs.h: An include file for use with Berkeley Pascal; contains declarations of external procedures giving access to the services in section 2 of the UNIX manual (4th BSD), it must be used in conjunction with file 'vaxtypes.h' } procedure getrusage( who: integer; var usage: rusage ); external; xxxxxxxxxx cat > vaxtypes.h <<\xxxxxxxxxx { vaxtypes.h: An include file for use with Berkeley Pascal; contains the type definitions needed by the procedures declared in file 'vaxprocs.h' } rusage = record { see procedure getrusage } utimes { user time seconds }, utimeus { microseconds }, stimes { system time seconds }, stimeus { microseconds }, maxrss, ixrss, idrss, isrss, minflt { minor page faults }, majflt { major page faults }, nswap { number of swaps }, inblock{ block reads }, oublock{ block writes }, msgsnd, msgrcv, nsignals, nvcsw { voluntary context switches }, nivcsw { involuntary context switches } :integer; end; xxxxxxxxxx