Previous

Examples


11.1. Complex square root


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
Calls {5.4.3 } using compsqrt:

compsqrt(w) ·compsqrt(-3.14) ·compsqrt(-1)

11.2. Innerproduct 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)

11.3. Innerproduct 2


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 .

11.7. Determinant of a matrix


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.}

11.10. Formula manipulation


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 #

11.11. Information retrieval


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

11.D. Towers of Hanoi


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