ETH

Eidgen6ssische Technische Hochschule

Zurich
Institut fur Informatik

Niklaus Wirth
A COLLECTION
OF PASCAL PROGRAMS

July 1979-

33

ETH

EIDGENOSSISCHE TECHNISCHE HOCHSCHULE

ZORICH

INSTITUT FUR INFORMATIK

NIKLAUS WIRTH

ACOLLECTION

JULY

1979

OF PASCAL PROGRAMS

33

Address of the author:

Institut fUr Informatik
ETH-Zentrum
CH-8092 ZUrich

1979

Institut fUr Informatik der ETH ZUrich

Conlents

Contents
O. Preface
1. Integer arithmetic
power, divide, gcd-Icm, binary ged, j-sqrt

2. Integer arithmetic and arrays

palindromes, magic squares, powers of two, fmctions,
harmonic function, prime numbers, sieve of Eratosthenes

3. Real (floating-point) arithmetic

sum10000, complex multiplication, Fibonacci numbers

4. Analytic functions and iteration

sqrt, logarithm, reciproc<ll value,
exp, sin, cos, arcsin, arctan, In

6. Text processing
printerplot, edit, count wordiengllls, crunch, hilparade

6. Recursion
permute, infix-poslfix, Hilbert curves,

Sierpinsl~i

curves

7. Sorting arrays
slraioht insertion, binary insertion, Shellsort,
straiol1t selection, l1eapsort, bubblesort, shal~ersort,
quicksort, rnergesort

8. Sequential sorting
nalural merge, balanced merge, polyphase merge

9. "Problem solving",

backtracl~ing

eight queens, nonrereating soqUGllces, sLIm of cuhes,

knight's tour, st8ble marriages, optimal selection
10. List and tree structures, pointers
search and insertion in ordered list,
search and insertion in reordering Iisl,
topological sorting, insertion and deletion in binnry troe,
insertion and deletion in bnl,lIlced tree,
insertion and deletion in G-lree, optimal senrcll tree
"11. Cross-reference generators
cross-reference gp.ner8.tor lIsing binary tree
cross-reference generalor using hasll table

12. Syntax an<:tlysis

Syntax analyser and scanner for 1,,1ngu8ge PLIO

o.

Pascnl prn'jrnrns

Preface

This is a collecHon of a wide variety of PaSC81 programs. They ranne in complexity

from simple examples used in introductory courses to illustrate desiqn principles and
Innguage features to intricole eX8111ples discussecl in courncs on 81~Jorithrns ond dntn
structures. The programs, however, are WOllped nccorcling to subjecl rnaller miller
lhon complexity. Many me tahen from the literature listed below, where they are
explained and analyzed in detail.
The main purpose of Ihis bool<let is to provide the tEitlcher of proDrnmming willl [\
condensed collection of exemplary progrmns ancl thereby to exhibit a preferred slyle
of programming using 8 structured Iflngll<1~le. AI the same lime, the bool,let may servo
(IS a guide in inventing other, perhaps similar exercises.
Lnstly, it may be a helpful
reference to some widely used, fundamental algorilhlflS, formulated in detail in a
widely avniloble language.

neferences
N. Wirth, Systematic prowamming.

I\/oorilhms

-I-

Prell!ice+lall, Inc. 1973.

c/vta structures::: programs.

Prentice-Hall, Inc. 1975.

Integer arithmetic

1. Integer arithmetic
1. Raise integer to a positive power. Repeot reading pairs of inlegers, until you
encounter a O. Indicate invariant of loop.
PROGRAM power(input, output);
VAR 8, b: integer;
FUNCTION power (x,n: integer): integer;
VAR w,z,i: integer;
BEGIN w := x; i := n; z := 1;
WHILE i # 0 DO
BEGIN (. z+w'ti = x'tn +)
IF odd(i) THEN z := z'w;
w := sqr(w); i := i DIV 2
END;
power := Z
END (+ power +) ;
BEGIN read(a);
WHILE a # 0 00
BEGIN read(b); writeln(a, b, power(a,b);
read(a)
END
END.

2. Divide an integer by a natural number, using operations of addition, subtraction,

doubling and halving only. Repeal reading pairs of inlegers, until you encounter a O.
For each pair, print dividend, divisor, quotient, and remainder. Indicate invariant of
loop.
PROGRAM divide(input, output);
VAR a,b,Cf,r: integer;
PROCEDURE divide (x,y: integer; VAR z,a: integer);
VAR q,r,w: inleger;
BEGIN r := x; w := y; q := 0;
WHILE w <= r DO w := 2'w;
WHILE w # y DO
BEGIN (+ x = q'w + r t) w:= w DIV 2; q := 2'q;
IF w <= r THEN
BEGI!'I r := r-w; q := q+ 1
END
E!'ID;
Z := q; a := r
END ('divide t ) ;
BEGIN read(a);
WHILE a it 0 00
BEGIN rend(b); divide(a,b,q,r); writeln(a, b, q, r);
read(a)
END
END.

Pascal programs

3. Compute the greatest common divisor (gcd) and the lowest cornman mUltiple (Icm)
01 two natural numbers by using addition and subtraction only. Note thaI ged(rn,n)
lcm(m,n) = m"n. Repeat reading pairs 01 Integers, until you encounter a O. For each
pair, print the arguments, the gcd and lhe tern. Indicate the loop invariant.
PROGRAM gcdlem(input, oUlput);
VAR a,b,c,d: integer;
PROCEDURE gcd(x,Y: integer; VAR u,v: integer);
VAR a,b,c,d: integer;
BEGIN a := x; c := x; b := y; d := y;
WHILE a # b DO
BEGIN (Ogcd(a,b) = gcd(x,y) AND aOd + b"c = 2'x"y')
IF a ) b THEN
BEGIN a := a-b; c := c+d
END
ELSE
BEGIN b := b-a; d := d+c
END
END;
u := a; v := (c+d) DIV 2
END ("gcdmult") ;
BEGIN read(a);
WHILE a # 0 DO
BEGIN read(b); gcd(a,b,c,d); writeln(a, b, c, d);
read(a)
END
END.

4. Compute the greatest common divisor (ged) 01 two natural numbers. Use addition,
subtraction, doubling and halving only.
PROGRAM binarygcd(output);
VAR a.b: integer;
FUNCTION gcd (x,y: integer): integer;
VAR u,v,d, [I,b,I<: integer;
BEGIN u := x; v := y; a := 0; b := 0;
WHILE NOT odd(u) DO
BEGIN u := u DIV 2; a := a+1
END;
WHILE NOT odd(v) DO
BEGIN v := v DIV 2; b := b+1
END;
.
IF a<b THEN k := a ELSE k := b;
d := u - v;
WHILE d # 0 DO
BEGIN REPEAT d := d DIV 2 UNTIL odd(d);
IF d<O THEN v := -d ELSf; u := d;
d := u - v
END;
WHILE k>O DO
BEGIN u := 2u; k := k-1
END;
ged := u
END;

Integer arithmetic

BEGIN read(a);
WHILE a # 0 DO
BEGIN read(b); writeln(a, b, gcd(a,b; read(a)
END
END.

5. Compute the largest integer less or equal to the square rool of a given integer
(due to Hoare).

PROGRAM isqrt(inpul,output);
VAR n,a2,b2,ab,t: integer;
BEGIN read(n);
WHILE n )= 0 DO
BEGIN a2 := 0; ab := 0; b2 := 1; writeln(" n =", n);
WHILE b2 <= n 00 b2 := 4 b2;
WHILE b2 # 1 DO
BEGIN (. a2+2ab+b2 > n, 0 <= a2 <= n, sqr(nb) = a2b2 .)
ab := ab DIV 2; b2 := b2 DIV 4; t := a2 + 2 t ab .,. b2;

<=

IF t
n THEN
BEGIN a2 := t; ab := ab + b2;
END
END;

writeln(a2,ab,b2); read(n)
END
END.

Pascal programs

2. Integer arithmetic and arrays

1, Find all integers between 1 and 1000 whose squares are palindromes.
11t2 = 121, 22t2 = 484.
PROGRAM palindromes(oulpul);
VAR i,i,l,n,r,s: integer;
p: boolean;
d: ARRAY [1 .. 10] OF integer;
BEGIN n := 0;
REPEAT n := n+1; s := nn; I
0;
REPEAT I := 1+1; r := S DIV 10;
d[l] := s - 10r; s := r
UNTIL s :: 0;
i '- l' j '- I'

:=

REPEAT'~ ;= d[i]=d[j];

i := i+1; j := j-1
UNTIL (i> =j) OR NOT p;
IF P THEN wrileln(n,nn)
UNTIL n = 1000
END.
2. Compute and print magic squares of order 3, 6, 7, ...
PROGRAM magics quare (output);
CONST lim = 11;
VAR i,j,x,nx,nsq,n: integer;
m: ARRAY [1 ..lim, 1..lim] OF integer;
PROCEDURE gelsquare;
BEGIN x ::: 0; nsq := sqr(n);
i := (n+1) DIV 2; j := n+1;
REPEAT nx := x + n; j := j-1;
x := X+ 1; m[i,j] := x;
REPEAT i :'" i+1; IF i
n THEN i := 1;
j := j+ 1; IF j > n THEN j := 1;
x := x+ 1; m[i,j] := x
UNTIL x = nx
UNTIL x :: nsq
END (tgetsquare) ;

>

PROCEDURE prinlsquare;
BEGIN
FOR i := 1 TO n DO
.
BEGIN FOR j := I TO n DO wrile(m[i,j]: 6);
wrileln
END;
wrileln
END (tprinlsquare) ;
BEGIN n := 3;
REPEAT getsquare; prinlsquare; n := n+2
UNTIL n > lim
END.

Examples:

Integer arithmetic and arrays

3. Compute a table of positive and negative powers of 2. Exponents range from 1 10,
say, 64. Do not truncate any digilsl
PROGRAM powersoftwo(output);
CONST m = 31; n = 100; (. m = n'log(2) ')
VAR exp,i,j,l: integer;
c,r,l: integer;
d: ARRAY [O.. m] OF inleger; ('positive powers')
f: ARRAY [l .. n] OF inleger; ('negative powers')
BEGIN I := 0; r := 1; d[O] := 1;
FOR exp := 1 TO n DO
BEGIN (. compute and print 2' 'exp') c:= 0;
FOR i := 0 TO 1 DO
BEGIN t := 2'd[i] + c;
IF I )= 10 THEN
BEGIN d[i] := t-10; c := 1
END
ELSE
BEGIN d[i] := I; c := 0
END
END;
IF c > 0 THEN
BEGIN I := 1+ 1; d[l] := 1
END'
FOR i :'= m DOWNTO I DO write(" ");
FOR i := I DOWNTO 0 DO write(d[i]:1);
write(exp:S," .");
('compute and print 2"(-exp) .)
FOR j := 1 TO exp-1 DO
BEGIN r := 10'r + I[j];
r[n := r DIV 2; r ::: r - 2'f[j]; wrile(f[j):l)
END'
r[exp'] := 5; wrileln("S"); r := 0
END
END.

Pascal programs

4. Compute a table of exact fractions 1/2, 1/3, ... , 1/64. If the fraction has a period,
print an apostrophe in front of its first digit and truncate after its last digit.
PROGRAM fractions(output);
(" fractions to the base b ")
CaNST b = 10; max = 64;
VAR i,',n,q,r: integer;
a. f: ARRAY [O..max] OF integer;
BEGIN FOR n := 2 TO max DO
BEGIN I := 0; r := 1;
FOR i := 0 TO n-1 DO a[i] := 0;
REPEAT I := 1+1; 8[r] := I;
r := b"r; q := r DIV n; r := r - q"n; f[l] := q;
UNTIL a[r] # 0;
wrile(n, .. ", ".");
FOR i := 1 TO a[r]-1 DO write(f[i]:1);
IF a[r] > 1 THEN write(" ...... );
FOR i := a[r] TO I DO write(f[i]:1);
writeln
END
END.

5. Compute the harmonic function H(n)

1 + 112 + 113 + ... + 1 In with m digits

accuracy.
PROGRAM harmonic(input,output);
CaNST lim = 100;
VAR i,k,m,n,c,r,q,sum: integer;
d,s: ARRAY [O.. lim] OF integer;
BEGIN read(m,n);
IF (01)0) AND (m(lim) THEN
BEGIN d[O] := 0; s[O] := 1;
FOR i := 1 TO m DO sri] := 0;
FOR k := 2 TO n DO
BEGIN ("compute 11k)" r := 1;
FOR i := 1 TO 01 DO
BEGIN r := 10"r; q := r DIV k; r := r-q"k; d[i] := q
END ;
IF (i0"r DIV k) >= 5 THEN d[m] := d[m]+1; ("round)
write(" 0."); ("intermediate output")
,
FOR i :=1 TOm DO write(d[i]:1);
writeln;
("compule s := s + i/k)" c:= 0;
FOR i := m DOWNTO 0 DO
BEGIN sum := s[i]+d[i]+c;
IF sum >= 10 THEN
BEGIN sum := sum-10; c :=
END
ELSE c := 0;
sri] := sum
END
END;
write(" ", s[0]:1, .....);
FOR i := 1 TO m DO write(s[i]:1);
writeln
END
END.
0

Integer arithmetic and arrays

6. Compute a table of the first n prime numbers.

Print m numbers per line.

PROGRAM primes(output);
CONST n = 1000; n1 = 33; m = 20;
(*n1 - sqrt(n)*)
VAR i,k,x,inc,lirn,square,l: integer;
prim: boolean;
p,V: ARRAY [1..n1] OF integer;
BEGIN I := 0;
x := 1; inc := 4; lim := 1; square := 9;
FOR i := 3 TO n DO
BEGIN (*find next prime*)
REPEAT x := x+inc; inc := 6-inc;
IF square <= x THEN
BEGIN lim := lim+ 1;
v[lim] := square; square := sqr(p[lim+1])
END;
k := 2; prim := true;
WHILE prim AND (k<lim) DO
BEGIN k := k+1;
IF v[k] < x THEN v[k] := v[k] + 2*p[k];
prim := x # v[k]
END
UNTIL prim;
IF i <= n1 THEN p[i] := x;
wrile(x:6); I := 1+1;
IF I = m THEN
BEGIN wrileln; I := 0
END
END;
writeln
END.

10

Pascal programs

7. Compute a table of the first n prime numbers.

method of the sieve of Eratosthenes.

Print m numbers per line.

PROGRAM primes(output);
CONST m = 100; n = 10000; m = 20; h = 58;
VAR x, inc, i,k, x1,x2, lim, square, a,b,l: integer;
P,V: ARRAY [Lm] OF integer;
sieve: SET OF O.. h;
BEGIN I := 0;
x := 1; inc := 4; lim := 1; square := 9;
xi := 0; x2 := 0; sieve := [O.. h];
p[1]:= 2; p[2]:= 3;
FOR i := 3 TO n DO
BEGIN ('"find next prime)'"
REPEAT x := x+inc; inc := 6-inc;
IF x >= square THEN
BEGIN lim := Iim+ 1; a := square; b := 2*p[lim];
WHILE a < x2 DO
BEGIN sieve := sieve - [a-x1]; a := a+b
END'
v[lim] ;= a; square := sqr(p[lim+ 1])
END;
IF x >= x2 THEN
BEGIN ('"construct new sieve)
xi := x2; x2 := x2+h; sieve := [O..h];
FOR k := 3 TO lim DO
BEGIN a := v[k]; b := 2p[k];
WHILE a < x2 DO
BEGIN sieve := sieve - [a-xi]; a := a+b
END;
v[k] := a
END
END
UNTIL x-xi IN. sieve;
IF i <= m THEN p[i] := x;
write(x:6); I := 1+1;
IF 1= m THEN
BEGIN writeln; I := 0
END
END;
writeln
END.

Use the

Real (floating-point) arilhmelic

11

3. Real (floating point) arithmetic

1. Compute the sum 1 - 1/2 + 1/3 - 1/4 + ... - 1/10000 in four different ways:
1. proceed strictly from lerr to right,
2. sum positive and negative terms separately,
3. proceed strictly from right to left,
4. as in 2., but from right to lefl.
Explain the differences in the results.
PROGRAM sum10000(output);
CONST n = 10000;
VAR i: integer; x, y, s1, s2p, s2n: real;
BEGIN i := 1;
sf := 0; s2p := 0; s2n := 0;
REPEAT x := 1.0/i; y := 1.0/(i+ 1);
s 1 := s 1 + x - y;
s2p := s2p + x; s2n := s2n + y;'
i := i+2
UNTIL i > n;
write (sl, s2p-s2n);
i := n;
s1 := 0; s2p := 0; s2n := 0;
REPEAT x := 1.0/(i-1); Y := 1.0/i;
s 1 := s 1 + x - y;
s2p := s2p + x; s2n := s2n + y;
i := ;-2
UNTIL i = 0;
writeln(s 1, s2p-s2n)
END.
2. Multiply the complex number z = 5/13 + 12/13i
50 limes with the complex
number w = (0.6 + 0.8i). Print intermediate products and tile square of theIr absolute
value. Note thai Izi = Iwl = 1.
PROGRAM complexmulI(output);
CONST u = 0.6: v = 0,8;
VAR i,j: integer; x,x1,Y: real;
BEGIN x := 5/13; y := 12/13;
FOR i ::: 1 TO 50 DO
BEGIN FOR j := 1 TO 10 DO
BEGIN (. (x+iy) := (x+iy) (u+iv) ')
x'I := x'u - yv; y := yu + x'v; x := xl
END;
wrileln( x,y ,sqr(x)t-sqr( y
END
END.

12

Pascal programs

3. Compute the Fibonacci numbers F( 1) ... F(N) in two different ways:

1. By repealed addition according to F(n) = F(n-1) + F(n-2), F(O) = F(1)
2. Using the formula F(n) ~ (phitn)/sqrt(5), where phi = (1+sqrt(5))/2.
Terminale as soon as the two results differ.
PROGRAM fibonacci(oulpul);
CONST rool5 = 2.236068;
VAR it fibO, fib1, fib3, t: integer;
phi,lib2: real;
BEGIN phi := (1.0+root5 )/2;
i := 0; fibO := 1; fib 1 := 0; fib2 := 1.0 / root5;
REPEAT i := i+1;
I := fibO+fib I; fibO := fib1; fib1 := t;
fib2 ;= fib2 pili; fib3 := lrunc(fib2 + 0.5);
wrHeln(i, fib1, fib3)
UNTIL fib1 # fib3
END.

1,

Analytic functions and iteralion

4. Analytic functions and iteration

CONST eps

= 1E-8;

FUNCTION sqrt (x:real): real;

VAR a,e: real;
(+ 0<x<2 +)
BEGIN Cl := x; e := 1.0-x;
(+ abs(c)< 1 +)
REPEAT (+ at2 = bO'(1-c) =) (a+(1+e/2t2 = b+(i-e)+(1+e/2)t2 =
b+( 1-0.7S+(et2) - 0.25+(ct3 +)
a := a+( 1.0 + O.Sc);
(O' at2 ::: b+(1-0.7S+(ct2) - 0.25+(c t 3 =
::: b+(1-(ct2)(O.75 + 0.2S+c) +)
e := sqr(c) + (0.75 + 0.2S+c);
(+ at2 = b+(1-c) .)
UNTIL abs(c) < eps;
sqrl := a
END;
FUNCTION log (x: real): real;
VAR a,b,s: real;
(0 1<=x<2 0)
BEGIN a := x; b :::: 1.0; s := 0;
REPEAT (+ log(x) = s + b+log(a), b<=1, 1<=a<2 +)
a := sqr(a);
(0 log(x) = s + b+log(sqrl(a, 1 <=a<4 +)
b := O.S+b;
(+ log(x) = s + b'log(a) +)
IF a >::: 2.0 THEN
BEGIN (+ 2<a<4 +) s := s+b (+ log(x) = s + (1-b)+log(a) ');
a :::: O.S'a
END
UNTIL abs(b) < eps;
log :::: s
END;
FUNCTION recip (x: reat): real;
VAR a,e: real;
(+ 0<x<2 +)
BEGIN a := 1.0; e := 1.0 - x;
REPEAT (+ a*x ::: i-c, abs(c)< 1 +)
a := a(1.0+e); (+ x*a = (1-c)+(1+e) = 1 - ct2 +)
c := sqr(c);
(+ x+a ::: 1-c +)
UNTIL abs(c) < eps;
recip := a (* recip = 1/x +)
END;

13

14

Pascal

programs

Compute analytic functions as truncated sums. Determine the recurrence relations of

their terms.
PROGRAM recurrence(input,outpul);
VAR i,n: inleger; x,Y,s,t: real;
BEGIN
writeln(" exp"); n := 5;
REPEAT read(x); y := 1.0; i := 0; t := 1.0;
REPEAT i:= i+1; t:= tx/i;
y := y + t
UNTIL y+t = y;
writeln(x,Y,i); n:= n-1
UNTIL n = 0;
writeln(" sin"); n := 5;
REPEAT read(x); y := x; i := 1; s := sqr(x); t := x;
REPEAT i := i+2; t := -t's/((i-1 Vi);
y := y + I
UNTIL y+t = y;
wrileln(x,Y, i DIV 2); n:= n-1
UNTIL n = 0;
writeln(" cos'!); n := 5;
REPEAT read(x); Y := 1.0;i := 0; s := sqr(x); 1:= 1.0;
REPEAT i := i+2; t := -t's/((i-1 )'i);

y := y + t

UNTIL y+t = y;
wrileln(x,y, i DIV 2); n:= n-1
UNTIL n = 0;
wrileln(" arcsin"); n := 5;
REPEAT read(x); y := x; i := 1; s := sqr(x); I := x;
REPEAT i := i+2; t := t"s"sqr(i-2)/((i-1)"i);
y := y + t
UNTIL y+t = y;
writeln(x,Y, i DIV 2); n:= n-1
UNTIL n = 0;
wrileln(" arctan"); n := 5;
REPEAT read(x); y := x; i := 1; s := sqr(x); t := x;
REPEAT i := i+2; t := -1's'(i-2)/i;
y := y + I
UNTIL y+l = y;
wrileln(x,Y. i DIV 2); n:= n-1
UNTIL n = 0;
writeln(" In"); n := 5;
REPEAT read{x); x := x-1.0; y := x; t := x; i := 1;
REPEAT i := i+1; t := -t'x"(i-1)/i;
y := y + t
UNTIL y+t = y;
wrileln(x+ 1.0, Y, i); n:= n-1
UNTIL n = 0;
END.

Texl processing

15

5. Text processing
1. Plot the function f(x) = exp(-x) cos(2pjx) with your line printer in the range x
Use 32 lines for the unit coordinate.

= 0 ... 4.

PROGRAM printerplot( output);

CONST xscale = 32;
yscale = 50; ysl1Ht = 65;
twopi = 6.2831833071796;
VAR i,k,n: integer;
x,y: real;
BEGIN n := 0; (. n = x position .)
REPEAT x := n / xscale;
y := exp(-x)cos(xlwopi); k := round(yyscFlle);
i := 0; write(" "); (. i = no of chars in fine .)
IF k < 0 THEN
BEGIN write(" ": yshifl+k); write("");
k := -k-1; IF k > 0 THEN write(" ":k);
write("I")
END ELSE
BEGIN write(" ": yshifl);
IF k > 0 THEN
BEGIN write(',!,'); k := k-1;
IF k > 0 THEN write(" ":k)
END;
write("")
END;
writeln; n := n+1
UNTIL n > 96
END.
2. Read a text and cOLint the number of words with length 1, 2, ... , 20, and those with
lenglh greater than 20. Words are separated by blanks or ends of lines.
PROGRAM wordlenglhs(input,output);
VAR i,k: inleger;
eh: char;
coun!: ARRAY [1 .. 21] OF integer;
BEGIN
FOR i := 1 TO 21 DO counl[i] := 0;
WHILE NOT eof(input) DO
BEGIN read(ch);
IF ("a"<=eh) AND (eh<="z") THEN
BEGIN (new word) k := 0;
REPEAT k ::: k+1; read(ch)
UNTIL (ell("a") OR ("z"<ch) ;
IF k > 20 THEN 1< := 21;
eOllnt[k] := counl[k] + 1
END
END;
wrileln;
wrileln("
length
count");
TO 21 DO writsln(i,count[i])
FOR i:=
END.

16

Pascal programs

3. Read a text and produce a copy with flushed left and right margins. Place a fixed
number of characters (say, length = 72) in each line, and distribute blanks as word
separators accordingly.
PROGRAM edil(inpul,oulput);
CONST length = 72;
VAR ch: char;
i,m,k,lim: integer;
line: ARRAY [1..136] OF char;
index: ARRAY [1 .. 68] OF integer;
PROCEDURE sellina;
VAR i,j,h,s: integer;
spaces, q,I,r: integer;
BEGIN IF m=O THEN
BEGIN (word is longer than line) m := 1; index[m] := lim
END;
j := 0; write(" "); ('printer control)'
IF m ) 1 THEN
BEGIN spaces := lim - index[m];
q := spaces DIV (m-1); r := spaces - (m-1)'q;
I := (m-r) DIV 2; r := l+r; ('distribute spaces)
i '- o
REPEAT i := i+ 1; s := index[i];
REPEAT j := j+ 1; wrile(line[iJ}
UNTil j = s;
FOR h := 1 TO q DO wrile(" or);
IF (I<=i) AND (i<r) THEN wrile(" or);
UNTIL i = m-1
END;
s := index[m] -1;
REPEAT j := j+1; write(line[j])
UNTIL j = s;
j := 0; wrileln;
FOR h := index[m]+1 TO lim DO
BEGIN j := j+ 1; line[j] := line[h]
END;
k := j; m := 0
END (selline) ;
BEGIN lim := lenglh+1;
k := 0;
(I~ = no. OF characters IN line)'
m := 0;
(m = no. OF complete words IN line)
WHILE NOT eof(input) DO
BEGIN read(ch);
IF ch # " " THEN
BEGIN (next word)'
REPEAT k := kt1; Hne[k] := ch; read(ch);
IF k = lim THEN setline
UNTIL ch = " or;
k := k+l; line[k] := " or;
m:= m+1; index[m]:= k;
IF k = lim THEN salline
END
END;
write(" "};
FOR i := 1 TO I~ DO write(line[i]);
writeln

Text processing

17

END.
4. Read a text and replace any sequence of one or more blanks by a single blank.
PROGRAM crunch(input,oulpul};
CONST blank = .. It;
VAR ch: char;
BEGIN
WHILE NOT eof(input} DO
BEGIN read(ch); write(blanl~}; ('printer control')
WHILE ch = blank DO read( ch};
WHILE NOT eoln(input) DO
BEGIN
REPEAT write(ch}; read(ch}
UNTIL ch = blank;
wrile(blank};
WHILE (ch:blank) AND NOT eoln(input} DO read(ch)
END;
writeln; read(ch)
END
END.

18

Pascal . programs

5. A record company conducts a poll 10 evaluale its products. The most popular hits
are to be broadcast in a hit parade. The polled population is divided into four
categories according to sex and age (teenager <= 20, adult> 20). Each person is
asked to list five hils, identified by their number between 1 and, say, 50. The result
of the poll is presented as a file; each record lists a respondent's name, first name,
sex, age, and his choices ordered according to priority. A program is to compute the
following dala:

1. A list of hits ordered according to popularity. Each entry consists of the hit
number and the number of votes il received. Hits not mentioned are omitted.
2. Four separate Iisls with names and first names of all respondents who had
mentioned in first place one of the three hils most popular in lheir calegory.
PROGRAM hitparade(poll ,oulput);
CONST n = 50; (.. number of hils .. )
TYPE sex = (male, female);
hilno = 1 ., n;
query = RECORD
name, firstname: alia;
s: sex;
age: 0 .. 99;
choice: PACKED ARRAY [1..5] OF hilno
END;
VAR i,k,max: inleger;
b: boolean;
tolal: ARRAY [hilno] OF integer;
coun!: ARRAY [sex,boolean,hitno] OF integer;
poll: FILE OF query;
PROCEDURE findnames(x: sex; y: boolean);
VAR i,i,k: integer;
selection: SET OF hilno;
BEGIN selection := [J; reset(poll);
wrileln(" ---------- -------- ------- - -------- ---- ");
( .. find 3 hits most frequenlly listed in this group .. )
FOR i := 1 TO 3 DO
BEGIN max := 0;
FOR j ;= 1 TO n DO
IF max < count[x,y,j] THEN
BEGIN max := count[x,y,j]; k := j
END'
selection' := selection + [k]; count[x,y,k] := 0
END;
(" lisl persons with one of these hils as firsl choice .. )
WHILE NOT eof(poll) DO
BEGIN
WITH pollt DO
IF s = x THEN
IF (age >= 20) = y THEN
IF choice[ 1] If\! selection THEN
writeln(" ",name," ",firslname);
get(poll)
END
END ("findnames") ;
BEGIN resel(poll);
FOR i := 1 TO n DO
BEGIN total[i] := 0;

Text processing

counl[male,true,i] := 0; count[fernnle,true,i] := 0;
counl[male,false,i] := 0; counl[female,false,i] := 0
END;
(0 collect counts .)
WHILE NOT eof(poll} DO
BEGIN
WITH pollt DO
FOR i := , TO 5 DO
BEGIN b := age >= 20; k := choice[i];
counl[s,b,I<] := counl[s,b,k] + 1
END;
gel(pol/)
END'
(. co;"pule lolals .)
FOR i := 1 TO n DO
tolal[i] := counl[rnale,lrue,i] + counl[fernale,true,i]
+ count[male,false,i] + counl[female.false,i];
page( output);
writeln(" reporl on hit popularity poll");
writeln(" lisl of hits ordered after popularilY");
writeln("
hit
frequency");
REPEAT max := 0; k := 0;
FOR i := 1 TO n DO
IF max < lolal[i] THEN
BEGIN max := lolal[i]; k := i
END;
IF max > 0 THEN
BEGIN tolal[k] := 0; writeln(k, max)
END;
UNTIL max = 0;
writeln(" nmnelists separate by sex and age");
writeln(" men "); findnames(male,lrue);
writeln(" women"); lindnames(female,true);
writeln(" boys "); findnames(nlClle,false);
writeln(" girls"); findnames(female,false);
wrileln(" end of report"}
END.

19

20

Pascal programs

6. Recursion
1. Compute all nl permutations of the integers 1 ... n.
PROGRAM permute(oulpul);
CONST n == 4;
VAR i: inleger;
a: ARRAY [i .. n] OF integer;

PROCEDURE print;
VAR i: integer;
BEGIN FOR i :== 1 TO n DO wrile(a[i]:3);
write1n
END (prinl) i
PROCEDURE perm(k: inleger);
VAR i,x: integer;
BEGIN
IF k = 1 THEN print ELSE
BEGIN perm(k-i);
FOR i := 1 TO k-1 DO
BEGIN x := a[i]; a[i] := ark]; ark] := x;
perm(k-1 );
x := a[i]; a[i] := ark]; ark] := Xi
END
END
END (perm) ;
BEGIN
FOR i := 1 TO
perm(n)
END.

n DO a[i] := i;

Recursion

21

2. Convert expressions from infix to postfix form. Each expression Is written on a

separate line. Expressions have the following syntax:
expression =
term =
factor =

term {("+"'''='') term}.

factor {"'" factor}.
leiter I "(" expression ")".

PROGRAM postfix(input,output);
VAR ch: char;
PROCEDURE expression;
V AR op: char;
PROCEDURE factor;
BEGIN IF ch = "(" THEN
BEGIN read(ch); expression; read(ch) (.) .)
END ELSE
BEGIN wrile(ch); read(ch)
END
END (* factor .. ) ;
PROCEDURE term;
BEGIN factor;
WHILE eh = .... " DO
BEGIN read(ch); factor; write( .. .. )
END
END (. term .) ;
BEGIN term;
WHILE (ch="+") OR (ch="-") DO
BEGIN op ;= cll; read(ch); term; write(op)
END
END (. expression .) ;
BEGIN
WHILE NOT eof(input) DO
BEGIN wrile(" "); read(ch); expression; writeln; readln
END
END.

22

Pascal programs

3. Plot Hilbert curves of orders 1 '" n. Plot procedure produces oulpul for the
Teklronix 4010 lerminal. Dala are represented as 12-bil bytes: a call of procedure
p 12 appends a byle to lhe oulput file.
PROGRAM hilbert(pf,oulpul);
CONST n = 4; hO = 512;
VAR i,h,x,y,xO,YO: inleger;
ce t we, buf: integer;
pf: FILE OF integer;
(Oplot file O)
PROCEDURE p12(u: inleger);
BEGIN buf := buf 4096 + u; ce:= cc + 1;
IF cc = 5 THEN
BEGIN pft := buf; put(pf);
we := we+1; buf := 0; cc := 0;
IF we = 31 THEN
BEGIN ph := 0; put(pf); we := 0
END
END
END ('p12+) ;
PROCEDURE plol;
VfiR u,v: integer;
BEGIN u := x DIV 32; v := y DIV 32;
p12(40b+v); p12(140b+y-32+v);
p 12(40b+u); p12( 100b+x-32+u);
END ("plot") ;
PROCEDURE selplol;
BEGIN p12(35b); pial
END;
PROCEDURE slartplo1;
BEGIN ec := 0; wc := 0; buf := 0; rewrile(pf)
END;
PROCEDURE endplol;
BEGIN x := 0; y := 767; selplol; p12(37b);
REPEAT p12(0) UNTIL cc = 0
END;
PROCEDURE b(i: integer); FORWARD;
PROCEDURE c(i: inleger); FORWARD;
PROCEDURE d(i: integer); FORWARD;
PROCEDURE a(i: inleger);
BEGIN IF i > 0 THEN
BEGIN d(i-1); x := x-hi plot;
a(i-1); y := y-h; pial;
a(i-1); x := x+h; plot;
b(i-1)
END
END;
PROCEDURE b;
BEGIN IF ; > 0 THEN
BEGIN c(i-1); Y := y+h; plol;
b(i-1); x := x+h; plot;

Recursion

b(i-1); y := y-h; plot;

a(i-1 )

END
END;
PROCEDURE c;
BEGIN IF i ) 0 THEN
BEGIN b(i-1); X := x+h; plot;

c(i-1); y := y+h; plot;

c(i-1); X := x-h; plot;
d(i-1 )
END
END;
PROCEDURE d;
BEGIN IF i ) 0 THEN
BEGIN a(i-1); y := y-h; plot;

d(i-1); X := x-h; plot;

d(i-1); y := y+h; plot;
c(i-1 )
END

END;
BEGIN slarlplot;
i := 0; h := hO; xO := h DIV 2 + h; yO := h DIV 2;
REPEAT (plot hilbert curve OF order j*)
i := i+ 1; h := h DIV 2;
xO := xO + (h DIV 2); yO := yO ... (h DIV 2);

x := xO; y := yO; setplot;

a(i)
UNTIL i = n;
endplot
END.

23

24

Pascal programs

4. Plot Sierpinski space-filling curves using their recursive pallern.

identical to lhe one used in the preceding program.
PROGRAM sierpinski(pf,oulpul);
CONST n = 4; hO = 512;
YAR i,h,x,Y,xO,YO: integer;
CC, wc, bur: integer;
eplot file)
pr: FILE OF integer;
PROCEDURE p12(u: integer);
BEGIN buf := buf 4096 + u; ec:= cc + 1;
IF cc = 5 THEN
BEGIN ph := bur; put(pf);
we := wc+1; buf := 0; cc := 0;
IF we = 31 THEN
BEGIN pf t := 0; put(pf); we := 0
END
END
END (*p12) ;
PROCEDURE plot;
YAR u,v: integer;
BEGIN u := x DIV 32; v := y DIY 32;
p12(40b+v); p12(140b+y-32v);
p12(40b+u); p12(100b+x-32u);
END (pIOI) ;
PROCEDURE setplot;
BEGIN p12(35b); plot
END;
PROCEDURE startplot;
BEGIN ee := 0; wc := 0; bur := 0; rewrite(pf)
END;
PROCEDURE end pial;
BEGIN x := 0; y := 767; selplol; p12(37b);
REPEAT p12(0) UNTIL cc = 0
END;
PROCEDURE b(i: integer); FORWARD;
PROCEDURE c(i: integer); FORWARD;
PROCEDURE d(i: integer); FORWARD;
PROCEDURE a(i: integer);
BEGIN IF i ) 0 THEN
BEGIN a(i-1); x := x+h; y := y-h; plot;
b(i-1); x := x + 2h; pial;
d(i-1); x := x+h; y := y+h; plot;
a(i-1)

END
END;
PROCEDURE b;
BEGIN IF i ) 0 THEN
BEGIN b(i--1); x := x-h; y := y-h; plot;
c(i-1); y := Y - 211; plot;

Plot routine is

Recursion

a(i-1); X := x+h; y ::: y-h; plot;

b(i-1)
END
END;
PROCEDURE c;
BEGIN IF i
0 THEN
BEGIN c(i-1); X := x-h; y ::: y+h; plol;
d(i-1); X := X - 2 +11; plot;
b(i-1); X := x-h; y := y-h; plol;
c(i-1 )
END
END;

>

PROCEDURE d;
BEGIN IF j
0 THEN
BEGIN d(i-1); X := x+h; y := y+hi plot;
a(i-1); y := y + 2+11; plot;
c(i-1); X := x-h; y := y+h; plOI;

>

d(i-1 )
END
END;
BEGIN slarlplol;
i := 0; h := hO DIV 4; xO ::: 2+h; yO := 3+h;
REPEAT i := i+ 1; xO := xO-h;
h := 11 DIV 2; yO ::: yO+h;
x := xO; y := yO; selplol;
a(i); x := x+h; y := y-h; plot;
b(i); X ::: x-h; y := y-h; plot;
c(i); x := x-h; y := y+h; plot;

d(i);
UNTIL i
endpJot
END.

:= x+h; y := y+h; plot;

= n;

25

26

Pascal programs

7. Sorting arrays
Reference: N.Wirlh, Algorithms + Data Structures

= Programs,

Prentice-Hall, Inc., 1975

PROGRAM sort(output);
CONST n = 256; nn = 512;
TYPE index = O.. nn;
item = RECORD key: integer;
(tother fields defined here)
END;
VAR i : index; r: integer;
a: ARRAY [-15.. nn] OF item;
z: ARRAY [1 ..n] OF integer;
PROCEDURE teste t: alia; PROCEDURE sort);
VAR i,z: integer;
BEGIN write(" ", 0;
FOR i := 1 TO n DO a[i].key := i;
z := clock; sort; write( clock-z);
FOR i := 1 TO n DO a[i].key := z[i];
z := clock; sort; write( clock-z);
FOR i := 1 TO n DO a[i].key := n-i;
z := clock; sort; writeln(clock-z);
END (testO) ;
PROCEDURE slraightinsertion;
VAR i,j: index; x: item;
BEGIN
FOR i := 2 TO n DO
BEGIN x := a[i]; e[O] := x; j := i-1;
WHILE x.l~ey < a[j].l<ey DO
BEGIN a[j+1) := a[j]; j := j-1;
END'
a[j+1] :~ x
END
END;
PROCEDURE binaryinserlion;
VAR i,j,I,r,m: index; x: item;
BEGIN
FOR i := 2 TO n DO
BEGIN x := a[i); I := 1; r := i-1;
WHILE I <= r DO
BEGIN m := (I+r) DIV 2;
IF x.key < a[m]'key THEN r := m-1 ELSE I := m+ 1;
END;
FOR j := j-1 DOWNTO I DO a[j+1] := a[j];
a[l] := x;
END
END;

Sorting arrays

PROCEDURE shellsort;
CONST t = 4;
VAR i,j,k,s: index; x: item; m: 1..t;
h: ARRAY [1..1] OF integer;
BEGIN h[ 1] := 9; h[2] := 5; h[3] := 3; h[ 4] := 1;
FOR rn := 1 TO t DO
BEGIN k := hem]; s := -k; (sentinel position)
FOR i := k+ 1 TO n DO
BEGIN x := a[i]; j := i-k;
IF s=O THEN s := -k; s := s+l; a[8] := x;
WHILE x.key < a[j].key DO
BEGIN a[j+k] := a[j]; j:= j-k
END;
a[j+k] := x
END
END;
END ;
PROCEDURE slraightselection;
VAR i,j,k: index; x: item;
BEGIN FOR i := 1 TO n-1 DO
BEGIN k := i; x:= a[i];
FOR j := i+1 TO n DO
IF a[j].key < x.key THEN
BEGIN k := j; x := a[j]
END;
ark] := a[i]; a[i] := x;
END
END;
PROCEDURE heapsort;
VAR I,r: index; x: item;
PROCEDURE sift;
LABEl 13;
VAR i,j: index;
BEGIN i := I; i :0= 2'"i; x := a[i];
WHILE j <= r DO
BEGIN IF j < r THEN
IF a[j].key < a[i+ 1 ].key THEN j := i+ 1;
IF x.key >= a[j].key THEN GOTO 13;
a[i] := a[iJ; i := j; j := 2 t j
END;
13: a[i] := x
END;
BEGIN I := (n DIV 2) + 1; r := n;
WHILE I > 1 DO
BEGIN I := 1-1; sir!
END;
WHILE r ) 1 DO
BEGIN x := a[I]; a[l] := a[rJ; a[r] := x;
r := r-1; sirt
END
END ('"heapsorl'") ;

27

28

Pascal . programs

PROCEDURE bubblesorl;
VAR i,j: index; x: item;
BEGIN FOR i := 2 TO n DO
BEGIN FOR j := n DOWNTO i 00
IF a[j-1 ].key > a[j].key THEN
BEGIN x ::::: a[j-1]; a[j-1] ::::: a[j);
END;
END
END (+bubblesorl+) ;

a[j] :=

PROCEDURE bubblex;
VAR j,k,l: index; x: item;
BEGIN I := 2;
REPEAT k := n;
FOR j := n DOWNTO , DO
IF 0[j-1 ].key > a[n.key THEN
BEGIN x := a[j-1]; a[j-1] := a[j}; a[j] := x;
k:= j
END;
I := k+1
UNTIL'
n
END (+bubblex+) ;

>

PROCEDURE shakersorl;
VAR j,k,l,r: index; x:ilem;
BEGIN I := 2; r := n; k := n;
REPEAT
FOR j := r DOWNTO , DO
IF a[j-1 ].key > a[j].key THEN
BEGIN x := a[j-1]; a[j-1] := a[j); aD] := x;
k := j
END;
, := k+1;
FOR j := I TO r DO
IF a[j-1 ].key > a[j].key THEN
BEGIN x := a[j-1]; a[j-1] := a[j); aD] := x;
k := j
END;
r := k-1;
UNTIL I > r
END (+shakersorl*) ;

Xj

Sorting arrays

PROCEDURE quicksort;

(recursive)

PROCEDURE sort(I,r: index);

VAR i.j: index; x,w: item;
BEGIN i := I; j := r;
x := a[(I+r) DIV 2];
REPEAT
WHILE a[i].key < x.key DO i := i+1;
WHILE x.key < a[j].key DO j := j- I ;
IF i <= j THEN
BEGIN w := a[i]; a[i] := a[j]; a[j] := w;
i := i+1; j := j-I
END
UNTIL i
j;
IF I
j THEN sorl(I,j);
IF i < r THEN sorl(i,r)
END;

<

>

BEGIN sort(1,n)
END (quicksort) ;
PROCEDURE quicksort1;
CONST m = 12;
VAR i,j,I,r: index;

(. non-recursive)

x,w: item;
s: 0 .. m;
stack: ARRAY [1 ..m] OF
RECORD l,r: index END;
BEGIN s := "; stack[ 1].1 := 1; stack[ 1].r := n;
REPEAT (tal~e lop request from stack)

I := stack[s].l; r := stack[s].r; s := s-I;

REPEAT (split a[l] ." a[r])
i := I; j := r; x := a[(IH) DIV 2];
REPEAT
WHILE
WHILE
IF i
BEGIN

<=

a[i].key < x.key DO i := i+";

x.key < a[j].key DO j := j-1;
j THEN

w := a[i]; a[i] := a[j]; an] := w;

i := 1+1; j := j-1
END
UNTIL i
j;
IF i < r THEN
BEGIN (slack request 10 sort right partition)

>

s := s+1; stack[s].1 := i; stacl~[s].r := r

END;
r := j
UNTIL I )= r
UNTIL s = 0
END (quicksort"') ;

29

30

Pascal programs

PROCEDURE mergesorl;
VAR i,j,k,l,t: index;
h,m,p,q,r: integer; up: boolean;
('nole that a has indices 1..2n)
BEGIN up := true; p := 1;
REPEAT h := 1; m := n;
IF up THEN
BEGIN i := 1; j := n; k := n+1; 1:= 2"n
END ELSE
BEGIN k := 1; I := II; i := n+1; j := 2'n
END
REPEAT ("merge a run from i ~md j to k")
('q = length of i-run, r = length of j-run")
IF m )= p THEN q := p ELSE q := m; m:= m-q;
IF m ): p THEN r := p ELSE r := m; m:: m-r';
WHILE (q#O) AND (r#O) DO
BEGIN ("merge")
IF a[i].key < a[j].key THEN
BEGIN a[k] := a[i]; k := k+h; i := i+1;'q :: q-1;
END ELSE
BEGIN a[k] ::: a[j]; k := k+h; j := j-1; r := r-1;
END
END;
IF q = 0 THEN
BEGIN ('copy tail of j-run")
WHILE r # 0 DO
BEGIN a[k] := a[j]; k := k+h; j := j-1; r := r-1;
END
END ELSE
BEGIN (+r = 0, copy tail of i-run")
WHILE q # 0 DO
BEGIN ark] := a[i]; k := k+h; i := i+1; q := q-1;
END
END;
h := -hi t := k; k := I; I := t
UNTIL m = 0;
up := NOT up; p := 2"p
UNTIL p )= n;
IF NOT up THEN
FOR i := 1 TO n DO a[i] := a[i+n]
END (+mergesort") ;
BEGIN i := 0; r := 54321;
REPEAT i := i+1;
r := (131071+r) MOD 2147483647; z[i] := r
UNTIL i :: ,n;
test("slr insert", straightinsertion);
test("bin insert", binaryinsertion);
lesl("shell sort", shellsort);
lesl("slr selecl", straightselection);
lest("heapsort ", heapsart);
lesl("bubblesort", bubblesort);
test("bubblesort", bubblex);
test("shal(ersorl", shakersorl);
test("Quicksorl ", qUicksort);
test("quicksorU", quicksor(1);
lest("mergesort ", mergesort);
END.

31

Sequentlal sorting

8. Sequential sorting
1. Natural merge sort wilh 3 files (lapes) and 2 phases.
PROGRAM mergesort(input,output);
TYPE item = RECORD key: inleger
(tother fields defined here t )
END;
lape = FILE OF item;
VAR C: lape; n: bur: item;
PROCEDURE Iist(VAR f: lape);
VAR x: ilem;
BEGIN reset(f);
WHILE NOT earn) DO
BEGIN read(r,x); wrile(output, x.key: 4)
END;
.
wrileln
END ('Iist t ) ;
PROCEDURE nlturalmerge;
VAR I: integer; (t no. at runs mergedO)
ear: boolean; (Oend-ot-run indicalorO)
a,b: lape;
PROCEDURE copy(VAR x,y: tape);
VAR bur: item;
BEGIN reacl(x, but); wrile(y,but);
IF eor(x) THEN ear := true ELSE ear := buf.key
END;
PROCEDURE copyrun(VAR x,y: tape);
BEGIN (Ocopy one rllll from x 10 yO)
REPEAT copy(x,y) UNTIL ear
END;
PROCEDURE dislribute;
BEGIN ('rrom c 10 a and b')
REPEAT copyrun(c,a);
IF NOT eot(c) THEN copyrull(c,b)
UNTIL eor(c)
END;
PROCEDURE mergerun;
BEGIN ('from a and b to ct)
REPEAT
IF at .key ( bt .key. THEN
BEGIN copy(a,c);
IF ear THEN copyrun(b,c)
END ELSE
BEGIN copy(b,c);
IF ear THEN copyrun(a,c)
END
UNTIL ear
END;
PROCEDURE merge;
BEGIN ('from a and b to c')

> xt .key

32

Pascal programs

REPEATmergerun; I := 1+1
UNTIL eof(a) OR eof(b);
WHILE NOT eof(a) DO
BEGIN copyrun(a,c); I := 1+1
END;
WHILE NOT eof(b) DO
BEGIN copyrun(b,c); I := 1+1
END;
list(c)
END;
BEGIN
REPEAT rewrite(a); rewrile(b); reset(c);
dislribute;
resel(a); reset(b); rewrite(c);
I ;= 0; merge;
UNTIL I = 1
END;
BEGIN ('main program. read input sequence ending with 0')
rewrite(c); read(buf.key);
REPEAT wrile(c, buf); read(buLkey)
UNTIL buLkey = 0;
Iist(c);
naturalmerge;
Iist(c)
END.

Sequential sorting

33

2. Sequential sorting by n-way mergesorl. In each phase, data are merged from n/2
files and distributed onto the other n/2 files. The program starls with the generation
of a single file with random numbers.
PROGRAM balancedrnerge( output);
CONST n = 6; nh = 3;
(no. of tapes')
TYPE item = RECORD
key: integer
END'
tape = I=ILE
item;
tapeno = 1..n;
VAR leng, rand: integer;
('used to generate file')
eat: boolean;
but: item;
fO: tape; ('fO is the input tape with random numbers')
f: ARRAY [1..n] OF tape;

OF

PROCEDURE list(VAR t: tape; n: tapeno);

VAR z: inleger;
BEGIN wrileln(" tape", n:2); z := 0;
WHILE NOT eof(f) DO
BEGIN read(f, buf); wrile(outpul, buf.key: 5); z := z+1;
IF z = 25 THEN
BEGIN writeln(outpul); Z := 0;
END;
END;
IF z # 0 THEN writeln(output); reset(f)
END (Iist) ;
PROCEDURE tapemergesorl;
VAR i,i,mx,tx: tapeno;
k 1,k2,1: integer;
x, min: integer;
I, ta: ARRAY [tapeno] OF tapeno;
BEGIN ('distribute initial runs to t[1] ... t[nh]*)
FOR i := 1 TO nil DO rewrile{f[i]);
j := nh; I := 0;
REPEA T IF j < nh THEN j := j+ 1 ELSE j := 1;
('copy one run from fa to lape j')
, := 1+1;
REPEAT read(fO, buf); wrile(f[J], buf)
UNTIL (buf.key > fat .key) OR eof(fO)
UNTIL eot(fO);
FOR i := 1 TO n DO lei] := i;
REPEAT ('merge from 1[1] ... t[nll] to t[nh+1] ... l[n]*)
IF I < nh THEN k1 := I ELSE k1 := nh;
('k1 = no. of input tapes in this phase')
FOR i := 1 TO k 1 DO
BEGIN resel(f[t[i]]); list(f[t[i]], t[i]); ta[i] := t[i]
END;
f := 0;
(" = number of runs merged")
j := nll+ 1;
("j == index of output tape')
REPEAT ('merge a run from 1[1] '0' l[k1] TO L[j]')
k2 ;= k1; 1:== 1+1; ('k2 = no. of active input tapes')
REPEAT ('select minimal element')
i :== 1; mx := 1; min := f[La[1]]t.key;
WHILE: i < k2 DO
BEGIN i := i+1; x := f[ta[i]]t.key;

34

Pascal programs

IF X < min THEN

BEGIN min := x; mx:= i
END
END;

('ta[mx] has minimal element, move it to t[j]')

read(f[ta[mx]J, bur); eat := eof(f[ta[mxJ]);
wrile(f[l[j]], but);
IF eot THEN
BEGIN rewrile(f[ta[mx]]); ('eliminate tape)
ta[mx] := ta[k2]; ta[k2] := ta[kl];
kl := kl-l; k2 := k2-1
END ELSE
IF buf.key
f[ta[mx]]t .key THEN
BEGIN tx := ta[mx]; ta[mx] := ta[k2J; ta[k2J := Ix;

>

k2 := k2-1
END
UNTIL k2 = 0;
IF j < n THEN j := j+l ELSE j:= nh+1
UNTIL k1 = 0;
FOR i := 1 TO nh DO
BEGIN tx := lei]; t[i] := t[i+nh]; l[i+nh] := tx

END

= 1;
reset(f[1[1]]); list(f[I[lJ], l[lJ);

UNTIL I

('sorled oulput is on t[l])

END ('lapemergesort') ;
BEGIN ('generate random fjle fO')

leng := 200; rand := 7789; rewrile(fO);

REPEAT rand := (131071'rand) MOD 2147483647;

buLkey := rand DIV 2147484; write(fO, buf); leng := leng - 1

= 0;
reset(fO); Iisl(fO,l);
tapemergesort;

UNTIL leng

END.

Sequential sorling

35

3. Polyphase sort program. There are n-1 source files for merging and a single
output file. The destination of the merged data changes, when a certain number of
runs has been distributed.
This number is computed according to a Fibonacci
distribution.
PROGRAM polysorl(autput);
CONST n = 6;
('no. of tapes')
TYPE item = RECORD
key: integer
END;
tape = FILE OF Hem;
tapeno = l .. n;
VAR leng, rand: integer;
('used 10 generate file')
eat: boolean;
buf: item;
fO: tape; ('fO is the input tape with random numbers')
f: ARRAY [1..n] OF tape;
PROCEDURE Iist(VAR f: tape; n: tapeno);
VAR z: integer;
BEGIN z := 0;
writeln(" tape", n:2);
WHILE NOT eof( f) DO
BEGIN read(f, buf); write(autput, buf.key: 5); z := z+ 1;
IF z = 25 THEN
BEGIN writeln(autptlt); z := 0
END;
END;
IF z # 0 THEN writeln(autput}; reset(f)
END ('list') ;
PROCEDURE palyphasesart;
VAR i,j,mx,tn: tapeno;
k, level: inleger;
a, d: ARRAY [tapeno] OF integer;
('a[i] = ideal number of runs on tape j')
('d[n = number of dummy runs on tape j')
dn, x, min, z: integer;
last: ARRAY [tapena] OF integer;
('last[iJ = key of tail item on lape it)
t,ta: ARRAY [tapena] OF tapena;
('mappings af tape numbers')
PROCEDURE selecttape;
VAR i: tapena; z: integer;
BEGIN
IF d[j] < d[j+ 1] THEN j := j+ 1 ELSE
BEGIN IF d[;] = 0 THEN
BEGIN level := level + 1; z := a[l];
FOR i := 1 TO n-1 DO
BEGIN d[i] := z + a[i+1] - a[i]; a[i] := z + a[i+1]
END
END;
j := 1
END;
d[n := d[j] -1
END;

36

Pascal programs

PROCEDURE copyrun;
BEGIN (copy one run Irom 10 to tape j")
REPEAT read(IO, bur); write(l[iJ, bul);
UNTil eol(fO) OR (buLkey ) fOt .key);

lasl[j] := buLkey
END;
BEGIN (distribute initial runs")
FOR i := 1 TO n-1 DO
BEGIN a[i] := 1; d[i] := 1;' rewrile( I[i])
END;

level := 1; j := 1; a[n] := 0; den] := 0;

REPEAT selecllape; copyrun
UNTIL eol(lO) OR (j=n-1);
REPEAT selecllape;
IF lasl[j] <= rot.key THEN
BEGIN ("continue old run")

copyrun;
IF eol(fO) THEN d[j] := d[j] + 1 ELSE copyrun
END
ELSE copyrun
UNTIL eol(lO);
FOR i := 1 TO n-1 DO reset(f[i]);
FOR i := 1 TO n DO t[i] := i;
REPEAT ('merge from t[1] ... l[n-1] to t[n]*)
z := a[n-1]; den] := 0; rewrite(l[t[n]]);

writeln(" level", level:4," lape", l[n]:4);

FOR i := 1 TO n DO wrileln(l[i], a[i], d[i]);
REPEAT k := 0; ("merge one run)
FOR i := 1 TO n-1 DO
IF d[i] > 0 THEN d[i] := d[i]-1 ELSE
BEGIN k := k+1; taCk] := I[i]
END;
IF k = 0 THEN den] := den] + 1 ELSE
BEGIN ("merge one real run Irom t[1] ... t[k]")
REPEAT i:= 'I; mx:= 1;

min := f[ta[ 1]] t .I<ey;

WHILE i < 1< DO

BEGIN i := i+1; x := I[ta[i]]t.key;
IF x < min THEN
BEGIN min := x; mx := i
END
END'

("ICi[';'X] contains minimal elemenl, move it 10 I[n] ')

read(f[ta[mx]]. 'bul); eot := eol(l[ta[mx]]);
wrile(f[t[n]], but);
IF (buLkey ) I[ta[mx]]t.key) OR eot THEN
BEGIN (drop this tape')
ta[mx] := taCk]; k := k-1
END
UNTil k =
END;
z := z-1
UNTil z = 0;

reset(f[l[n]]); list(f[i[n]], ten]); ("rotate tapes")

tn := I[n]; 'dn := den]; z := a[n-1];
FOR i := n DOWNTO 2 DO

Sequential sorting

BEGIN I[i] := t[i-1]; d[i] := d[i-1]; a[i] := a[i-1] - z

END;
I[ 1] := tn; d[ 1] := dn; a[ 1] := z;
(. sorted outpul is on I[ 1] .)
level := level - 1
UNTIL level = 0;
END (polyphasesorI O ) ;
BEGIN (0 generale random file)
leng := 200; rand := 7789;
REPEAT rand:= (131071rand) MOD 2147483647;
buLkey := rand DIV 2147484; wrile(fO, but); leng := leng UNTIL leng = 0;
reset(fO); lisl(fO,1);
polyphase sort;
END.

37

38

Pascal programs

9. "Problem solving", backtracking.

1. Find all sellings of 8 queens on an 8x8 chess board such that no queen checks
another queen. [see also, Comm. ACM 14, 4, 221-27 (April 74)].
PROGRAM eightqueens( output);
VAR i : integer;
a : ARRAY [ 1..8 ] OF boolean;
b: ARRAY [2.. 16] OF boolean;
c : ARRAY [-7..7 ] OF boolean;
x : ARRAY [ 1..8 ] OF integer;
safe : boolean;
PROCEDURE print;
VAR k: integer;
BEGIN write(" It);
FOR k := 1 TO 8 DO write(x[k]:2);
wrlteln
END;
PROCEDURE trycol(j : integer);
\fAR i : integer;
PROCEDURE setqueen;
BEGIN a[i] := false; b[i+j] := false; c[i-j] := false
END;
PROCEDURE remove queen;
BEGIN a[i] := true; b[i+j] := true; c[i-j] := true
END;
BEGIN i := 0;
REPEAT i := i+l; safe := a[i] AND b[i+iJ AND c[i-j];
IF safe THEN
BEGIN sctqueen; x[j] := i;
IF j < 8 THEN trycol(j+1) ELSE print;
removequeen
END
UNTIL i = 8
END;
BEGIN FOR i := 1 TO 8 DO a[i] := true;
FOR i := 2 TO 16 DO b[i] := true;
FOR i := -7 TO 7 DO c[i] := true;
lrycol( I);
END.

"Problem solving", backtracking

39

2. Find sequences of digits 0, 1, 2 and of lenglhs 1 '" 90, such lhal lhey con lain no
lwo adjacent subsequences lhat are equal.
PROGRAM sequence012(oulput);
CONST maxlenglh = 90;
VAR n: inleger;
good: boolean;
s: ARRAY [1 ..maxlenglh] OF integer;
PROCEDURE prinlsequence;
VAR k: inleger;
BEGIN write(" ");
FOR k := 1 TO n DO write(s[k]:1);
writeln
END (printsequence');
PROCEDURE changesequence;
BEGIN IF sen] = 3 THEN
BEGIN n := n-1; changesequence
END ELSE sen] := SlIcc(s[n])
END (. changesequence') ;
PROCEDURE lry;
VAR i,l,nhalf: inleger;
BEGIN IF n <= 1 THEN good := true ELSE
BEGIN I := 0; nhalf := n DIV 2;
REPEAT 1:= 1+1; i:= 0;
(. comp8re tails of length I for equality *)
REPEAT good := s[n-i] # s[n-H]; i := i+1
UNTIL good OR (bl)
UNTIL NOT good OR (I>=nhalf);
END
END ('lry') ;
BEGIN n := 0;
REPEAT n := n+1; sen] := 1; lry;
WHILE NOT good DO
BEGIN chDngesequence; try
END;
prinlsequence
UNTIL n = maxlenglh
END.

40

Pascal programs

3. Find .the sma,llest positive integer that can be represented as the sum of 10 cubes
(integers raised to Ihe third power) in Iwo different ways.
PROGRAM sumofcubes( output);
VAR i, ill, II, min, at b, k: integer;
j, sum, pwr: ARRAY [1..200] OF inleger;

(. pwr[I~] = power of k, sum[k]:: p[k] + p[j[k]],

j[k] = columnindex of lasl considered candidaIe in row k,
ih = rowindex of highest considered row,
il = rowindex of least still relevant row .)
BEGIN i := 1; if := 1; ih := 2;
j[ 1] ::: 1; pwr[ 1] := 1; sum[ 1] := 2;
j[2] := 1; pwr[2] := 8; sum[2] := 9;
REPEAT
min := sllm[i]; a := i; b := j[i];
(* now gel next sum in row i *)
IF j[i] :: i THEN
BEGIN (* there is none left *) iI := il+1;
END ELSE
BEGIN IF j[i] :: 1 THEN
BEGIN (* the new min wns from the first column, now add
a new row before laldng th~ new sum from Ihe old row')
ih := ih + 1; pwr[ih] := ill'ih 'ih;
j[ih] :=1; sum[ih] := pwr[ih]+1;
END;

j[i] := j[i]+1; (. next candidate in row i .)

sum[i] := pwr[i] + pwr[j[i]]
END;
(* nOli\( find minimal candidate in rows iI .. ih *)
i := it; k := i+ 1;
WHILE k <= ih DO
BEGIN IF sum[k] < sum[i] THEN i := k; k:= k+1
END

UNTIL sum[i] :: min;

writeln(min,a,b,i,j[i])
END.

"Problem solving". backtracking

4. Find

a path of a knight on a chess board which covers all 64 squares.

PROGRAM knightslour(output);
CONST n = 5; nsq = 25;
TYPE index = 1.. n;
VAR i,i: index;
q: boolean;
s: SET OF index;
a,b: ARRAY [1..8] OF integer;
h: ARRAY [index, index] OF integer;
PROCEDURE try(i: integer; x,y: index; VAR q: boolean);
VAR k,u,v: integer; q1: boolean;
BEGIN k := 0;
REPEAT k := k+ 1; q 1 := false;
U := x + ark]; v := y + b[k];
IF (u IN s) AND (v IN s) THEN
IF h[u,v] = 0 THEN
BEGIN h[u,v] := i;
IF i < nsq THEN
BEGIN try(i+1,u,v,q1);
IF NOT q1 THEN h[u,v] := 0
END ELSE q 1 := true
END
UNTIL q1 OR (1<=8);
q := ql
END (>try ;
BEGIN s := [1,2.3.4,5];

8[1]:=
a[2]:=
a[3] :=
a[4] :=
0[5] :=
a[6] :=

2;
1;
- t;
-2;
-2;
-1;

b[ 1]:= 1;
b[2]:= 2;
b[3] :=2;
b[4]:= 1;
beG] := -1;
b[6] := -2;

a[7]:= 1; b[?] := -2;

n[8]:= 2; b[a] := -1;
FOR i := 1 TO n DO
FOR j := 1 TO n DO h[i,j] := 0;
h[1,1] := 'f; try(2,1,I,q);
IF q THEN
FOR i := 1 TO n DO
BEGIN FOR j := 1 TO n DO write{h[i,j):5);
write In
END
ELSE writeln(It no solution It)
END.

41

42

Pascal programs

5. Find a solution to the stable marriage problem. n men and n women slate their
preferences of partners. Find n pairs such Ihat no man would prefer 10 be married to
anolher woman who would also prefer him 10 her pmtner. A set of pairs is cnlled
stable, if no such cases exist [see also Comm. ACM 14, 7, 486-92 (July 71)].
PROGRAM marriage(inpul,output);
CONST n = 8;
TYPE man = 1.. n; woman = 1.. n; rank = 1.. n;
VAR m: man; w: woman; r: rank;
wmr: ARRAY [man, ranl~] OF woman;
mwr: ARRAY [woman, rank] OF man;
rmw: ARRAY [man, woman] OF rank;
rwm: ARR/\Y [woman, man] OF rank;
x: ARRAY [man] OF woman;
y: ARliAY [woman] OF man;
single: ARRAY [woman] OF boolean;
PROCEDURE print;
VAR m: man; rm, rw: integer;
BEGIN rm := 0; rw := 0;
FOR m := 1 TO n DO
BEGIN wrile(x[m]:4);
rm := rm + rmw[m,x[m]]; rw := rw + rwm[x[m],m]
END;
wri Ie InC rm:8,rw:4);
END ('print") ;
PROCEDURE try(m: man);
VAR r: rank; w: woman;
FUNCTION stable: boolean;
VAR pm: man; pw: woman;
i, lim: rank; s: boolean;
BEGIN s := true; i := 1;
WHILE O<r) AND s DO
BEGIN pw := wmr[m,i]; i := 1+1;
IF NOT single[pw] THEN s := rwm[pw,m] > rwm[pw,y[pw]]
END;
i := 1; lim := rwm[w,m];
WHILE (i<lim) AND s DO
BEGIN pm := rnwr[w,i]; i := 1+'1;
IF pm < rn THEN s := rmw[pm,w] > rmw[pm,x[pm]]
END;
slable := s
END ("test") ;

BEGIN ("Iry")
FOR r := 1 TO n DO
8EG1[\1 VI := wmr[m,r];
IF single[w] THEN
IF stable THEN
BEGIN x[m] := w; yEw] := m; single[w] := false;
IF m < n THEN try(succ(rn ELSE print;
single[w] := true
END
END
END rtry*) ;

"Problem solving". backlrocking

BEGIN writeln("1");
FOR m := 1 TO n DO
FOR r := 1 TO n DO
BEGIN read(wmr[m,r]); rmw[m,wmr[m,r]] := r
END'
FOR w
1 TO n DO
FOR r.:= 1 TO n DO
BEGIN read(mwr[w,r]); rwm[w,mwr[w.r]] := r
END
FOR w
1 TO n DO single[w] := Irue;
Iry("I)
END.

;=

;=

5 7 1 2 6 843
2 3 7 541 8 6
8514623 7
3 2 7 4 1 685
725 1 368 4
1 6 7 5 8 423
2 5 763 481
3 8 457 261
5 3 761 284
8 6 357 2 1 4
1 5 6 2 487 3
8 7 3 241 5 6
64738"125
2 8 5 4 6 3 7 1

752 1 864 3
741 5 2 368

43

44

Pascal programs

6. Find an opUmal selection of objects from a given set of n objects under a given
constrain!. Each object is characterised by two properties v (for value) and w (for
weight). The optimal selection is the one with the largest sum of values of its
members. The constraint is that the sum of their weights musl not surpass a given
limit fimv. The algorithm is called branch and bound.
PROGRAM selection(inpul,output);
CONST n = 10;
TYPE index = 1.. n;
object = RECORD v,w: integer END;
VAR i: index;
a: ARRAY [index] OF object;
Iimw, totv, maxv: integer;
wi, w2, w3: integer;
s, opts: SET OF index;
z: ARRAY (boolean] OF char;
PROCEDURE try(i: index; tW,av: integer);
VAR av1: integer;
BEGIN (try inclusion of object i)
IF tw + n[i].w <= limw THEN
BEGIN s := S + (i];
IF i < 11 THEN try(i+1, tw+a[i].w, av) ELSE
IF av > mtlXV THEN
BEGIN maxv := BV; opts := s
END;
s := S - [i]
END;
(now try without object i') av1 := av - a[i].v;
IF av1 > mtlxv THEN
BEGIN IF i < n THEN try(i+1, tw, avi) ELSE
BEGIN maxv := av1; opts := s
END
END
END ('try') ;
BEGIN lotv := 0;
FOR i := 1 TO n DO
WITH a[i] DO
BEGIN read(w,v); totv := totv + v
END;
read(w1,w2,w3);
z[true] ;= "'''; z[false] :=
write(" weight ");
FOR i := 1 TO n DO wriLe(a[i].w:4);
writeln; write(" value
"); ,
FOR i := 1 TO n DO write(a[i].v:4);
writeln;
REPEAT limw := w 1; m3XV := 0; s := []; opts := [];
try( 1,O,totv);
wrile(limw);
FOR i := 1 TO n DO write(" ", z[i IN opls]);
wrileln; w1 := wi .1- w2 .
UNTIL W"' > w3
END.
II

";

Lisl and tree structures. poinlers

45

10. List and tree structures, pointers.

1. A procedure search is to locale records with a given key in an ordered list. If the
key is not present, then a new record is 10 be inserted so that the ordering of keys is
maintained. Use a sentinel at the end of the lis!.

PROGRAM Iist(input,output);
TYPE ref = tword;
word = RECORD key: integer;
count: integer;
next: ref
END;
VAR k: integer; root, sentinel: ref;
PROCEDURE search(x: integer; VAR root: ref);
VAR w1,w2,w3: ref;
BEGIN w2 := root; w 1 := w2 t .next; sentinel t .I~ey := x;
WHILE w1 t .key < x DO
BEGIN w2 := w1; w1 := w2t.next
END'
IF (w1 t .'key = x) AND (w1 :/I sentinel) THEN
w 1 t .count := w 1 t .count + 1 ELSE
BEGIN new(w3); ('insert w3 between w1 AND w2')
WITH w3t DO
BEGIN key := x; count := 1; next := w 1
END;
w2t.next := w3
END
END ("search+) ;
PROCEDURE printlist(w,z: ref);
BEGIN WHILE w :/I z DO
BEGIN wrileln(wt.l~ey. wt.count);
w := wt.next
END
END (+printlist+) ;
BEGIN new(root); new(senlinel); root t .next := sentinel;
read(k);
WHILE k:ll 0 DO
BEGIN search(I<, root); read(k)
END;
prinllisl(root t .next,senlinel)
END.

46

Pascal programs

2. Instead of keeping the list ordered according to keys, reorder it as follows: After
each search, the accessed record is moved to the lop of the list. In this case,
repeated accesses to the same element will be very fast. Use a sentinel at tile end
of the list.
PROGRAM lisl(input,output);
TYPE ref = tworu;
word = RECORD key: inleger;
count: integer;
next: ref
END;
VAR k: integer; root, sentinel: ref;
PRO'CEDURE search(x: integer; VAR rool: ref);
VAR w1,w2: ref;
BEGIN wi := root; sentinelt.key := x;
IF wi = sentinel THEN
BEGIN (Iirst element) new(root);
WITH matt DO
BEGIN key := x; count := 1; next := sentinel
END
END ELSE
IF wI t .key = x THEN wit .count := wI t .count + 1 ELSE
BEGIN (search)
REPEAT w2 := wi; wi := w2t.next
UNTIL wIt .key = x;
IF wi = sentinel THEN
BEGIN ('insert)
w2 := 1'001; new(root);
WITH roott DO
BEGIN key := x; count := 1; next := w2
END
END ELSE
BEGIN (. found, now reorder')
wit.count := wit.counl + 1;
w2t.next := wi t.next; wi t.next := root; root := wi
END
END
END ('search') ;
PROCEDURE prinllist(w,z: ref);
BEGIN WHILE w # z DO
BEGIN writeln(wt .key, wt .count);
w := wt.next
END
END ('printlist') ;
BEGIN new(sentinel); root := senlinel;
read(k);
WHILE k # 0 DO
BEGIN search(k, root); read(k)
END;
prinllisl(rool,senlinel)
END.

List and tree structures, pointers

47

3. Read a sequence of relations defining a directed, finite graph. Then eslablish

whether or nol a partial ordering is defined. If so, print the elements in a sequence
showing the partial ordering. (Topological sorting).
PROGRAM topsorl(inpul,oulput);
TYPE Iref = tleader;
tref = ttrailer;
leader = RECORD key: integer;
count: integer;
tmil: tref;
next: Iref;
END;
trailer= RECORD id: Iref;
next: tref
END;
VAR head, tail, p,q: Iref;
I: tre!; z: integer;
x,y: inleger;
FUNCTION I{w: integer): Iref;
('reference to leader with key w')
VAR h: Iref;
BEGIN h ;= head; tailt.key := w; (*sentinel)
WHILE h t .key # w DO h:= ht .next;
IF h = tail THEN
BEGIN ('no element with key w in the list)
new(tail); z := z+1;
ht.counl := 0; ht.trail := NIL; ht.next := lail
END;
I := h
END (1') ;
BEGIN ('initialise list of leaders with a dummy')
new(head); tail := head; z := 0;
('input phase') read(x);
WHILE x # 0 DO
BEGIN read(y); writeln(x,y);
p := I(x); q := I(y);
new(l); tt.id ;= q; tt.next := pt.trail;
pt.lrail := t; qt.count := qt.count + 1;
read(x)
END;
('search for leaders with counl = 0')
p := head; head := NIL;
WHILE P # lail DO
BEGIN q := p; p := pt .next;
IF q t .counl = 0 THEN
BEGIN qt .nexl := head; head := q
END;
END;
('oulput phase') q:= head;
WHILE q /1 NIL DO
BEGIN writeln(qt.key); z ;= z-1;
1:= qt.tr<:lil;'q := qt.nexl;
WHILE t # NIL DO

48

Pascal -programs

BEGIN p := tt .id; pt .count := pot .count - 1;

IF P t .count = 0 THEN
BEGIN ('insert pt in q-list+)
p t .next := q; q := p
END;
t := tt.next
END
END;

IF z # 0 THEN wrileln(" this set is not partially ordered")

END.

List and tree structuros. pointers

49

4. Insertion and deletion in a binary tree. Read a sequence of integers. A positive

integer signifies that it should be inserted in an ordered binary tree as the key of a
node. A negative integer signifies that a node with its absolule value as key should
be searched and deleted.
PROGRAM tree(input,output);
TYPE ref = tword;
word = RECORD key: integer;
count: integer;
lefl, right: ref;
END;
VAR rool: ref; k: integer;
PROCEDURE printlree(w: ref; I: integer);
VAF~ i: integer;
BEGIN IF w # NIL THEN
WITH wt DO
BEGIN printlree(left, 1+1);
For-l i := 1 TO I DO write(H
wrileln(key);
printlree(right, 1+1)
END
END;

");

PROCEDURE search(x: integer; VAR p: ref);

BEGIN
IF p = NIL THEN
BEGII'l ("word is not in tree; insert it')
new(p);
WITH pt DO
BEGIN key := x; count := 1; left := NIL; right := NIL
END
END ELSE
IF x < pt.key THEN search(x, pt.lelt) ELSE
IF x > pt .key THEN search(x, pt .right) ELSE
pt .count := pt .count + 1
END ('search') ;
PROCEDURE delete(x: integer; VAR p: ref);
VAR q: ref;
PROCEDURE del(VAR r: ref);
BEGIN IF rt .right # NIL THEN del(rt .right) ELSE
BEGIN qt .key := rt .key; qt .count := rt .count;
q := r; r := rt .Ielt
END
END;
BEGIN ('delete')
IF p :: NIL THEN wrileln(" word is not in tree") ELSE
IF x < p t.1<ey THEN delete(x, p"t.left) ELSE
IF x ) pt.key THEN delete(x, pt.right) ELSE
BEGIN ('deleto pt") q:= p;
IF qt .right = NIL THEN P := qt .left ELSE
IF qt.left = NIL THEN p:= qt.right ELSE del(qt.loft);
('dispose(q)')
END
END ('delete') ;

50

Pascal programs

BEGIN rool ;= NIL; read(k);

WHILE k # 000
BEGIN IF k > 0 THEN
BEGIN writeln(" Insert", k); search(k,root)
END ELSE
BEGIN wrileln(" delete",-k); delete(-k,root)
END;
prinllree(rool,O); read(k)
END;
END.

List and tree structures. pointers

5. Insertion and deletion in a

Iree may grow in all sorls of
the "Iree" even degenerales
mainlained, suell lhat at each

51

AVL -balanced tree. In the previous program, the binary

shapes -- if Ihe inserted keys are ordered upon arrival,
inlo a linear lis!. In the following program, a balance is
node lhe heights of ils Iwo subtrees differ by at most 1.

PROGRAM ballree(inpul,output);
TYPE ref = tword;
word = RECORD key: integer;
counl: integer;
left, right: ref;
bal: -1..+1
END;
V AR root: ref; h: boolean; k: integer;
PROCEDURE printtree(w: ref; I: integer);
VAR i: inleger;
BEGIN IF w # NIL THEN
WITH wt DO
BEGIN prinllree(left, 1+1);
FOR i := 1 TO 1 DO write("
wrileln(key:5, bal:3);
printtree(right, 1+1)
END
END;

");

PROCEDURE search(x: inleger; VAR p: ref; VAR h: boolean);

VAR p" ,p2: ref;
('11 = false')
BEGIN
IF P = NIL THEN
BEGIN (word is not in tree; inserl iI*)
new(p); h := Irue;
WITH pt DO
BEGIN key := x; count:= 1;
left := NIL; right := NIL; bal := 0
END
END ELSE
IF x < pt.key THEN
BEGIN search(x, pt .left, h);
IF h THEN
(*Iert branch has grown higher)
CASE p t .bal OF
1: BEGIN pt .bal := 0; h := false
END;
0: p t .bal := -1;
-1: BEGIN (+rebalance+) p1 := pt.left;
IF p1 t .bal = -1 THEN
BEGIN (*single LL rotalion)
pt.lefl:= p1t.right; p1t.righl:= p;
pt.bal := 0; p := p1
END ELSE
BEGIN (+double LR rotation) p2:= p1 t.right;
p1t.righl:= p2t.lefl; p2t.lell:= p1;
p't .left := p2t .right; p2t .rigl1l := p;
IF p2t.bal = -1 THEN pt.bal := +1 ELSE pt.bal := 0;
IF p2t.bal = +1 THEN p1t.bal:= -I ELSE ph.bal:= 0;
p := p2
END;
pt .bal := 0; h := false
END

52

Pascal programs

END
END ELSE
IF X > pt .key THEN
BEGIN search(x, pt .right, h);
IF h THEN
('right branch has grown higher)
CASE pt .bal OF
-1: BEGIN pt .bal := 0; h := false
END;
0: pt.bal:= +1;
1: BEGIN (rebalance") pi := pt.right;
IF pH.bal = +1 THEN
BEGIN ("single RR rotation)
pt.rigl1t := pH.left; pi t.lefl := p;
pt .bal := 0; p := pi
END ELSE
BEGIN ("double RL rotation') p2:= pi t .Ieft;
pi t.left := p2t.righl; p2t.right := pi;
pt.right:= p2t.left; p2t.left:= p;
IF p2t.bal = +1 THEN pt.bal := -1 ELSE pt.bal := 0;
IF p2t.bal = -1 THEN pH.bal := +'1 ELSE pH.bal := 0;
p := p2
END;
pt .bal := 0; h := false
END
END
END
ELSE
BEGIN pt .count := p t .count ... 1; h := false
END
END (semch ;
PROCEDURE delete(x: integer; VAR p: ref; VAR 11: boolean);
VAR q: ref;
(+h = false
PROCEDURE balance1(VAR p: ref; VAR h: boolean);
VAR p',p2: ref; b1,b2: -1..+1;
BEGIN (+h = true, left branch has become less high
CASE pt .bal OF
-1: pt .bal := 0;
0: BEGIN p t .bal := + 1; h := false
END;
1: BEGIN (>rebalance') pi := pt.right; b1 := pit.bal;
IF b1 >= 0 THEN
BEGIN ('single RR rotation)
pt.right:= pH.left; pit.left:= p;
IF b1 = 0 THEN
BEGIN pt.bal := +1; pi t.bal := -1; h := false
END ELSE
BEGIN P t .hal := 0; pit .bal := 0
END;
p := pi
END ELSE
BEGIN (double RL rotntion+)
p2 := p'l t.lell; b2 := p2t.bal;
pi t.left := p2t.rirJht; p2uight := p'l;
pt.right := p2t.lert; p2t.lefl := p;
IF b2 = +1 THEN Pt .b81 := -I ELSE Pt .bal := 0;
IF b2 = -1 THEN plt.bal := +1 ELSE pit.bal := 0;

list and tree structures, pointers

p := p2; p2t .bal := 0

END
END
END
END (balance1) ;
PROCEDURE balance2(VAR p: ref; VAR h: boolean);
VAR p1,p2: ref; b1,b2: -1..+1;
BEGIN (11 = true, rigl1t branch has become less high)
CASE pt.bal OF
1: pt.bal:= 0;
0: BEGIN pt .bal := -1; h := false
END;
i
-1: BEGIN (rebalance) pi := pt.lelt; b1 := p1t.bal;
IF b1 <= 0 THEN
BEGIN ("single LL rotation)
p't.left := pi t.right; pi t.rigllt := p;
IF b'l = 0 THEN
BEGIN pt,bal := -1; pi t.bal := +1; h := false
END ELSE
BEGIN pt.bal := 0; p1t.bal := 0
END;
P := pi
END ELSE
BEGIN (double LR rotation)
p2 := p 1t .right; b2 := p2t .bal;
pi t.rigl1t := p2t,left: p2t.lefl := p1;
pt .left := p2t .right; p2t .right := p;
IF b2 = -1 THEN pt .bal := +1 ELSE pt .bal := 0;
IF b2 = +1 THEN p1 t.bal := -1 ELSE pi t.bal := 0;
p := p2; p2t .bal := 0
END
END
END
END (*balance2") ;
PROCEDURE del(VAR r: ref; VAR 11: boolean);
BEGIN (h = false*)
IF rt .right # NIL THEN
BEGIN del(rt .right,h); IF h THEN balance2(r,h)
END ELSE
BEGIN qt .key := rt .key; qt .count := rt .count;
r := rt .Ieft; h := true
END
END;
BEGIN (delete)
IF p = NIL THEN
BEGIN writeln(" I<ey is not in tree"); h := false
END ELSE
IF x < p t .I<ey THEN
BEGIN delele(x,pt .left,h); IF h THEN balance 1(p,ll)
END ELSE
IF x > pt.key THEN
BEGIN delete{x,pt .right,h); IF 11 THEN balc:tnce2(I1,h)
END ELSE
BEGIN (delete"pt) q:= p;
IF qt .right = NIL THEN

53

54

Pascal . programs

BEGIN P := q t .left; h := true

END ELSE
IF qt .Iell = NIL THEN
BEGIN P := qt .right; h := true
END ELSE
BEGIN del(qt.lefl,h);
IF h THEN balance1 (p,h)
END'
(tdispose(q)')
END
END (tdelete') ;
BEGIN read(k); root := NIL;
WHILE k # 0 DO
BEGIN IF k >= 0 THEN
BEGIN wrileln(tI inserl", k); search( k,root,h)
END ELSE
BEGIN writeln(tI deleletl,-k); delete(-k,root,h)
END'
printt~ee(root.O); read(k)
END;
END.

List and tree structures, pointers

55

6. Insert and delete elements in a B-tree of page size 2n. Read a sequence of keys;
positive values denote insertion, negative ones deletion. Print the resulting B-tree
after each operation.

PROGRAM Blree(input,output);
CONST n = 2; nn = 4; ('page size)
TYPE ref = tpage;
item = RECORD key: integer;
p: ref;
count: integer;
END;
page = RECORD m: O.. nn; (no. of items')
pO: ref;
e : ARRAY [1 .. nn] OF item;
END;
VAR root, q: ref; x: integer;
h: boolean; u: item;
PROCEDURE prinUree(p: ref; I: integer);
VAR i: integer;
BEGIN IF p 1/ NIL THEN
WITH p"t DO
,
");
BEGIN FOR i := 1 TO I DO write("
FOR i := 'I TO m DO write(e[i].l<ey: 4);

wrileln;
prinllree(pO,I+1 );
FOR i := 1 TO m DO prinUree(e[i].p, 1+1)
END
END;
PROCEDURE search(x: integer; a:ref;
VAR 11: boolean; VAR v: item);
('search key x on B-tree with root a; if found, increment counter.
Otherwise
insert an item with key x and count 1 in tree. If em item emerges to be passed
to a lower level, then assign it to v; h:= "tree a has become higher")
VAR k,l,r: integer; q: ref; u: item;
PROCEDURE insert;
VAR i: integer; b: ref;
BEGIN ('insert u to the right of at.e[r])
WITH at DO
BEGIN IF m < nn THEN
BEGIN In := m+ 1; h := false;
FOR i := m DOWNTO r+2 DO e[i] := e[i-1];
o[r+'I] := u
END ELSE
BEGIN ('page at is full; split it and assign the emerging
item to v) new(b);
IF r <= n THEN
BEGIN IF r = n THEN v := u ELSE
BEGIN v := e[n];
FOR i := n DOWNTO r+2 DO e[i] := e[i-1];
e[r+1J := u
END;
FOR i := 1 TO n DO bt.e[i] := at.e[i+n];
END ELSE

56

Pascal programs

BEGIN ('insert u in right page) r:= r-n; v := e[n+1];

FOR i := 1 TO r-1 DO bt.e[i] := at.e[i+n+1];

bt .e[r] := u;
FOR i := r+1 TO n DO bt.e[i] := at.e[i+n]
END;
01

:= n; bt.m := n; bt .pO := v.p; v.p := b;

END
END ('WITW)
END (inserP) ;
BEGIN ('search key x on page at; h = false')
IF a = NIL THEN
BEGIN ('item with key x is not in tree') h ::: true;
WITH v DO
BEGIN key := x; count := 1; P := NIL
END
END ELSE
WITH at DO
BEGIN I := 1; r := 01; ('binary array search '')
REPEAT k := (I+r) DIV 2;
IF x <= e[kj.key THEN r := k-1;
IF x
e[k].key THEN I := k+1;
UNTIL r
I;
IF I-r
1 THEN
BEGIN ('found) e[k].count := e[k].count + '1; h := false
END ELSE
BEGIN (' item is not on this page')
IF r = 0 THEN q := pO ELSE q := e[r].p;
search(x,q,h,u); IF h THEN insert
END
END
END ('search') ;

>=
<
>

PROCEDURE delete(x: integer; a: ref; VAR h: boolean);

('semet, and delete key x in B-tree a; if a page underflow is necessary,

balance with adjacent page if possible, otherwise merge; h:= "page a is
undersize"')
VAR i,k,l,r: integer; q: ref;
PROCEDURE underflow(c,a: ref; s: integer; VAR h: boolean);

('a:: under!low page,

= ancestor page')

VAR b: ref; i,I<,mb,mc: integer;

BEGIN me := ct .01; ('h = true, at.m = n-1")
IF s < mc THEN
BEGIN (*b := page to the right of at) s:= 5+1;
b := ct.e[s].p; mb := bt.m; k := (mb-n+1) DIV 2;

(*k = no. of items available on adjacent page b*)

at.e[n] := ct.e[s]; at.e[n].p := bt.pO;
IF k > 0 THEN
BEGIN ('move k items from b 10 at)
FOR i := 1 TO k-1 DO at .e[i+n] := bt .e[i];
c t .e[s] := bt .e[k]; cot .e[s].p := b;
bt.pO:= bt.e[k].p; mb:= mb-k;
FOR i := 1 TO mb DO bt.e[iJ:= bt.e[i+k];
bt.m := mb; at.m := n-I+k; h := false
END ELSE
BEGIN ('merge pages a fllld bO)

List and tree structures, pointers

FOR i := 1 TO n DO at.e[i+n] := bt.e[i];

FOR i := s TO me-1 DO ct.e[i] := c"t.e[i+1];
at.m := nn; ct.rn := mc-1; ('dispose(b)')
END
END ELSE
BEGIN ('b := page 10 the left of at)
IF s = 1 THEN b := et.pO ELSE b := et,e[s-l].p;
mb := bt.m + 1; k := (mb-n) DIV 2;
IF k > 0 THEN
BEGIN ('move k Hems from page b 10 a')
FOR i := n-1 DOWNTO 1 DO at.e[i+k] := at.e[i];
at.e[k] := ct.e[s]; at.e[k].p := at.pO; mb := rnb-k;
FOR i := k-1 DOWNTO 'I DO at .e[i] := bt .e[i+mb];
at.pO := bt.e[mb].p;
ct.e[s] := bt.e[mb]; ct.e[s].p := a;
bt.rn := mb-1; at.m := n-1+k; h := false
END ELSE
BEGIN ('merge pages a and b+)
bt.e[mb] := ct.e[s]; bt.e[mb]'p := ot.pO;
FOR i := 1 TO n-1 DO b1' .e[l+rnb] := at .e[i];
bt.m := nn; cot.m := mc-1; (+dispose(a)')
END
END
END ('underflow') ;
PROCEDURE del(p: ref; VAR h: boolean);
VAR q: ref;
('global a,k')
BEGIN
WITH pt DO
BEGIN q := e[m].p;
IF q /t NIL THEN
BEGIN del(q,h); IF h THEN underflow(p,q,m,h)
END ELSE
BEGIN P t .e[m].p := at .e[k].p; at .e[k] := pt .e[m];
m := rn-1; h := m<n
END
END
END ('del') ;
BEGIN ('delete')
IF a = NIL THEN
BEGIN wrilcln(" key is not in tree"); h := false
END ELSE
WITH at DO
BEGIN I := 1; r := m; ('binary array search')
REPEAT I~ := (I+r) DIV 2;
IF x <= e[k].l~ey THEN I' := k-1;
IF x >= e[k].l~ey THEN' := k+1;
UNTIL I > r;
IF 1'=0 THEN q := pO ELSE q := e[r].p;
IF 1-1' > I THEN
BEGIN (' round, now delete e[k)")
IF q = NIL THEN
BEGIN ('a is a lerminal paget) m:= m-1; h := m<n;
FOR i := k TO m 00 eli] := o[i+ I];
END ELSE
BEGIN del(q,h); IF h THEN under[\ow(n,Cl,r,h)
END

57

58

Pascal programs

END ELSE
BEGIN delete(x,q,h);IF h THEN underllow(a,q,r,h)
END
END
END (delete) ;

BEGIN root := NIL; read(x);

WHILE x It 0 00
BEGIN writeln(" search key", x);
search(x,rool,h,u);
IF h THEN
BEGIN ("inserl new base page") q := root; new(root);
WITH roolt DO
BEGIN m := 1; pO := q; e[l] := U
END
END;
prinllree(rool,1); read(x)
END;
read(x);
WHILE x # 000
BEGIN wrileln(" delete key", x);
delele(x,rool,h);
IF h THEN
BEGIN (base page size was reduced)
IF root t.m = 0 THEN
BEGIN q := root; root := qt .pO; (dispose(q))
END;
END'
prillll~ee(root,1); read(x)
END
END.

List nnd tree structures, pointers

59

7. Find lhe optimally structured binary search tree for n keys. Known are the search
frequencies of the keys, b[i] for key[i], and the frequencies of searches with
arguments that are not I~eys (represented in the tree). a[i] is the frequency of an
argument lying between key[i-l ] and key[i]. Use Knuth's algorithm, Acta Informatica
1, 1, 14-25 (197"\). The following example uses Pascal I<eywords as keys.
PROGRAM optimallree(input,output);
CONST n = 31; ("no. of keys")
kin == ,10; ("max keylengtl'")
TYPE index = O.. n;
alra = PACKED ARRAY [1..kln] OF char;
VAR ell: char;
k1, k2: integer;
id: aHa;
('identifier or key")
buf: ARRAY [1 ..kln] OF char;
("character buffer")
key: ARRAY [1 ..n] OF alra;
i,j,k: integer;
a: ARRAY [1 ..n] OF integer;
b: ARRA'( [index] OF integer;
p,w: ARRAY [index,index] OF integer;
r: ARRAY [index,index] OF index;
suma, sumb: integer;
FUNCTION baltree(i,j: index): integer;
VAR k: integer;
BEGIN k := (i+j+ 1) DIV 2; r[i,j] := k;
IF i >= j THEN baltree := b[k] ELSE
ballree := baltree(i,k-1) + ballree(k,j) + w[i,j]
END ("baltree') ;
PROCEDURE opllree;
VAR x, min: integer;
i,i.I<,h,m: index;
BEGIN ("argument: w, result: p,r')
FORi := 0 TO n DO p[i,i] := w[i,i];
("width of tree h = 0")
FOR i := 0 TO n-1 DO
("width of tree h = 1')
BEGIN j:= i+1;
p[i,n := p[i,i] + p[j,j]; r[i,iJ:= j
END;
FOR h := 2 TO n DO
(. h = width of considered tree .)
FOR i := 0 TO n-h DO
(. i = lett index of considered tree .)
BEGIN j:= i+h;
(. j = right index of considered tree ")
III := r[i,j-1]; min:= p[i,rn-1] + p[m,j];
FOR k := 111+1 TO r[i-t-1,iJ DO
BEGIN x := p[i,k-l] -I- p[I<,j];
IF.x < min THEN
BEGIN m := k; min:= x
END
END;
p[i,j] := min + w[i,j]; r[i,j]:= III
END;
END ("opllree') ;
PROCEDURE prinllree;
CONST Iw = 120;
TYPE ref = tnode;
lineposition "= O..Iw;
node = RECORD key: alfa;

('Iine width of printer')

60

Pascal programs

pas: lineposition;
left, right, link: ref
END'
VAR root, curr~nt, next: ref;
q,q1,q2: ref;
i: integer;
k: integer;
u, u 1, u2, u3, u4: lineposition;
FUNCTION tree(i,j: index): ref;
VAR p: ref;
BEGIN IF i = j THEN p := NIL ELSE
BEGIN new(p);
pt .left := tree(i, r[i,j]-1);
pt.pos := trunc((lw-l<ln)*k/(n-1 + (kin DIV 2); k:= k+1;
pt .key := key[r[i,j]];
pt.right :'" tree(r[i,i], j)
END;
tree := p
END;
BEGIN k := 0; root:= tree(O,n);
current := root; root t .Iink := NIL;
next := NIL;
WHILE current # NIL DO
BEGIN (*proceed down; first write vertical lines)
FOR i := 1 TO 3 DO
BEGIN u := 0; q := current;
REPEAT u1 := qt.pos;
REPEAT write(" "); u := u+ 1
UNTIL u = u1;
write(":"); u := u+1; q := qt.link
UNTIL q = NIL;
writeln
END;
(*now print master line; descending from nodes on current list
collect their descendants and form next list')
q := current; u := 0;
REPEAT unpack(qt .key, buf, '1);
("center key about pos") i:= kin;
WHILE buf[i] = " "DO i:= i-1;
u2 := qt.pos - ((i-1) DIV 2); u3 := u2+i;
ql := q t .Ieft; q2 := q t .right;
IF q 1 = NIL THEN u1 := 1I2 ELSE
BEGIN u1 := q1t .pos; ql t .link := next; next := q1
END;
IF q2 = NIL THEN u4 := u3 ELSE
BEGIN u4 := q2t .pos+ 1; q2t .link := next; next := q2
END;
i := 0;
WI-IILE u < u1 DO BEGIN writer' "); 1I := u+1 END;
WI-IILE u < u2 DO BEGIN wrile("-"); u := u+1 END;
WHILE u < u3 00 BEGIN i := i+1; write(blll[i]); II := u+1 END;
WHILE u < u4 DO BEGIN write("-"); u := LJ+I END;
q := qt .link
UNTIL Cj = NIL;
writeln;
(*now invert next list AND make it current list')

List and tree slruclures, pointers

current := NIL;
WHILE nexl # NIL DO
BEGIN q := next; next := q1' .link;
q t .link := current; current := q
END
END
END (. printlree') ;
BEGIN (initialize lable of keys and counlers')
key[ 1] := "ARRAY"; key[ 2] := "BEGIN ";
key[ 3] := "CASE ";
key[ 4] := "CaNST "; key[ 5] := "DIV
";
key[ 6] := "DOWNTO ";
key[ 7] := "DO
";
key[ 8] := "ELSE ";
key[ 9] := "END
";
key[10]:= "FILE ";
key[11.1:= "FOR
";
key[12]:= "FUNCTION ";
key[13] := "GOTO "; key[14]:= "IF
";
key[15] := "IN
',',;.
key[16] := "LABEL ";
key[17]:= "MOD
";
key[18] := "NIL
,
key[ 19] := "OF
";
key[20]:= "PROCEDURE "; key[21] := "PROGRAM ";
l<ey[22] := "RECORD "; key[23] := "REPEAT ";
key[24] := "SET
";
l<ey[25] := "THEN ";
key[26]:= "TO
";
key[27] := "TYPE ";
l<ey[28] := "UNTIL ";
l'\ey[29]:= "VAR
";
key[30] := "WHILE ";
key[31] := "WITH ";
FOR i := 1 TO n DO
BEGIN ali] := 0; b[i]:= a
END'
b[O] := '0; k2 := kIn;
("scan inpul text and delermine a and bY)
WI-liLE NOT eof(input) DO
BEGIN reacl(ell);
IF ell IN ["8" .. "Z"] THEN
BEGIN ('identifier or I<ey') k1 := 0;
REPEAT IF k1 < kin THEN
BEGIN k1 := k1+1; bul[k1] := eh
END;
read(ell)
UNTIL NOT (ell IN ["a" .."z", "0" .. "9"]);
IF k1 >= k2 THEN 1<2 := k1 ELSE
REPEAT bul[k2] := " "; k2 := k2-1
UNTIL k2 = k1;
paek(bul,1,id);
i := "I; j := n;
REPEAT 1< := (i+j) DIV 2;
IF key[k] <= iel THEN i := k+1;
IF key[k] )= id THEN j := k-1;
UNTIL i
j;
IF key[I<] = id THEN a[I<] := 8[k] + 1 ELSE
BEGIN k := (i+j) DIV 2; b[k] := b[k]+"'
END;
END ELSE
IF ell = ""'''' THEN
REPEAT read(eh) UNTIL ell = """" ELSE
IF eh = "("" THEN
REPEAT read(eh) UNTIL eh = "")"
END;
writeln(" keys and frequencies of occurrence:");
suma := 0; sllmb := b[O];
FOR i := 1 TO n DO
BEGIN sumo := suma+a[i]; sumb := sumb+b[i];
wrileln(b[iali], " ", key[i])
END;

>

n,

61

62

Pascal programs

wrileln(b[n]);
wrHeln("
.
------");
writeln(sumb, suma);
('compute w from a and b t )
FOR i :=
TO n DO
BEGIN w[i,i] := b[i];
FOR j ::: i+1 TO n DO w[i,j] := w[i,j-1] + a[j] + b[j]
END;
writeln;
write(" average path leng1l1 of balanced tree ::");
writeln(baltree(O,n)/w[O,n]:6:3); prinllree;

opllree;
write In;
write(" average palh length of optimal tree =");
writeln(p[ O,n]/w[O,n]:6:3); prinllree;
('now consider keys only. selling b :: 0')
FOR i := 0 TO n DO
BEGIN w[i,i] := 0;
FOR j ::: i+1 TO n DO w[i,j] := w[i,j-1] + a[j]
END;
opltree;
writeln;
writeln(" optimal tree considering keys only");
printlree
END.

Cross reference generators

63

11. Cross re"ference generators

1. Read a text and generate a cross reference table of nil words. i.e. sequences of
characters that b(')~Jin with a leiter and consisl of lellers and digils only. Blanks, ends
of lines. and special characlers are considered to be separators. Use a binary tree to
store the words encountered.
PROGRAM crossref(f,oulpul);
CONST c1 = 10;
('ength of words")
c2 = 8; ("numbers per line")
c3 = 6; (. digits per number")
c4 = 9999; (max line number")
TYPE alfa = PACKED ARRAY [Lc1] OF char;
wordref = tword;
itemref = tHem;
word = RECORD key: alfa;
first. last: ilemref;
left, right: wordref
END;
Hem = PACKED RECORD
Ina: 0 .. 9999;
next: itemref
END;
VAR root: wardref;
k.k1: inleger;
n: integer;
(current line number)
id: alta;
f: text;
a: ARRAY [ , ..c 1] OF char;
PROCEDURE search(VAR w1: wordref);
VAf~ w: wardraf; x: itemref;
BEGIN w := w1;
IF w = NIL THEN
BEGIN new(w); new(x);
WITH wtDO
BEGIN key := id; left := NIL; right := NIL;
first := x; last := x
END;
xt.lno := n; xt.nexl := NIL; w1 := w
END ELSE
IF id ( wr.key THEN se<lrch(wt.lefl) ELSE
IF id > wr.key THEN search(wt.right) ELSE
BEGIN new(x); X1' .Ino := 11; xt .next := NIL;
wt,laslt.next := x; wt.last := x
END
END (search+) ;
PROCEDURE prinllree(w: wordref);
PROCEDURE printword(w: word);
VAn I: inle~Jer; x: iternref;
BEGIN wrile(" ". w.key);
x := w.firsl; I := 0;
REPEA T IF I = c2 THEN
BEGIN wrileln;
I :'= 0; write(" ":c 1+1)
END;

64

Pascnl programs

1:= 1+1; wrile(xt.lno:c3);

UNTIL

:= xt.next

= NIL;

writeln
END (printword) ;
BEGIN IF w # NIL THEN
BEGIN printtree(wt .Ieft);

printword(w t); prinltree(w t .right)

END
END (Oprinllree);
BEGIN root := NIL; n := 0; k 1 := c 1;

page( output); resel(f);

WHILE NOT eof(f) DO
BEGIN IF n = c4 THEN n ;= 0;
n := n+1; write(n:c3);
(next line)

write(" tI);
WHILE NOT 8010(f) DO
BEGIN ('scan non-empty line)
IF ft IN [tla" .."z"] THEN
BEGIN k := 0;
REPEAT IF k
c1 THEN
BEGIN k := k+ 1; a[k]:= ft;
END;

<

write(ft); get(f)
UNTIL NOT (ft IN ["a".."z.. ,tlO......g"]);
IF k >::: k1 THEN k1 ;= k ELSE
REPEAT <.1[k1] := ""; k1 := k1-1
UNTIL k1 = k;
pack(a,f ,id); search(root)
END ELSE
BEGIN ('check for quote or comment)
IF ft = '''''''' THEN
REPEAT write(ft); get(f)
UNTIL f t = ..... tI. ELSE
IF ft ::: "(" THEN
REPEAT write(ft); get(f)
UNTIL ft = "}tI ;

write(ft); get(f)
END
END;

writeln; get(f)
END;

page( output); printtree(root);

END.

Cross reference generators

65

2. Cross reference generator as above, bul using a hash lable ins lead of a binary tree
10 store the words encounlered.
PROGRAM crossref(f,output);
LABEL 13;
CONST c1 = 10; (Olenglh of words")
c2 = 8;
("numbers per line")
c3 = 6;
("digits per number")
c4 = 9999; (max line number")
p = 997;
("prime number")
free = 0'
";
TYPE index = O.. p;
Hemref = tilem;
word = RECORD key: alfa;
first, last: ilemref;
101: index
END;
ilem = PACKED RECORD
Ina: 0 ..9999;
nexl: Hemref
END;
VAR i, top: index;
k,k1: inleger;
n: integer;
(" current line number")
id: alia;
f: texI;
a: ARRAY [Lc1] OF char;
lellers, letdigs: SET OF char;
I: ARRAY [O.. p] OF word;
("hash tableO)
PROCEDURE search;
VAR h,d,i: index;
x: itemref; f: boolean;
("global variables: I, iel, lop)
BEGIN h := orcl(id) DIV 4096 MOD p;
('Pascal-60aO defines ord on packed characler array of length 10.
Division is needed because division operules on 48 bits only! ")
f := false; d := 1;
new(x); xt .1110 := n; x t .next := NIL;
REPEAT
IF I[h].key = id THEN
BEGIN ("found") f := true;
t[h].last t .nexl := x; l[h).last := x
END ELSE
IF l[h].key :: free THEN
BEGIf\J ("new enlry") I := true;
WITH I[h] DO
BEGIN key := id; firsl := x; last := x; fol := top
END;
top := h
END ELSE
BEGIN ("collision") h := h+d; d := d+2;
IF h >= P THEN h := h-p;
IF d = p THEN
BEGIN wrileln(" table overflow"); GOTO 13
END
END
UNTIL f

66

Poscal

programs

END ('search') ;
PROCEDURE printlable;
VAR i,i,m: index;
PROCEDURE prinlword(w: word);
VAR I: integer; x: i1emref;
BEGIN write(" ", w.key);
x := w.lirsl; I := 0;
REPEAT IF I = c2 THEN
BEGIN wrileln;
I := 0; wrile(" ":c1+1)
END;
I := 1+ 1; write(x t .lno:c3); x := x t .next
UNTIL x = NIL;
writeln
END ('prinlword') ;
BEGIN i := lop;
WHILE i # p DO
BEGIN ('scan linked list and find minimal key')
m := i; i := l[i].lol;
WHILE j # P DO
BEGIN IF l[j).key < t[mlkey THEN m := j;
j := t[j),fol
END;
printword(l[m]);
IF m # i THEN
BEGIN t[m].key := I[i].key;
I[m]'first := t[i].lirst; I[mllasl := t[i].last
END;
i := l[i).loJ
END
END ('prinllable") ;
BEGIN n := 0; k1 := c1; lop := p; reset(f);
FOR i := 0 "TO p DO l[i].l~ey := free;
Ie tiers := ["a.... "z"]; leldigs := leUers + ["0".."9"];
WHILE NOT eof(f) DO
BEGIN IF n = c4 THEN n := 0;
n := n+1; write(n:c3);
("next line")
wrile(" ");
WHILE NOT eoln(f} DO
BEGIN ("scan non-emply line')
IF ft IN letters THEN
BEGIN k := 0;
REPEAT IF k < c1 THEN
BEGIN k := k+1; a[k]:= ft;
END;
wrile(ft); gel(f)
UNTIL NOT (It IN leldigs);
IF k )= k1 THEN k1 :,,; k ELSE
REPEAT a[k1]:=" "; k1:= k1-1
UNTIL k1 = k;
pack(a,l,id); search;
END ELSE
BEGIN ('check lor quole or commenl")
IF rt = .""." THEN

Cross reference generators

REPEAT write(ft); gel(f)

UNTIL f t = ... nt" ELSE
IF ft = "(" THEN
REPEAT wrile(ft); gel(f)
UNTIL ft = tt}" ;
write(ft); get(f)
END
END;
writeln; gel(f)
END;
13: page; prinUable
END.

67

68

Pascal programs

12. Syntax analysis

Skeleton compiler which checks lhe syntax of its input text according to the following
grammar. Principle is top-down, recursive descent with one symbol lookahead. (see
also N.Wirtll, Algorithms + Data Structures: Programs, Ch. 5, Prentice-Hall, Inc. 1975)
program
block::

blocl~

"." .
[ "CONST" idenl ":" number ("," ident ":" number) ";"]
[ "VAR" ident ("," ident} ";"]
( "PROCEDURE" ident ";" block ";") statement.
slatement : [ ident "::" expression I "CALL" ident I
"BEGIN" statement (";" statement} "END" I
"IF" condilion "THEN" statement I
"WHILE" condition "DO" statement ] ,
condition : "ODD" expression I
expression (":"1" #"'''<''1'' <:"1" )"'''):'') expression
expression:: ["+"1"-"] term ("+"1"-") term}.
term ::
factor ("'''1''/'') factor}.
faclor::
ident I number I "(" expression ")"

PROGRAM PLO(inpllt,outpul);
LABEL 99;
CONST norw = 1 I;
txmax = "' 00;
nmax :: 14;
81 :: 10;
chselsize = 128;

("no. of reserved words")

('Iength of identifier table')
(max. no of digits in numbers')
(+Iength of identifiers")
("for ASCII character set')

TYPE symbol :
(nul,idenl,nllmber,plus,minus,times,slash,oddsym,
eql,neq,lss,leq,glr,geq,lparen,rparen,comma,semicolon,
period,becomes,beginsym,endsym,ifsym,thensym,
whilesym,dosym,callsyrn,conslsym,varsym,procsym);
alta = PACKED ARRAY [1..aIJ OF char;
object = (conslant,variable,prozedure);
VAR cl1: char;
('Iast clleraeter read')
sym: symbol;
("'ast symbol read')
id: alta;
Clast identifier read')
num: inleger;
("ast number read')
cc: inleger;
('character cOLlnt')
II: integer;
('line length')
I,k: integer;
line: ARRA Y [1 ..81] OF char;
a: alta;
word: ARRAY [1..norw] OF alra;
wsym: ARRAY [1..norw] OF symbol;
ssym: AF1RAY [char] OF symbol;
Inble: ARRAY [O.. lxmaxJ OF
RECORD name: alra;
kind: object
END;

Syntax analysis

PROCEDURE error(n: integer);

BEGIN wrileln(" ":cc , "t", n:2); GOTO 99
END (*error*) ;
PROCEDURE gelsym;
VAR i,Lk: integer;
PROCEDURE getch;
BEGIN IF cc = II THEN
BEGIN IF eof(inpllt) THEN
BEGIN wrile(" program incomplete"); GOTO 99
END;
II := 0; cc := 0; wrile(" ");
WHILE NOT eoln(input) DO
BEGIN II := 11+1; read(eh); write(eh); line[lI] := cll
END;
writeln; II := 11+1; read(line[II])
END;
ec := ec+1; eh := line[ee]
END ("gelch") ;
BEGIN ('getsym')
WHILE ell =
DO geteh;
IF ell IN ["a" z"] THEN
BEGIN ('identifier or reserved word') k:= 0;
REPEAT IF k < al THEN
BEGIN k := k+1; ark] := eh
END;
geteh
UNTIL NOT (ch IN [ .. a......z..,.. O... .'g..]);
IF k >= kk THEN kl< := k ELSE
. REPEAT a[kk] := .. "; kk := kk-1
UNTIL kk = k;
id := a; i := 1; j := norw;
REPEAT 1<:= (i+j) DIV 2;
IF id <= word[k] THEN j := k-1;
IF id >= word[k] THEN i := k+ 1
UNTIL i > j;
IF i-1 > j THEN sym := wsym[k] ELSE sym := ident
END ELSE
IF ell IN ["0".."9"] THEN
BEGIN ('number') k := 0; num := 0; SYm := number;
r~EPEAT num :=IO'num + (ord(ell)-ord("O";
1< := k+1; gelcll
.
UNTIL NOT (ell IN ["0...."9..]);
IF k
nmax THEN error(30)
END ELSE
IF eh = ":" THEN
BEGIN gelch;
IF ell :: "=" THEN
BEGIN sym := becomes; getch
END ELSE sym := nul;
END ELSE
IF eh = "(" THEN
BEGIN geleh;

>

69

70

Pascal programs

IF eh : ":" THEN
BEGIN sym :: leq; geleh
END ELSE sym := Iss
END ELSE
IF eh : ")" THEN
BEGIN getel1;
IF ell : ":" THEN
BEGIN sym :: geq; gelch
END ELSE s ym := gtr
END ELSE
BEGIN sym := ssym[eh]; gelch
END
END ('getsym") ;
PROCEDURE block(lx: inleger);
PROCEDURE enler(k: objecl);
BEGIN ('enter ohjecl inlo table')
tx := tx -I- 1;
WITH lable[lx] DO
BEGIN name :: id; kind :: k;
END
END ('enler') ;
FUNCTION position(id: alfa): integer;
VAR i: integer;
BEGIN ('find identifier id in lable")
lable[O].name := id; i:= tx;
WHILE table[i].name It id DO i:= ;-1;
position := i
END ('position") ;
PROCEDURE consldeclaration;
BEGIN IF sym :: ident THEN
BEGIN getsym;
IF sym : eql THEN
BEGIN getsym;
IF sym = number THEN
BEGIN enler(eonslant); getsym
END
ELSE error(2)
END ELSE error(3)
END ELSE error(4)
END ('constdeclaralion") ;
PROCEDUr-lE vardeelaration;
BEGIN IF sym = ident THEN
BEGIN enter(vtlriable); getsym
END ELSE errore 4)
END ('vardeclmalion") ;
PROCEDURE statement;
VAR i: integer;

Syntax analysis

PROCEDURE expression;
PROCEDURE term;
PROCEDURE faclor;
VAR i: integer;
BEGIN
IF sym " idenl THEN
BEGIN i := position(id);
IF i = 0 THEN error( 11) ELSE
IF table[i].kind = prozedure THEN error(21);
gelsym
END ELSE
IF sym = number THEN
BEGIN getsym
END ELSE
IF sym = Iparen THEN
BEGIN getsym; expression;
IF sym " rparen THEN getsym ELSE error(22)
END
ELSE error(23)
END ('factor") ;
BEGIN ('term') factor;
WHILE sym IN [limes,slash] DO
BEGIN gelsym; faclor
END
END ("term") ;
BEGIN ("expression)
IF sym IN [plus,minus] THEN
BEGIN getsym; lerm
END ELSE lerm;
WHILE sym IN [plus,minus] DO
BEGIN gelsym; term
END
END ("expression) ;
PROCEDURE condition;
BEGIN
IF sym = oddsym THEN
BEGIN getsym; expression
END ELSE
BEGIN expression;
IF NOT (sym IN [eql,neq,lss,leq,glr,geq]) THEN
orror(20) ELSE
BEGIN gelsym; expression

END
END
END ('condition') ;
BEGIN (slatement")
IF sym = idenl THEN
BEGIN i := posilion(id);
IF i = OTJ-IEN error( 11) ELSE
IF lable[i].kind II variable THEN error(12);

71

72

rascal programs

getsym; IF sym = becomes THEN getsym ELSE errore 13);

expression
END ELSE
IF sym = callsym THEN
BEGIN getsym;
IF sym # ident THEN error(14) ELSE
BEGIN i := position(id);
IF i = 0 THEN errore 11) ELSE
IF table[i].kind It prozedure THEN errore 15);
getsyrn
END
END ELSE
IF sym = ifsym THEN
BEGIN gelsym; condition;
IF sym = thensym THEN getsyrn ELSE errore 16);
statement;
.
END ELSE
IF sym = beginsym THEN
BEGIN gelsym; stalemenl;
WHILE sym = semicolon DO
BEGIN getsym; slalement
END;
IF sym = endsym THEN gelsym ELSE errore 17)
END ELSE
IF sym = whilesyrn THEN
BEGIN gelsym; condition;
IF sym = dosym THEN getsym ELSE errore 18);
statement
END
END ('statement) ;
BEGIN ('block')
IF sym = conslsym THEN
BEGIN getsym; constdeclaration;
WHILE sym = comma DO
BEGIN gelsyrn; constdeclaralion
END;
IF sym = semicolon THEN getsym ELSE error(5)
END;
IF sym = varsym THEN
BEGIN gelsym; vardeclaralion;
WHILE sym = comma DO
BEGIN getsym; vardeclaralion
END;
IF sym = semicolon THEN gelsym ELSE error(5)
END;
WHILE sym = procsym DO
BEGIN gelsym;
IF sym = ide"l THEN
BEGIN enler(prozedure); gelsym
END
ELSE errore 4.);
IF sym = semicolon THEN gelsym ELSE error(5);
bJocltx);

Syntax analysis

IF sym = semicolon THEN getsym ELSE error(5);

END;
statement
END ("block") ;
BEGIN ("main program")
FOR ch := chr(O) TO chr(chsetsize-1) DO ssym[ch] := nul;
word[ 1] := "BEGIN
"; warde 2] ;= "CALL
";
word[ 3] := "CONST
"; warde 4] := "DO
";
word!: 5] := "END
"; warde 6] := "IF
";
word[ 7] := "000
"; warde 8] := "PROCEDURE ";
warde 9]:= "THEN
"; word[10]:= "VAR
";
word[ 11] := "WHILE
";
wsyrn[ 1] := beginsym; wsym[ 2] := callsym;
wsym[ 3] ;= constsym; wsym[ 4] ;= dosym;
wsym[ 5] := endsym; wsym[ 6] ~= ifsym;
wsym[ 7] := oddsyrn; wsym[ 8] := procsym;
wsym[ 9] ;= thensymj wsym[ 10] := varsym;
wsym[ 11] := whilesym;
ssym["+"] := plus;
ssymC"-"]:= minus;
ssym[ .. .. ] := times;
ssym["/"]:= slash;
ssym["("] ;= Iparen; ssyrn[")"]:= rparen;
ssym["="] := eql;
ssym[","] := comma;
ssym["."] ;= period; ssym["#"]:= neq;
ssym["<"] := Iss;
ssym[")"] := glr;
ssym[";"] := semicolon;
paget output);
cc := 0; II := 0; eh :=
kk := al; getsym;
block(O);
IF sym # period THEN error(9);
99; wrileln
END.
II

";

73

Berichte des Instituts fUr Informatik

* Nr. 1

* Nr. 2
Nr. 3
Nr. 4

* Nr. 5

* Nr.

Nf. 7

Nr. 8

* Nr.

* Nr.10

Nr.11

* Nr. 12
* Nr. 13
Nr.14
* Nr.15
Nr.16
Nr.17

* Nr .18
*Nr.19
Nr.20

* Nr. 21
Nr.22
Nr.23
Nr.24

N. Wirth
N. Wirth
P. Uiuchl i
W. Gander,
A. Mazzario
N. Wirth
C.A.R.Hoare,
N. Wirth
W. Gander,
A. Mazzario
E. Engel er,
E. Wiedmer,
E. Zachos
H.P. Frei

The Programming Language PASCAL

Program development by step-wise refi nement
Reduktion e1ektrischer Netzwerke und Gauss'sche Elimination
Numerische Prozeduren I
The Programming Language PASCAL (Revised Report)
An Axiomatic Definition of the Language PASCAL
Numerische Prozeduren II
Ein Einb1ick in die Theorie der Berechnungen
Computer Aided Instruction: The Author Language and
the System THALES

K.V. Nori,
U. Ammann,
K. Jensen, The Pascal "P' Compiler: Implementation Notes
H.H. Nage1i, (Revised Edition)
Ch. Jacobi
G.I. Ugron,
F.R. LUthi
N. Wirth
U. Ammann
K.Lieberherr
E. Engeler
W. Bucher
N. Wirth
N. ~Jirth
N. Wirth

Das Informations-System ELSBETH

PASCAL-S: A subset and its Implementation
Code Generati on ina PASCAL Compil er
Toward Feasible Solutions of NP-Complete Problems
Structural Relations between Programs and Problems
A contribution to solving large linear problems
Programming languages: what to demand and how to
access them
and
Professor C1everbyte's visit to heaven
MODULA: A 1anguage for modu1 ar multi programmi ng
The use of MODULA and
Design and Implementation of MODULA
Exaktes Rechnen mit reel len Zahlen

E. Wiedmer
J.Nievergelt,
H.P. Frei, XS-O, a Self-explanatory School Computer
et al.
P. Uiuchli Ein Problem der ganzzah1igen Approximation
K. Bucher
Automatisches Zeichnen von Diagrammen
E. Enge1er Generalized Galois Theory and its Applicationto Complexity

Nr.25

U. Ammann

Nr.26
Nr.27
Nr.28

E. Zachos

Nr.29
Nr.30
Nr.31
Nr.32
Nr.33

N. Wirth

Error Recovery in Recursive Descent Parsers and

Run-time Storage Organization
Kombinatorische Logik und S-Terme
MODULA-2

J.Nievergelt,S
tA
'1
Te11'1 ng t he User 0 fan
It
J Heyde t
1 tes, 'Iodes and Tral s:
n erac t'lve
.
r
System where he is, what he can do, and how to get to Places
A.C. Shaw
On the Specification of Graphic Command Languages and
their Processors
B.Thurnherr,
C.A.Zehnder Global Data Base Aspects, Consequences for the Relational
Model and a Conceptual Scheme Language
A.C. Shaw
Software Specification Languages based on regular Expressions
E. Engeler
Algebras and Combinators
N. Hirth
A Collection of PASCAL Programs

out of pri nt