PROC compsqrt = (COMPL z) COMPL :
# the square root whose real part is nonnegative of the complex number 'z' #
BEGIN REAL x = RE z, y = IM z;
REAL rp = sqrt ((ABS x + sqrt (x ^ 2 + y ^ 2)) / 2);
REAL ip = (rp = 0 | 0 | y / (2 * rp));
IF x >= 0 THEN rp I ip ELSE ABS ip I (y >= 0 | rp | -rp) FI
END
compsqrt(w) ·compsqrt(-3.14) ·compsqrt(-1)
PROC innerproduct 1 = ( INT n, PROC ( INT ) REAL x, y) REAL :
# the innerproduct of two vectors, each with 'n' components, x(i),
y(i), i = 1, \dots, n, where 'x' and 'y' are arbitrary mappings
from integer to real number #
BEGIN LONG REAL s := LONG 0;
FOR i TO n DO s +:= LENG x(i) * LENG y(i) OD;
SHORTEN s
END
Real-calls using innerproduct 1:
innerproduct 1(m, (INT j)REAL: x1 [j],(INT j)REAL:
y1 [j])
innerproduct 1(n, nsin, ncos)
PROC innerproduct 2= (REF [ ] REAL a, b) REAL :
IF UPB a - LWB a= UPB b - LWB b
THEN # the innerproduct of two vectors 'a' and 'b' with equal numbers of elements #
LONG REAL s := LONG 0;
REF [ ] REAL a1=a[@1], b1=b[@1];
# note that the bounds of 'a [@1]' are [1: UPB a- LWB a+1]#
FOR i TO UPB a1 DO s+:= LENG a1 [i] * LENG b1 [i] OD;
SHORTEN s
FI
Real-calls using innerproduct 2:
innerproduct2(x1, y1)
innerproduct2(y2 [2, ], y2 [ ,3])
11.4. Largest element
PROC absmax = (REF [, ] REAL a, # result # REF REAL y,
# subscripts # REF INT i, k) VOID:
# the absolute value of the element of greatest absolute value of
the matrix 'a' is assigned to 'y', and the subscripts of this
element to 'i' and 'k'#
BEGIN y := -1;
FOR p FROM 1 LWB a TO 1 UPB a
DO
FOR q FROM 2 LWB a TO 2 UPB a
DO
IF ABS a[p, q]>y THEN y := ABS a[i := p, k := q] FI
OD
OD
END
Calls using absmax:
absmax(x2, x, i,j) ·absmax(x2,
x, LOC INT, LOC INT )
11.5. Euler summation
A call using euler:
euler((INT i)REAL: (ODD i | -1/i | 1/i), 1.e-5, 2)
11.6. The norm of a vector
PROC norm = (REF [ ] REAL a) REAL :
# the euclidean norm of the vector 'a' #
( LONG REAL s := LONG 0;
FOR k FROM LWB a TO UPB a DO s+:= LENG a [k] ^ 2 OD;
SHORTEN long sqrt (s))
For a use of norm in a call, see 11.7
.
PROC det = (REF [, ] REAL x, REF [ ] INT p) REAL :
IF REF [, ] REAL a=x[@1, @1];
1 UPB a=2 UPB a&1 UPB a= UPB p - LWB p+1
THEN INT n=1 UPB a;
# the determinant of the square matrix 'a' of order 'n' by the
method of Crout with row interchanges: 'a' is replaced by its
triangular decomposition, l * u, with all u [k, k] = 1.
The vector 'p' gives as output the pivotal row indices; the \g{k}-th
pivot is chosen in the \g{k}-th column of T such that abs l [i, k] / row norm is maximal #
[ 1: n] REAL v; REAL d := 1, s, pivot;
FOR i TO n DO v[i] := norm(a [i, ]) OD;
FOR k TO n
DO INT k1=k-1; REF INT pk=p[@1] [k]; REAL r := -1;
REF [ , ]REAL al=a[, 1:k1], au=a[1: k1, ];
REF [ ]REAL ak=a[k, ], ka=a[, k], alk=al[k, ], kau=au[, k];
FOR i FROM k TO n
DO REF REAL aik=ka [i];
IF (s := ABS (aik -:= innerproduct 2(al [i, ], kau)) / v [i])> r
THEN r := s; pk := i
FI
OD;
v[pk]:= v[k]; pivot := ka[pk]; REF [ ]REAL apk=a[pk, ];
FOR j TO n
DO REF REAL akj=ak[j], apkj=apk [j];
r := akj;
akj := IF j <= k THEN apkj
ELSE (apkj - innerproduct 2 (alk, au [, j])) / pivot FI;
IF pk /= k THEN apkj := -r FI
OD;
d *:= pivot
OD;
d
FI
A call using det: det(y2,i1)
11.8. Greatest common divisor
PROC gcd = (INT a, b) INT:
# the greatest common divisor of two integers #
( b=0 | ABS a | gcd(b, a MOD b))
A call using gcd: gcd(n, 124)
11.9. Continued fraction
OP / = ([ ]REAL a, [ ]REAL b)REAL:
# the value of a / b is that of the continued fraction
a1 / (b1 +a2 / (b2+\dots an / bn)\dots)#
IF LWB a=1 & LWB b=1 & UPB a= UPB b
THEN ( UPB a=0 | 0 | a[1]/(b[1]+a[2: ] / b[2: ]))
FI
A formula using /: x1 / y1
{The use of recursion may often be elegant rather than
efficient as in the recursive procedure 11.8
and the
recursive operation 11.9
. See, however, 11.10
and 11.13
for examples in which recursion is of the essence.}
BEGIN
MODE FORM = UNION (REF CONST, REF VAR, REF TRIPLE, REF CALL);
MODE CONST = STRUCT (REAL value);
MODE VAR = STRUCT (STRING name, REAL value);
MODE TRIPLE = STRUCT (FORM left operand, INT operator, FORM right operand);
MODE FUNCTION = STRUCT (REF VAR bound var, FORM body);
MODE CALL = STRUCT (REF FUNCTION function name, FORM parameter);
INT plus=1, minus =2, times =3, by =4, to =5;
HEAP CONST zero, one; value OF zero := 0; value OF one := 1;
OP = = (FORM a, REF CONST b) BOOL: (a | (REF CONST ec): ec :=: b | FALSE);
OP + = (FORM a, b) FORM:
( a=zero | b |: b=zero | a | HEAP TRIPLE := (a, plus, b));
OP - = (FORM a, b) FORM: (b = zero | a | HEAP TRIPLE := (a, minus, b));
OP * = (FORM a, b)FORM: (a = zero OR b=zero | zero |: a=one | b |: b=one | a |
HEAP TRIPLE := (a, times, b));
OP / =(FORM a, b)FORM: (a = zero & (b =zero) | zero |: b=one | a |
HEAP TRIPLE := (a, by, b));
OP ^ = (FORM a, REF CONST b) FORM:
( a=one OR (b :=: zero) | one |: b :=: one | a | HEAP TRIPLE := (a, to, b));
PROC derivative of = (FORM e, # with respect to # REF VAR x) FORM:
CASE e IN
( REF CONST): zero,
( REF VAR ev): (ev :=: x | one | zero),
( REF TRIPLE et):
CASE FORM u = left operand OF et, v = right operand OF et;
FORM udash = derivative of(u, # with respect to # x),
vdash = derivative of(v, # with respect to # x);
operator OF et
IN
udash + vdash,
udash - vdash,
u * vdash + udash * v,
( udash -et * vdash) / v,
( v | (REF CONST ec): v * u ^ (HEAP CONST c;
value OF c := value OF ec - 1; c) * udash)
ESAC,
( REF CALL ef):
BEGIN REF FUNCTION f= function name OF ef;
FORM g = parameter OF ef; REF VAR y = bound var OF f;
HEAP FUNCTION fdash := (y, derivative of (body OF f, y));
( HEAP CALL := (fdash, g)) * derivative of(g, x)
END
ESAC;
PROC value of = (FORM e) REAL:
CASE e IN
( REF CONST ec): value OF ec,
( REF VAR ev): value OF ev,
( REF TRIPLE et):
CASE REAL u = value of (left operand OF et),
v = value of (right operand OF et);
operator OF et
IN u + v, u - v, u * v, u / v, exp (v * ln (u))
ESAC,
( REF CALL ef):
BEGIN REF FUNCTION f = function name OF ef;
value OF bound var OF f := value of (parameter OF ef);
value of (body OF f)
END
ESAC;
HEAP FORM f, g;
HEAP VAR a := ("a", SKIP), b := ("b", SKIP), x := ("x", SKIP);
# start here#
read ((value OF a, value OF b, value OF x));
f := a +x / (b + x);
g := (f+one) / (f-one);
print ((value OF a, value OF b, value OF x,
value of (derivative of(g, # with respect to # x))))
END # example OF formula manipulation #
BEGIN
MODE RA = REF AUTH, RB = REF BOOK;
MODE AUTH = STRUCT (STRING name, RA next, RB book),
BOOK = STRUCT (STRING title, RB next);
RA auth, first auth := NIL, last auth;
RB book; STRING name, title; INT i; FILE input, output;
open (input, "", remote in); open (output, "", remote out);
putf(output, ($ p
"to enter a new author, type ""author"", a space,"x
"and his name. "l
"to enter a new book, type ""book"", a space,"x
"the name of the author, a new line, and the title. "l
"for a listing of the books by an author, type ""hst"","x
"a space, and his name. "l
"to find the author of a book, type ""find"", a new line,"x
"and the title. "l
"to end, type ""end"""al$, "."));
PROC update = VOID:
IF RA (first auth) :=: NIL
THEN auth := first auth := last auth := HEAP AUTH := (name, NIL, NIL)
ELSE auth := first auth;
WHILE RA (auth) :/=: NIL
DO
( name = name OF auth | GO TO known | auth := next OF auth)
OD;
lastauth := next OF lastauth := auth :=
HEAP AUTH := (name, NIL, NIL);
known: SKIP
FI;
DO
try again:
getf(input, ($ c("author", "book", "list", "find", "end", ""), x30al, 80al$ , i));
CASE i IN
# author#
( getf(input, name); update),
# book #
BEGIN getf (input, (name, title)); update;
IF RB (book OF auth) :=: NIL
THEN book OF auth := HEAP BOOK := (title, NIL)
ELSE book := book OF auth;
WHILE RB (next OF book) :/=: NIL
DO
( title = title OF book
| GO TO try again | book := next OF book)
OD;
( title /= title OF book |
next OF book := HEAP BOOK := (title, NIL))
FI
END,
# list #
BEGIN getf(input, name); update;
putf(output, ($ p"author: "30all$ , name));
IF RB(book := book OF auth) :=: NIL
THEN put (output, ("no publications", newline))
ELSE on page end (output,
( REF FILE f) BOOL:
( putf(f, ($ p"author: "30a41k"continued"ll$ , name));
TRUE));
WHILE RB (book):/=: NIL
DO putf (output, ($l80a$ , title OF book)); book := next OF book
OD;
on page end (output, (REF FILE f) BOOL: FALSE)
FI
END,
# find#
BEGIN getf(input, (LOC STRING , title)); auth := first auth;
WHILE RA (auth) :/=: NIL
DO book := book OF auth;
WHILE RB (book):/=: NIL
DO
IF title = title OF book
THEN putf(output, ($l"author: "30a$ , name OF auth));
GO TO try again
ELSE book := next OF book
FI
OD;
auth := next OF auth
OD;
put (output, (newline, "unknown", newline))
END,
# end #
( put (output, (new page, "signed off", close)); close (input);
GOTO stop),
# error #
( put( output, (newline, "mistake, try again")); newline (input))
ESAC
OD
END
11.12. Cooperating sequential processes
BEGIN INT nmb magazine slots, nmb producers, nmb consumers;
read ((nmb magazine slots, nmb producers, nmb consumers));
[ 1: nmb producers] FILE in file; [1: nmb consumers] FILE out file;
FOR i TO nmb producers DO open (in file [i], "", inchannel [i]) OD;
# 'inchannel' and 'outchannel' are defined in a surrounding range #
FOR i TO nmb consumers
DO open (out file [i], "", outchannel [i]) OD;
MODE PAGE= [1: 60, 1:132] CHAR ;
[ 1: nmb magazine slots] REF PAGE magazine;
INT # pointers of a cyclic magazine # index:= 1, exdex := 1;
SEMA full slots = LEVEL 0, free slots = LEVEL nmb magazine slots,
in buffer busy = LEVEL 1, out buffer busy = LEVEL 1;
PROC par call = (PROC (INT) VOID p, INT n) VOID:
# call 'n' incarnations of 'p' in parallel #
( n> 0 | PAR (p (n), par call (p, n - 1)));
PROC producer = (INT i) VOID:
DO HEAP PAGE page;
get (in file [i], page);
DOWN free slots; DOWN in buffer busy;
magazine [index] := page;
index MODAB nmb magazine slots PLUSAB 1;
UP full slots; UP in buffer busy
OD;
PROC consumer = (INT i) VOID:
DO PAGE page;
DOWN full slots; DOWN out buffer busy;
page := magazine [exdex];
exdex MODAB nmb magazine slots PLUSAB 1;
UP free slots; UP out buffer busy;
put (out file [i], page)
OD;
PAR (par call (producer, nmb producers),
par call (consumer, nmb consumers))
END
FOR k TO 8
DO FILE f := stand out;
PROC p = (INT me, de, ma) VOID:
IF ma > 0 THEN
p (me, 6 - me - de, ma - 1);
putf(f, (me, de, ma));
# move from peg 'me' to peg 'de' piece 'ma' #
p(6-me-de, de, ma -1)
FI ;
putf(f, ($ l "k = "dl, n((2 ^ k+15) % 16)(2(2(4(3(d)x)x)x)l)$ , k));
p(1, 2, k)
OD
C Glossaries
12.1. Technical terms
Given below are the locations of the defining occurrences
of a number of words which, in this Report, have a specific technical meaning.
A word appearing in different grammatical forms is given once, usually
as the infinitive. Terms which are used only within pragmatic remarks are
enclosed within braces.
d>
{Denn eben, wo Begriffe fehlen, Da
stellt ein Wort zur rechten Zeit sich ein. Faust, J.W. von Goethe.}
12.2. Paranotions
Given below are short paranotions representing the notions
defined in this Report, with references to their hyper-rules.
12.5. Alphabetic listing of metaproduction
rules
Next