reduce-historical/r36/xlog/RLISP88.LOG

REDUCE 3.6, 15-Jul-95, patched to 6 Mar 96 ...


% Test of Rlisp88 version of Rlisp. Many of these functions are taken
% from the solved exercises in the book "RLISP '88: An Evolutionary
% Approach to Program Design and Reuse".

% Author: Jed B. Marti.

on rlisp88;


nil


% Confidence test tries to do a little of everything. This doesn't really
% test itself so  you need to compare to the log file. Syntax errors on
% the other hand should be cause for alarm.

%                             ARRAYS
% 1. Single dimension array.
global '(v1);


nil

v1 := mkarray 5;


[nil nil nil nil nil nil]

for i:=0:5 do v1[i] := 3**i;


nil

v1;


[1 3 9 27 81 243]



% 2. 2D array.
global '(v3x3);


nil

v3x3 := mkarray(2, 2);


[[nil nil nil] [nil nil nil] [nil nil nil]]

for row := 0:2 do
  for col := 0:2 do
     v3x3[row, col] := if row = col then 1.0 else 0.0;


nil

v3x3;


[[1.0 0.0e+000 0.0e+000] [0.0e+000 1.0 0.0e+000] [0.0e+000 0.0e+000 1.0]]


% 3. Triangular array.
global '(tri);


nil

tri := mkarray 3;


[nil nil nil nil]

for row := 0:3 do tri[row] := mkarray row;


nil

for row := 0:3 do
  for col := 0:row do
     tri[row,col] := row * col;


nil

tri;


[[0] [0 1] [0 2 4] [0 3 6 9]]


% 4. ARRAY test.
expr procedure rotate theta;
/* Generates rotation array for angle theta (in radians) */
array(array(cosd theta, - sind theta, 0.0),
      array(sind theta, cosd theta, 0.0),
      array(0.0, 0.0, 1.0));


rotate

rotate 45.0;


[[0.70710678118655 -0.70710678118655 0.0e+000] [0.70710678118655 0.70710678118655
0.0e+000] [0.0e+000 0.0e+000 1.0]]


% 5. Random elements.
% Now create a vector with random elements.
M3 := ARRAY('A, 3 + 4, ARRAY("String", 'ID), '(a b));


[a 7 ["String" id] (a b)]

M3[2, 1];


id

M4 := ARRAY(ARRAY('a, 'b), ARRAY('c, 'd));


[[a b] [c d]]

M4[1];


[c d]


% 6. Array addition.
expr procedure ArrayAdd(a, b);
if vectorp a then
    for i:=0:uc
        with c, uc
        initially c :=  mkarray(uc := upbv a)
        do c[i] := ArrayAdd(a[i], b[i])
        returns c
  else a + b;


arrayadd

ArrayAdd(array(array(array(1, 2), array(3, 4)),
               array(array(5, 6), array(7, 8))),
         array(array(array(1, 1), array(2, 2)),
               array(array(3, 3), array(4, 4))));


[[[2 3] [5 6]] [[8 9] [11 12]]]


%                               RECORDS
% 1: Declaration.
RECORD MAPF  /* A MAPF record defines
               the contents of a MAPF file. */
  WITH 
  MAPF!:NAME := ""        /* Name of MAPF (a string) */,
  MAPF!:NUMBER := 0       /* MAPF number (integer) */,
  MAPF!:ROAD-COUNT := 0   /* Number of roads */,
  MAPF!:NODE-COUNT := 0   /* Number of nodes */,
  MAPF!:LLAT := 0.0       /* Lower left hand corner map latitude */,
  MAPF!:LLONG := 0.0      /* Lower left hand corner map longitude */,
  MAPF!:ULAT := 0.0       /* Upper right hand corner map latitude */,
  MAPF!:ULONG := 0.0      /* Upper right hand corner map longitude */;


mapf


% 2: Creation.
global '(r1 r2 r3);


nil

r1 := mapf();


[mapf "" 0 0 0 0.0e+000 0.0e+000 0.0e+000 0.0e+000]

r2 := mapf(mapf!:name := "foobar", mapf!:road-count := 34);


[mapf "foobar" 0 34 0 0.0e+000 0.0e+000 0.0e+000 0.0e+000]

r3 := list('a . r1, 'b . r2);


((a . [mapf "" 0 0 0 0.0e+000 0.0e+000 0.0e+000 0.0e+000]) (b . [mapf "foobar" 0
34 0 0.0e+000 0.0e+000 0.0e+000 0.0e+000]))


% 3: Accessing.
mapf!:number r1;


0

mapf!:road-count cdr assoc('b, r3);


34


% 4: Assignment.
mapf!:number r1 := 7622;


7622

mapf!:road-count cdr assoc('b, r3) := 376;


376

mapf!:node-count(mapf!:name r2 := mapf()) := 34;


34

r2;


[mapf [mapf "" 0 0 34 0.0e+000 0.0e+000 0.0e+000 0.0e+000] 0 376 0 0.0e+000
0.0e+000 0.0e+000 0.0e+000]



% 5. Options.
RECORD complex /* Stores complex reals */
  WITH
   R := 0.0  /* Real part */,
   I := 0.0  /* Imaginary part */
  HAS CONSTRUCTOR;


complex

Make-Complex(I := 34.0, R := 12.0);


[complex 12.0 34.0]


RECORD Rational /* Representation of rational numbers */
  WITH
    Num := 0  /* Numerator */,
    Den := 1  /* Denominator */
  HAS CONSTRUCTOR = rat;


+++ num redefined as a macro

+++ den redefined as a macro

rational


expr procedure gcd(p, q);
if q > p then gcd(q, p)
else (if r = 0 then q else gcd(q, r)) where r = remainder(p,q);


gcd


expr procedure Rational(a, b);
/* Build a rational number in lowest terms */
  Rat(Num := a / g, Den := b / g) where g := gcd(a, b);


+++ rational redefined

rational

Rational(34, 12);


[rational 17 6]



RECORD Timing /* Timing Record for RLISP test */
  WITH
    Machine := ""    /* Machine name */,
    Storage := 0     /* Main storage in bits */,
    TimeMS = 0       /* Test time in milliseconds */
  HAS NO CONSTRUCTOR;


timing




% PREDICATE option.
RECORD History /* Record of an event */
  WITH
    EventTime := 0.0   /* Time of event (units) */,
    EventData := NIL   /* List with (type ...) */
  HAS PREDICATE = History!?;


history


History!? History(EventData := '(MOVE 34.5 52.5));


t



%                            FOR LOOP
% 1) Basic test.
EXPR PROCEDURE LPRINT lst;
/* LPRINT displays each element of its argument separated by blanks.
   After the last element has been displayed, the print line is
   terminated. */
FOR EACH element IN lst 
    DO << PRIN2 element; PRINC " " >>
    FINALLY TERPRI()
    RETURNS lst;


lprint

LPRINT '(Now is the time to use RLISP);

now is the time to use rlisp 

(now is the time to use rlisp)


% 2) Basic iteration in both directions.
FOR i:=5 STEP -2 UNTIL 0 DO PRINT i;

5
3
1

nil

FOR i:=1:3 DO PRINT i;

1
2
3

nil


% 3) COLLECT option.
FOR EACH leftpart IN '(A B C)
    EACH rightpart IN '(1 2 "string")
    COLLECT leftpart . rightpart;


((a . 1) (b . 2) (c . "string"))


% 4) IN/ON iterators.
FOR EACH X IN '(a b c) DO PRINT x;

a
b
c

nil

FOR EACH x ON '(a b c) DO PRINT x;

(a b c)
(b c)
(c)

nil



% 5) EVERY option.
FOR EACH x IN '(A B C) EVERY IDP x
    RETURNS "They are all id's";


"They are all id's"

FOR EACH x IN '(A B 12) EVERY IDP x
    RETURNS "They are all id's";


nil


% 6) INITIALLY/FINALLY option.
EXPR PROCEDURE ListPrint x;
/* ListPrint(x) displays each element of x separated by blanks. The
   first element is prefixed with "*** ". The last element is suffixed
   with a period and a new line. */
FOR EACH element ON x 
    INITIALLY PRIN2 "*** "
    DO << PRIN2 CAR element;
          IF CDR element THEN PRIN2 " " >>
    FINALLY << PRIN2 "."; TERPRI() >>;


listprint

ListPrint '(The quick brown bert died);

*** the quick brown bert died.

nil



% 7) MAXIMIZE/MINIMIZE options.
FOR EACH x IN '(A B 12 -34 2.3)
    WHEN NUMBERP x
    MAXIMIZE x;


12

FOR EACH x IN '(A B 12 -34 2.3)
    WHEN NUMBERP x
    MINIMIZE x;


-34



% 8) RETURNS option.
EXPR PROCEDURE ListFiddle(f, x);
/* ListFiddle displays every element of its second argument and returns
   a list of those for which the first argument returns non-NIL. */
FOR EACH element IN x
   WITH clist
   DO << PRINT element;
         IF APPLY(f, LIST element) THEN clist := element . clist >>
   RETURNS REVERSIP clist;


listfiddle

ListFiddle(FUNCTION ATOM, '(a (BANG 12) "OOPS!"));

a
(bang 12)
"OOPS!"

(a "OOPS!")



% 9) SOME option.
FOR EACH x IN '(a b 12) SOME NUMBERP x
    DO PRINT x;

a
b

t


% 10) UNTIL/WHILE options.
EXPR PROCEDURE CollectUpTo l;
/* CollectUpTo collect all the elements of the list l up to the
   first number. */
FOR EACH x IN l UNTIL NUMBERP x COLLECT x;


collectupto

CollectUpTo '(a b c 1 2 3);


(a b c)


% 11) WHEN/UNLESS options.
FOR EACH x IN '(A 12 "A String" 32)
    WHEN NUMBERP x
    COLLECT x;


(12 32)



% ##### Basic Tests #####
% Tests some very basic things that seem to go wrong frequently.

% Numbers.
if +1 neq 1 then error(0, "+1 doesn't parse");


nil

if -1 neq - 1 then error(0, "-1 doesn't parse");


nil


expr procedure factorial n;
if n < 2 then 1 else n * factorial(n - 1);


+++ factorial redefined

factorial


if +2432902008176640000 neq factorial 20 then 
    error(0, "bignum + doesn't work");


nil

if -2432902008176640000 neq - factorial 20 then
    error(0, "bignum - doesn't work");


nil


% This actually blew up at one time.
if -3.14159 neq - 3.14159 then error(0, "negative floats don't work");


nil

if +3.14159 neq 3.14159 then error(0, "positive floats don't work");


nil



% ##### Safe Functions #####

% Description: A set of CAR/CDR alternatives that
%    return NIL when CAR/CDR of an atom is tried.

expr procedure SafeCar x;
/* Returns CAR of a list or NIL. */
if atom x then nil else car x;


safecar


expr procedure SafeCdr x;
/* Returns CDR of a list or NIL. */
if atom x then nil else cdr x;


safecdr


expr procedure SafeFirst x; SafeCar x;


safefirst

expr procedure SafeSecond x; SafeCar SafeCdr x;


safesecond

expr procedure SafeThird x; SafeSecond SafeCdr x;


safethird



% ##### Test of Procedures #####

%------------------------- Exercise #1 -------------------------

expr procedure delassoc(x, a);
/* Delete the element from x from the alist a non-destructively. Returns
 the reconstructed list. */
if null a then nil
  else if atom a then a . delassoc(x, cdr a)
  else if caar a = x then cdr a
  else car a . delassoc(x, cdr a);


delassoc



if delassoc('a, '((a b) (c d))) = '((c d)) 
   then "Test 1 delassoc OK"
   else error(0, "Test 1 delassoc failed");


"Test 1 delassoc OK"


if delassoc('b, '((a b) (b c) (c d))) = '((a b) (c d))
   then "Test 2 delassoc OK"
   else error(0, "Test 2 delassoc failed");


"Test 2 delassoc OK"


if delassoc('c, '((a b) (b c) (c d))) = '((a b) (b c))
   then "Test 3 delassoc OK"
   else error(0, "Test 3 delassoc failed");


"Test 3 delassoc OK"


if delassoc('d, '((a b) (b c) (c d))) = '((a b) (b c) (c d))
   then "Test 4 delassoc OK"
   else error(0, "Test 4 delassoc failed");


"Test 4 delassoc OK"



%------------------------- Exercise #2 -------------------------
expr procedure gcd(u, v);
if v = 0 then u else gcd(v, remainder(u, v));


+++ gcd redefined

gcd


if gcd(2, 4) = 2 then "Test 1 GCD OK" else error(0, "Test 1 GCD fails");


"Test 1 GCD OK"

if gcd(13, 7) = 1
  then "Test 2 GCD OK" else error(0, "Test 2 GCD fails");


"Test 2 GCD OK"

if gcd(15, 10) = 5
  then "Test 3 GCD OK" else error(0, "Test 3 GCD fails");


"Test 3 GCD OK"

if gcd(-15, 10) = -5
  then "Test 4 GCD OK" else error(0, "Test 4 GCD fails");


"Test 4 GCD OK"

if gcd(-15, 0) = -15
  then "Test 5 GCD OK" else error(0, "Test 5 GCD fails");


"Test 5 GCD OK"



%-------------------- Exercise #3 --------------------
expr procedure properintersection(a, b);
/* Returns the proper intersection of proper sets a and b.
  The set representation is a list of elements with the
  EQUAL relation. */
if null a then nil
  else if car a member b then car a . properintersection(cdr a, b)
  else properintersection(cdr a, b);


properintersection


% Test an EQ intersection.
properintersection('(a b), '(b c));


(b)

if properintersection('(a b), '(b c)) = '(b)
     then "Test 1 properintersection OK"
     else error(0, "Test 1 properintersection fails");


"Test 1 properintersection OK"


% Test an EQUAL intersection.
properintersection('((a) b (c)), '((a) b (c)));


((a) b (c))

if properintersection('((a) b (c)), '((a) b (c))) = '((a) b (c))
     then "Test 2 properintersection OK"
     else error(0, "Test 2 properintersection fails");


"Test 2 properintersection OK"


% Test an EQUAL intersection, out of order.
properintersection('((a) b (c)), '(b (c) (a)));


((a) b (c))

if properintersection('((a) b (c)), '(b (c) (a))) = '((a) b (c))
     then "Test 3 properintersection OK"
     else error(0, "Test 3 properintersection fails");


"Test 3 properintersection OK"


% Test an empty intersection.
properintersection('((a) b (c)), '(a (b) c));


nil

if properintersection('((a) b (c)), '(a (b) c)) = nil
     then "Test 4 properintersection OK"
     else error(0, "Test 4 properintersection fails");


"Test 4 properintersection OK"




%-------------------- Exercise #4 -------------------------

expr procedure TreeVisit(a, tree, c);
/* Preorder visit of tree to find a. Returns path from root. c
  contains path to root of tree so far. */
if null tree then nil
  else if a = car tree then append(c, {a})
  else TreeVisit(a, cadr tree, append(c, {car tree})) or
       TreeVisit(a, caddr tree, append(c, {car tree}));


treevisit


TreeVisit('c, '(a (b (d nil nil) (c nil nil)) (e nil nil)), nil);


(a b c)

if TreeVisit('c, '(a (b (d nil nil) (c nil nil)) (e nil nil)), nil)
             = '(a b c)
     then "Test 1 TreeVisit OK"
     else error(0, "Test 1 TreeVisit fails");


"Test 1 TreeVisit OK"


TreeVisit('h, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil);


(a e g h)

if TreeVisit('h, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil))),nil) = '(a e g h)
     then "Test 2 TreeVisit OK"
     else error(0, "Test 2 TreeVisit fails");


"Test 2 TreeVisit OK"


if TreeVisit('i, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil) = nil
     then "Test 3 TreeVisit OK"
     else error(0, "Test 3 TreeVisit fails");


"Test 3 TreeVisit OK"


if TreeVisit('a, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil) = '(a)
     then "Test 4 TreeVisit OK"
     else error(0, "Test 4 TreeVisit fails");


"Test 4 TreeVisit OK"


if TreeVisit('e, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil) = '(a e)
     then "Test 5 TreeVisit OK"
     else error(0, "Test 5 TreeVisit fails");


"Test 5 TreeVisit OK"



%-------------------- Exercise #5 ------------------------- 

expr procedure lookfor(str, l);
/* Search for the list str (using =) in the top level
   of list l. Returns str and remaining part of l if
   found. */
if null l then nil
  else if lookfor1(str, l) then l
  else lookfor(str, cdr l);


lookfor


expr procedure lookfor1(str, l);
if null str then t
  else if null l then nil
  else if car str = car l then lookfor1(cdr str, cdr l);


lookfor1



if lookfor('(n o w),'(h e l l o a n d n o w i t i s)) = '(n o w i t i s)
  then "Test 1 lookfor OK"
  else error(0, "Test 1 lookfor fails");


"Test 1 lookfor OK"


if lookfor('(now is), '(now we have nothing is)) = NIL
  then "Test 2 lookfor OK"
  else error(0, "Test 2 lookfor fails");


"Test 2 lookfor OK"


if lookfor('(now is), '(well hello!, now)) = NIL
  then "Test 3 lookfor OK"
  else error(0, "Test 3 lookfor fails");


"Test 3 lookfor OK"



%-------------------- Exercise #6 ------------------------- 

expr procedure add(a, b, carry, modulus);
/* Add two numbers stored as lists with digits of
  modulus. Carry passes the carry around. Tries to
  suppress leading 0's but fails with negatives. */
if null a then
  if null b then if zerop carry then nil
                   else {carry}
  else remainder(carry + car b, modulus) .
        add(nil, cdr b, (carry + car b) / modulus, modulus)
else if null b then add(b, a, carry, modulus)
else remainder(car a + car b + carry, modulus) .
      add(cdr a, cdr b, (car a + car b + carry) / modulus,
          modulus);


add



if add('(9 9), '(9 9), 0, 10) = '(8 9 1)
  then "Test 1 add OK"
  else error(0, "Test 1 add fails");


"Test 1 add OK"


if add('(-9 -9), '(9 9), 0, 10) = '(0 0)
  then "Test 2 add OK"
  else error(0, "Test 2 add fails");


"Test 2 add OK"


if add('(9 9 9), '(9 9 9 9), 0, 10) = '(8 9 9 0 1)
  then "Test 3 add OK"
  else error(0, "Test 3 add fails");


"Test 3 add OK"


if add('(99 99 99), '(99 99 99 99), 0, 100) = '(98 99 99 0 1)
  then "Test 4 add OK"
  else error(0, "Test 4 add fails");


"Test 4 add OK"


if add('(13 12), '(15 1), 0, 16) = '(12 14)
  then "Test 5 add OK"
  else error(0, "Test 5 add fails");


"Test 5 add OK"



%-------------------- Exercise #7 ------------------------- 

expr procedure clength(l, tmp);
/* Compute the length of the (possibly circular) list l.
  tmp is used to pass values looked at down the list. */
if null l or l memq tmp then 0
  else 1 + clength(cdr l, l . tmp);


clength


if clength('(a b c), nil) = 3
  then "Test 1 clength OK"
  else error(0, "Test 1 clength fails");


"Test 1 clength OK"



<< xxx := '(a b c); cdr lastpair xxx := xxx; nil >>;


nil


if clength(xxx, nil) = 3
  then "Test 2 clength OK"
  else error(0, "Test 1 clength fails");


"Test 2 clength OK"


if clength(append('(a b c), xxx), nil) = 6
  then "Test 3 clength OK"
  else error(0, "Test 1 clength fails");


"Test 3 clength OK"


%------------------------- Exercise #8 -------------------------

expr procedure fringe x;
/* FRINGE(X) -- returns the fringe of X (the atoms at the
  end of the tree structure of X). */
if atom x then {x}
  else if cdr x then append(fringe car x, fringe cdr x)
  else fringe car x;


fringe


if fringe nil = '(NIL)
  then "Test 1 fringe OK"
  else error(0, "Test 1 fringe fails");


"Test 1 fringe OK"


if fringe '(a b . c) = '(a b c)
  then "Test 2 fringe OK"
  else error(0, "Test 2 fringe fails");


"Test 2 fringe OK"


if fringe '((((a) . b) (c . d)) . e) = '(a b c d e)
  then "Test 3 fringe OK"
  else error(0, "Test 3 fringe fails");


"Test 3 fringe OK"



%------------------------- Exercise #9 -------------------------
expr procedure delall(x, l);
/* DELALL(X, L) -- Delete all X's from the list L using EQUAL
  test. The list is reconstructed. */
if null l then nil
  else if x = car l then delall(x, cdr l)
  else car l . delall(x, cdr l);


delall


if delall('X, nil) = NIL
  then "Test 1 delall OK"
  else error(0, "Test 1 delall fails");


"Test 1 delall OK"


if delall('X, '(X)) = NIL
  then "Test 2 delall OK"
  else error(0, "Test 2 delall fails");


"Test 2 delall OK"


if delall('X, '(A)) = '(A)
  then "Test 3 delall OK"
  else error(0, "Test 3 delall fails");


"Test 3 delall OK"


if delall('(X B), '(A (B) (X B))) = '(A (B))
  then "Test 4 delall OK"
  else error(0, "Test 4 delall fails");


"Test 4 delall OK"


if delall('(X B), '((X B) (X B))) = NIL
  then "Test 5 delall OK"
  else error(0, "Test 5 delall fails");


"Test 5 delall OK"


if delall('(X B), '((X B) X B (X B))) = '(X B)
  then "Test 6 delall OK"
  else error(0, "Test 6 delall fails");


"Test 6 delall OK"



% ------------------------- Exercise #10 -------------------------
expr procedure startswith(prefix, word);
/* STARTSWITH(PREFIX, WORD) -- Returns T if the list of
  characters WORD begins with the list of characters PREFIX. */
if null prefix then T
  else if word then
     if car prefix eq car word then
         startswith(cdr prefix, cdr word);


startswith


if startswith('(P R E), '(P R E S I D E N T)) = T
  then "Test 1 startswith OK!"
  else error(0, "Test 1 startswith fails");


"Test 1 startswith OK!"


if startswith('(P R E), '(P O S T F I X)) = NIL
  then "Test 2 startswith OK!"
  else error(0, "Test 2 startswith fails");


"Test 2 startswith OK!"


if startswith('(P R E), '(P R E)) = T
  then "Test 3 startswith OK!"
  else error(0, "Test 3 startswith fails");


"Test 3 startswith OK!"


if startswith('(P R E), '(P R)) = NIL
  then "Test 4 startswith OK!"
  else error(0, "Test 4 startswith fails");


"Test 4 startswith OK!"


if startswith('(P R E), NIL) = NIL
  then "Test 5 startswith OK!"
  else error(0, "Test 5 startswith fails");


"Test 5 startswith OK!"


if startswith('(P R E), '(P P R E)) = NIL
  then "Test 6 startswith OK!"
  else error(0, "Test 6 startswith fails");


"Test 6 startswith OK!"



% ##### Test of Definitions #####

%------------------------- Exercise #1 -------------------------
expr procedure goodlist l;
/* GOODLIST(L) - returns T if L is a proper list. */
if null l then T
  else if pairp l then goodlist cdr l;


goodlist


if goodlist '(a b c) = T
  then "Test 1 goodlist OK"
  else error(0, "Test 1 goodlist fails");


"Test 1 goodlist OK"


if goodlist nil = T
  then "Test 2 goodlist OK"
  else error(0, "Test 2 goodlist fails");


"Test 2 goodlist OK"


if goodlist '(a . b) = NIL
  then "Test 3 goodlist OK"
  else error(0, "Test 3 goodlist fails");


"Test 3 goodlist OK"



%------------------------- Exercise #2 -------------------------
expr procedure fmember(a, b, fn);
/* FMEMBER(A, B, FN) - Returns rest of B is A is a member
  of B using the FN of two arguments as an equality check. */
if null b then nil
  else if apply(fn, {a, car b}) then b
  else fmember(a, cdr b, fn);


fmember


if fmember('a, '(b c a d), function EQ) = '(a d)
  then "Test 1 fmember is OK"
  else error(0, "Test 1 fmember fails");


"Test 1 fmember is OK"


if fmember('(a), '((b c) (a) d), function EQ) = NIL
  then "Test 2 fmember is OK"
  else error(0, "Test 2 fmember fails");


"Test 2 fmember is OK"


if fmember('(a), '((b c) (a) d), function EQUAL) = '((a) d)
  then "Test 3 fmember is OK"
  else error(0, "Test 3 fmember fails");


"Test 3 fmember is OK"


if fmember(34, '(1 2 56 12), function LESSP) = '(56 12)
  then "Test 4 fmember is OK"
  else error(0, "Test 4 fmember fails");


"Test 4 fmember is OK"


%------------------------- Exercise #3-4 -------------------------
expr procedure findem(l, fn);
/* FINDEM(L, FN) - returns a list of elements in L that satisfy
  the single argument function FN. */
if null l then nil
  else if apply(fn, {car l}) then car l . findem(cdr l, fn)
  else findem(cdr l, fn);


findem


if findem('(a 1 23 b "foo"), function idp) = '(a b)
  then "Test 1 findem OK!"
  else error(0, "Test 1 findem fails");


"Test 1 findem OK!"


if findem('(1 3 a (44) 12 9),
          function (lambda x; numberp x and x < 10)) = '(1 3 9)
  then "Test 2 findem OK!"
  else error(0, "Test 2 findem fails");


"Test 2 findem OK!"




%------------------------- Exercise #5 -------------------------
expr procedure insert(a, l, f);
/* Insert the value a into list l based on the partial ordering function
  f(x,y). Non-destructive insertion. */
if null l then {a}
  else if apply(f, {car l, a}) then a . l
  else car l . insert(a, cdr l, f);


insert



% Basic ascending order sort.
insert(6, '(1 5 10), function geq);


(1 5 6 10)

if insert(6, '(1 5 10), function geq) = '(1 5 6 10)
     then "Test 1 insert (>=) OK"
     else error(0, "Test 1 insert (>=) fails");


"Test 1 insert (>=) OK"


% Try inserting element at end of list.
insert(11, '(1 5 10), function geq);


(1 5 10 11)

if insert(11, '(1 5 10), function geq) = '(1 5 10 11)
     then "Test 2 insert (>=) OK"
     else error(0, "Test 2 insert (>=) fails");


"Test 2 insert (>=) OK"


% Tru inserting something at the list beginning.
insert(-1, '(1 5 10), function geq);


(-1 1 5 10)

if insert(-1, '(1 5 10), function geq) = '(-1 1 5 10)
     then "Test 3 insert (>=) OK"
     else error(0, "Test 3 insert (>=) fails");


"Test 3 insert (>=) OK"



% Insert into an empty list.
insert('34, nil, function leq);


(34)

if insert(34, nil, function leq) = '(34)
     then "Test 4 insert (<=) OK"
     else error(0, "Test 4 insert (<=) fails");


"Test 4 insert (<=) OK"


% Use a funny insertion function for (order . any);
expr procedure cargeq(a, b); car a >= car b;


cargeq

insert('(34 . any), '((5 . now) (20 . and) (30 . then) (40 . but)),
       function cargeq);


((5 . now) (20 . and) (30 . then) (34 . any) (40 . but))

if insert('(34 . any), '((5 . now) (20 . and) (30 . then) (40 . but)),
       function cargeq) = '((5 . now) (20 . and) (30 . then) (34 . any)
                            (40 . but))
     then "Test 5 insert (>=) OK"
     else error(0, "Test 5 insert (>=) fails");


"Test 5 insert (>=) OK"



% ###### FOR Loop Exercises #####

%------------------------- Exercise #1 -------------------------
expr procedure floatlist l;
/* FLOATLIST(L) returns a list of all floating point
   numbers in list L. */
for each x in l
    when floatp x
    collect x;


floatlist


if floatlist '(3 3.4 a nil) = '(3.4)
  then "Test 1 floatlist OK"
  else error(0, "Test 1 floatlist fails");


"Test 1 floatlist OK"


if floatlist '(3.4 1.222 1.0e22) = '(3.4 1.222 1.0e22)
  then "Test 2 floatlist OK"
  else error(0, "Test 2 floatlist fails");


"Test 2 floatlist OK"


if floatlist '(a b c) = NIL
  then "Test 3 floatlist OK"
  else error(0, "Test 3 floatlist fails");


"Test 3 floatlist OK"



%------------------------- Exercise #2 -------------------------
expr procedure revpairnum l;
/* REVPAIRNUM(L) returns elements of L in a pair with
  the CAR a number starting at length of L and working
  backwards.*/
for i:=length l step -1 until 0
    each x in l
    collect i . x;


revpairnum


if revpairnum '(a b c) = '((3 . a) (2 . b) (1 . c))
  then "Test 1 revpairnum OK"
  else error(0, "Test 1 revpairnum fails");


"Test 1 revpairnum OK"


if revpairnum  nil = nil
  then "Test 2 revpairnum OK"
  else error(0, "Test 2 revpairnum fails");


"Test 2 revpairnum OK"


if revpairnum '(a) = '((1 . a))
  then "Test 3 revpairnum OK"
  else error(0, "Test 3 revpairnum fails");


"Test 3 revpairnum OK"


%------------------------- Exercise #3 -------------------------
expr procedure lflatten l;
/* LFLATTEN(L) destructively flattens the list L
  to all levels. */
if listp l then for each x in l conc lflatten x
  else {l};


lflatten


if lflatten '(a (b) c (e (e))) = '(a b c e e)
  then "Test 1 lflatten OK"
  else error(0, "Test 1 lflatten fails");


"Test 1 lflatten OK"


if lflatten '(a b c) = '(a b c)
  then "Test 2 lflatten OK"
  else error(0, "Test 2 lflatten fails");


"Test 2 lflatten OK"


if lflatten nil = nil
  then "Test 3 lflatten OK"
  else error(0, "Test 3 lflatten fails");


"Test 3 lflatten OK"


if lflatten '(a (b (c (d)))) = '(a b c d)
  then "Test 4 lflatten OK"
  else error(0, "Test 4 lflatten fails");


"Test 4 lflatten OK"


%------------------------- Exercise #4 -------------------------
expr procedure realstuff l;
/* REALSTUFF(L) returns the number of non-nil items in l. */
for each x in l count x;


realstuff


if realstuff '(a b nil c) = 3
  then "Test 1 realstuff OK"
  else error(0, "Test 1 realstuff fails");


"Test 1 realstuff OK"


if realstuff '(nil nil nil) = 0
  then "Test 2 realstuff OK"
  else error(0, "Test 2 realstuff fails");


"Test 2 realstuff OK"


if realstuff '(a b c d) = 4
  then "Test 3 realstuff OK"
  else error(0, "Test 3 realstuff fails");


"Test 3 realstuff OK"


%------------------------- Exercise #5 -------------------------
expr procedure psentence s;
/* PSENTENCE(S) prints the list of "words" S with
  separating blanks and a period at the end. */
for each w on s
    do << prin2 car w;
          if cdr w then prin2 " " else prin2t "." >>;


psentence


psentence '(The man in the field is happy);

the man in the field is happy.

nil


%------------------------- Exercise #6 -------------------------
expr procedure bsort v;
/* BSORT(V) sorts the vector V into ascending order using
  bubble sort. */
for i:=0:sub1 upbv v
    returns v
    do for j:=add1 i:upbv v
           when i neq j and v[i] > v[j]
           with tmp
           do << tmp := v[j]; v[j] := v[i]; v[i] := tmp >>;


bsort


xxx := [4,3,2,1, 5];


[4 3 2 1 5]

if bsort xxx = [1,2,3,4,5]
  then "Test 1 bsort OK"
  else error(0, "Test 1 bsort fails");


"Test 1 bsort OK"


xxx := [1];


[1]

if bsort xxx = [1]
  then "Test 2 bsort OK"
  else error(0, "Test 2 bsort fails");


"Test 2 bsort OK"



%------------------------- Exercise #7 -------------------------
expr procedure bsortt v;
/* BSORTT(V) sorts the vector V into ascending order using
  bubble sort. It verifies that all elements are numbers. */
<< for i:=0:upbv v 
       when not numberp v[i]
       do error(0, {v[i], "is not a number for BSORTT"});
   for i:=0:sub1 upbv v
       returns v
       do for j:=add1 i:upbv v
              when i neq j and v[i] > v[j]
              with tmp
              do << tmp := v[j]; v[j] := v[i]; v[i] := tmp >> >>;


bsortt


xxx := [1,2,'a];


[1 2 a]

if atom errorset(quote bsortt xxx, nil, nil)
  then "Test 1 bsortt OK"
  else error(0, "Test 1 bsortt fails");


"Test 1 bsortt OK"


xxx := [1, 4, 3, 1];


[1 4 3 1]

if car errorset(quote bsortt xxx, nil, nil) = [1,1,3,4]
  then "Test 2 bsortt OK"
  else error(0, "Test 2 bsortt fails");


"Test 2 bsortt OK"



% ------------------------- Exercise #8 -------------------------
expr procedure average l;
/* AVERAGE(L) compute the average of the numbers
  in list L. Returns 0 if there are none. */
for each x in l
    with sm, cnt
    initially sm := cnt := 0
    when numberp x
    do << sm := sm + x; cnt := cnt + 1 >>
    returns if cnt > 0 then sm / cnt else 0;


average


if average '(a 12 34) = 23 then
  "Test 1 average OK"
  else error(0, "Test 1 average fails");


"Test 1 average OK"


if average '(a b c) = 0 then
  "Test 2 average OK"
  else error(0, "Test 2 average fails");


"Test 2 average OK"


if average '(a b c 5 6) = 5 then
  "Test 3 average OK"
  else error(0, "Test 3 average fails");


"Test 3 average OK"


if average '(a b c 5 6.0) = 5.5 then
  "Test 4 average OK"
  else error(0, "Test 4 average fails");


"Test 4 average OK"


%------------------------- Exercise #9 -------------------------
expr procedure boundingbox L;
/* BOUNDINGBOX(L) returns a list of
  (min X, max X, min Y, max Y)
 for the list L of dotted-pairs (x . y). */
{ for each x in L minimize car x,
  for each x in L maximize car x,
  for each y in L minimize cdr y,
  for each y in L maximize cdr y};


boundingbox



if boundingbox '((0 . 1) (4 . 5)) = '(0 4 1 5)
  then "Test 1 boundingbox OK"
  else error(0, "Test 1 boundingbox fails");


"Test 1 boundingbox OK"


if boundingbox nil = '(0 0 0 0)
  then "Test 2 boundingbox OK"
  else error(0, "Test 2 boundingbox fails");


"Test 2 boundingbox OK"


if boundingbox '((-5 . 3.4) (3.3 . 2.3) (1.2 . 33)
                 (-5 . -8) (22.11 . 3.14) (2 . 3)) = '(-5 22.11 -8 33)
  then "Test 3 boundingbox OK"
  else error(0, "Test 3 boundingbox fails");


"Test 3 boundingbox OK"



%------------------------- Exercise #10 -------------------------

expr procedure maxlists(a, b);
/* MAXLISTS(A, B) -- Build a list such that for each pair
  of elements in lists A and B the new list has the largest
  element. */
for each ae in a
    each be in b
    collect max(ae, be);


maxlists


if maxlists('(3 1.2), '(44.22 0.9 1.3)) = '(44.22 1.2)
  then "Test 1 maxlists OK"
  else error(0, "Test 1 maxlists fails");


"Test 1 maxlists OK"


if maxlists(nil, '(44.22 0.9 1.3)) = nil
  then "Test 2 maxlists OK"
  else error(0, "Test 2 maxlists fails");


"Test 2 maxlists OK"


if maxlists('(44.22 0.9 1.3), nil) = nil
  then "Test 3 maxlists OK"
  else error(0, "Test 3 maxlists fails");


"Test 3 maxlists OK"


if maxlists('(1.0 1.2 3.4), '(1 1)) = '(1.0 1.2)
  then "Test 4 maxlists OK"
  else error(0, "Test 4 maxlists fails");


"Test 4 maxlists OK"


%------------------------- Exercise #11 -------------------------
expr procedure numberedlist l;
/* NUMBEREDLIST(L) -- returns an a-list with the CAR being
  elements of L and CDR, the position in the list of the
  element starting with 0. */
for i:=0:length l
    each e in l
    collect e . i;


numberedlist


if numberedlist nil = nil
  then "Test 1 numberedlist is OK"
  else error(0, "Test 1 numberedlist fails");


"Test 1 numberedlist is OK"


if numberedlist '(a) = '((a . 0))
  then "Test 2 numberedlist is OK"
  else error(0, "Test 2 numberedlist fails");


"Test 2 numberedlist is OK"


if numberedlist '(a b c) = '((a . 0) (b . 1) (c . 2))
  then "Test 2 numberedlist is OK"
  else error(0, "Test 2 numberedlist fails");


"Test 2 numberedlist is OK"




%------------------------- Exercise #12 -------------------------
expr procedure reduce x;
/* REDUCE(X) -- X is a list of things some of which are
  encapsulated as (!! . y) and returns x. Destructively
  replace these elements with just y. */
for each v on x
    when eqcar(car v, '!!)
    do car v := cdar v
    returns x;


reduce


global '(x11);


nil

x11 := '((!! . a) (b c) (d (!! . 34)));


((!! . a) (b c) (d (!! . 34)))


if reduce x11 = '(a (b c) (d (!! . 34)))
  then "Test 1 reduce OK"
  else error(0, "Test 1 reduce fails");


"Test 1 reduce OK"


if x11 = '(a (b c) (d (!! . 34)))
  then "Test 2 reduce OK"
  else error(0, "Test 2 reduce fails");


"Test 2 reduce OK"



% ##### Further Procedure Tests #####

%------------------------- Exercise #1 -------------------------
expr procedure removeflags x;
/* REMOVEFLAGS(X) -- Scan list x replacing each top level
  occurrence of (!! . x) with x (whatever x is) and return
  the list. Replacement is destructive. */
while x and eqcar(car x, '!!)
      with v
      initially v := x
      do << print x; car x := cdar x;  print x; x := cdr x >>
      returns v;


removeflags


xxx := '((!!. a) (!! . b) c (!! . d));


((!! . a) (!! . b) c (!! . d))

if removeflags xxx = '(a b c (!! . d))
 then "Test 1 removeflags OK"
 else error(0, "Test 1 removeflags fails");

((!! . a) (!! . b) c (!! . d))
(a (!! . b) c (!! . d))
((!! . b) c (!! . d))
(b c (!! . d))

"Test 1 removeflags OK"


if xxx = '(a b c (!! . d))
 then "Test 2 removeflags OK"
 else error(0, "Test 2 removeflags fails");


"Test 2 removeflags OK"



%------------------------- Exercise #2 -------------------------

expr procedure read2char c;
/* READ2CHAR(C) -- Read characters to C and return the
 list including C. Terminates at end of file. */
repeat l := (ch := readch()) . l
       with ch, l
       until ch eq c or ch eq !$EOF!$
       returns reversip l;


read2char


if read2char '!* = {!$EOL!$, 'A, 'B, 'C, '!*}
  then "Test 1 read2char OK"
  else error(0, "Test 1 read2char fails");


ABC*
"Test 1 read2char OK"


%------------------------- Exercise #3 -------------------------

expr procedure skipblanks l;
/* SKIPBLANKS(L) - Returns L with leading blanks
  removed. */
while l and eqcar(l, '! )
      do l := cdr l
      returns l;


skipblanks


if skipblanks '(!  !  !  a b) neq '(a b)
  then error(0, "Skipblanks fails test #1");


nil


if skipblanks nil
  then error(0, "Skipblanks fails test #2");


nil


if skipblanks '(!  !  !  )
  then error(0, "Skipblanks fails test #3");


nil


if skipblanks '(!  !  a b !  ) neq '(a b ! )
  then error(0, "Skipblanks fails test #4");


nil


%------------------------- Exercise #4 -------------------------

expr procedure ntoken l;
/* NTOKEN(L) - Scan over blanks in l. Then collect
  and return all characters up to the next blank
  returning a dotted-pair of (token . rest of L) or
  NIL if none is found. */
while l and eqcar(l, '! ) do l := cdr l
 returns
  if l then
     while l and not eqcar(l, '! )
           with tok
           do << tok := car l . tok;
                 l := cdr l >>
           returns (reversip tok . l);


ntoken



if ntoken '(!  !  a b !  ) neq '((a b) . (!  ))
  then error(0, "ntoken fails test #1");


nil


if ntoken nil then error(0, "ntoken fails test #2");


nil


if ntoken '(!  !  !  ) then  error(0, "ntoken fails test #3");


nil


if ntoken '(!  !  a b) neq '((a b) . nil) 
  then error(0, "ntoken fails test #4");


nil



% ##### Block Statement Exercises #####

%------------------------- Exercise #1 -------------------------
expr procedure r2nums;
/* R2NUMS() -- Read 2 numbers and return as a list. */
begin scalar n1;
  n1 := read();
  return {n1, read()}
end;


r2nums


if r2nums() = '(2 3)
  then "Test 1 r2nums OK"
  else error(0, "Test 1 r2nums failed");


2  3

"Test 1 r2nums OK"

%------------------------- Exercise #2 -------------------------
expr procedure readcoordinate;
/* READCOORDINATE() -- Read a coordinate and return
 it in radians. If prefixed with @, convert from
 degrees. If a list convert from degrees minutes
 seconds. */
begin scalar x;
  return
    (if (x := read()) eq '!@ then read() / 57.2957795130823208767981
      else if pairp x then
        (car x + cadr x / 60.0 + caddr x / 3600.0)
            / 57.2957795130823208767981
      else x)
end;


readcoordinate


fluid '(val);


nil

val := readcoordinate();


@  57.29577

0.99999983396539
if val < 1.000001 AND val > 0.999999
  then "Test 1 readcoordinate OK"
  else error(0, "Test 1 readcoordinate failed");


"Test 1 readcoordinate OK"


% This fails with poor arithmetic.
val := readcoordinate();


(57 17 44.772)
0.99999983396539

if val < 1.000001 AND val > 0.999999
  then "Test 2 readcoordinate OK"
  else error(0, "Test 2 readcoordinate failed");


"Test 2 readcoordinate OK"

unfluid '(val);


nil



if readcoordinate() = 1.0
  then "Test 3 readcoordinate OK"
  else error(0, "Test 3 readcoordinate failed");


1.0

"Test 3 readcoordinate OK"


%------------------------- Exercise #3 -------------------------
expr procedure delallnils l;
/* DELALLNILS(L) - destructively remove all NIL's from
  list L. The resulting value is always EQ to L. */
begin scalar p, prev;
   p := l;
loop: if null p then return l;
    if null car p then 
      if null cdr p then
         if null prev then return nil
         else << cdr prev := nil;
                 return l >>
      else << car p := cadr p;
              cdr p := cddr p;
              go to loop >>;
    prev := p;
    p := cdr p;
    go to loop
end;


delallnils


fluid '(xxx yyy);


nil
    % New - added to aid CSL.
xxx := '(a b c nil d);


(a b c nil d)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 1 dellallnils OK"
  else error(0, "Test 1 delallnils Fails!");


"Test 1 dellallnils OK"


xxx := '(a nil b nil c nil d);


(a nil b nil c nil d)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 2 dellallnils OK"
  else error(0, "Test 2 delallnils Fails!");


"Test 2 dellallnils OK"


xxx := '(a nil b nil c nil d nil);


(a nil b nil c nil d nil)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 3 dellallnils OK"
  else error(0, "Test 3 delallnils Fails!");


"Test 3 dellallnils OK"


xxx := '(a nil nil nil nil b c d);


(a nil nil nil nil b c d)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 4 dellallnils OK"
  else error(0, "Test 4 delallnils Fails!");


"Test 4 dellallnils OK"


xxx := '(nil a b c d);


(nil a b c d)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 5 dellallnils OK"
  else error(0, "Test 5 delallnils Fails!");


"Test 5 dellallnils OK"


xxx := '(nil nil nil a b c d);


(nil nil nil a b c d)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 6 dellallnils OK"
  else error(0, "Test 6 delallnils Fails!");


"Test 6 dellallnils OK"


xxx := '(a b c d nil nil nil);


(a b c d nil nil nil)

yyy := delallnils xxx;


(a b c d)

if yyy = '(a b c d) and yyy eq xxx
  then "Test 7 dellallnils OK"
  else error(0, "Test 7 delallnils Fails!");


"Test 7 dellallnils OK"



%------------------------- Exercise 4 -------------------------

expr procedure dprin1 x;
/* DPRIN1(X) - Print X in dotted-pair notation (to
  all levels). Returns X as its value. */
if vectorp x then 
  << prin2 "[";
     for i:=0:upbv x
         do << dprin1 x[i];
               if i < upbv x then prin2 " " >>;
     prin2 "]";
     x >>
  else if atom x then prin1 x
  else << prin2 "(";
          dprin1 car x;
          prin2 " . ";
          dprin1 cdr x;
          prin2 ")";
          x >>;


dprin1


% The test is hard to make because we're doing output.
% Verify the results by hand and make sure it returns the
% argument.
dprin1 nil;

nil
nil

dprin1 '(a . b);

(a . b)
(a . b)

dprin1 '(a 1 "foo");

(a . (1 . ("foo" . nil)))
(a 1 "foo")

dprin1 '(((a)));

(((a . nil) . nil) . nil)
(((a)))

<< x := mkvect 2; x[0] := 'a; x[1] := '(b c); x[2] := 34; >>;


nil

dprin1 {'(b c), x, 34};

((b . (c . nil)) . ([a (b . (c . nil)) 34] . (34 . nil)))
((b c) [a (b c) 34] 34)



% ##### Property List Exercises #####

%---------------------------- Exercise #1 ------------------------------

global '(stack!*);


nil

expr procedure pexecute l;
/* PEXECUTE(L) - L is a stack language. Constants are
  placed on the global stack!*, id's mean a function
  call to a function under the STACKFN property of the
  function name. Other values are placed on the stack
  without evaluation. */
if null l then nil
else if constantp car l then
    << stack!* := car l . stack!*;
       pexecute cdr l >>
  else if idp car l then
    if get(car l, 'STACKFN) then
       << apply(get(car l, 'STACKFN), nil);
          pexecute cdr l >>
    else error(0, {car l, "undefined function"})
  else << stack!* := car l . stack!*;
          pexecute cdr l >>;


pexecute


 expr procedure pdiff;
/* PADD1() - Subtract the 2nd stack elt from the
  first and replace top two entries with result. */
stack!* := (cadr stack!* - car stack!*) . cddr stack!*;


pdiff

put('!-, 'STACKFN, 'pdiff);


pdiff


expr procedure pplus2;
/* PPLUS2() - Pop and add the top two numbers
  on the stack and push the result. */
stack!* := (car stack!* + cadr stack!*) . cddr stack!*;


pplus2

put('!+, 'STACKFN, 'pplus2);


pplus2


expr procedure pprint;
/* PPRINT() - Print the top stack element. */
print car stack!*;


pprint

put('PRINT, 'STACKFN, 'pprint);


pprint



pexecute '(3 4 !+);


nil

if stack!* neq '(7) then error(0, "PEXECUTE test #1 fails");


nil

stack!* := nil;


nil


pexecute '(5 3 !- 2 4 !+ !+);


nil

if stack!* neq '(8) then error(0, "PEXECUTE test #2 fails");


nil



%---------------------------- Exercise #2 ------------------------------

expr procedure pexecute l;
/* PEXECUTE(L) - L is a stack language. Constants are
  placed on the global stack!*, id's mean a function
  call to a function under the STACKFN property of the
  function name. Other values are placed on the stack
  without evaluation. */
if null l then nil
else if constantp car l then
    << stack!* := car l . stack!*;
       pexecute cdr l >>
  else if idp car l then
    if eqcar(l, 'QUOTE) then
       << stack!* := cadr l . stack!*;
          pexecute cddr l >>
    else if flagp(car l, 'STACKVAR) then
       << stack!* := get(car l, 'STACKVAL) . stack!*;
          pexecute cdr l >>
    else if get(car l, 'STACKFN) then
       << apply(get(car l, 'STACKFN), nil);
          pexecute cdr l >>
    else error(0, {car l, "undefined function"})
  else << stack!* := car l . stack!*;
          pexecute cdr l >>;


+++ pexecute redefined

pexecute



expr procedure pset;
/* PSET() - Put the second value on the stack under
  the STACKVAL attribute of the first. Flag the id as
  a STACKVAR for later use. Pop the top stack
  element. */
<< put(car stack!*, 'STACKVAL, cadr stack!*);
   flag({car stack!*}, 'STACKVAR);
   stack!* := cdr stack!* >>;


pset

put('SET, 'STACKFN, 'pset);


pset


stack!* := nil;


nil

pexecute '(4.5 quote x set 4 !+ x !+ PRINT);

13.0

nil

if stack!* neq '(13.0) then error(0, "Test 3 PEXECUTE fails");


nil



% ##### Records Exercises #####

%------------------------- Exercise #1 -------------------------

record qtree /* QTREE is a quad tree node element. */
 with
   node := NIL        /* Node name */,
   q1 := NIL          /* Child #1 */,
   q2 := NIL          /* Child #2 */,
   q3 := NIL          /* Child #3 */,
   q4 := NIL          /* Child #4 */;


qtree



expr procedure qvisit q;
/* QVISIT(Q) -- Q is a QTREE data structure or NIL as are
  each of its children. Return a preorder visit of each
  node. */
if null q then nil
  else append({node q},
              append(qvisit q1 q,
               append(qvisit q2 q,
                append(qvisit q3 q, qvisit q4 q))));


qvisit



/* A simple quad tree. */
global '(qdemo);


nil

qdemo := qtree(node := 'A,
            q1 := qtree(node := 'B),
            q2 := qtree(node := 'C),
            q3 := qtree(node := 'D,
                        q1 := qtree(node := 'E)),
            q4 := qtree(node := 'F));


[qtree a [qtree b nil nil nil nil] [qtree c nil nil nil nil] [qtree d [qtree e
nil nil nil nil] nil nil nil] [qtree f nil nil nil nil]]


if qvisit qdemo = '(A B C D E F)
  then "Test 1 qvisit OK!"
  else error(0, "Test 1 qvisit Fails!");


"Test 1 qvisit OK!"


/* The quadtree in the book. */
global '(qdemo2);


nil

qdemo2 := qtree(node := 'A,
    q1 := qtree(node := 'B),
    q2 := qtree(node := 'C),
    q3 := qtree(node := 'D,
         q1 := qtree(node := 'E,
            q2 := qtree(node := 'F)),
         q2 := qtree(node := 'G),
         q3 := qtree(node := 'H),
         q4 := qtree(node := 'I)));


[qtree a [qtree b nil nil nil nil] [qtree c nil nil nil nil] [qtree d [qtree e
nil [qtree f nil nil nil nil] nil nil] [qtree g nil nil nil nil] [qtree h nil nil
nil nil] [qtree i nil nil nil nil]] nil]


if qvisit qdemo2 = '(A B C D E F G H I)
  then "Test 2 qvisit OK!"
  else error(0, "Test 2 qvisit Fails!");


"Test 2 qvisit OK!"


if qvisit nil = NIL
  then "Test 3 qvisit OK!"
  else error(0, "Test 3 qvisit Fails!");


"Test 3 qvisit OK!"



%------------------------- Exercise #2 -------------------------

expr procedure qsearch(q, val, fn);
/* QSEARCH(Q, VAL, FN) -- Returns the node path from the
  root of the quadtree Q to VAL using FN as an equality
  function whose first argument is from the tree and
  second VAL. */
if null q then nil
else if apply(fn, {val, node q}) then {node q}
else begin scalar v;
  if v := qsearch(q1 q, val, fn) then return node q . v;
  if v := qsearch(q2 q, val, fn) then return node q . v;
  if v := qsearch(q3 q, val, fn) then return node q . v;
  if v := qsearch(q4 q, val, fn) then return node q . v
end;


qsearch


if qsearch(qdemo, 'E, function EQ) = '(A D E)
  then "Test 1 qsearch OK!"
  else error(0, "Test 1 qsearch fails");


"Test 1 qsearch OK!"


if qsearch(qdemo, 'XXX, function EQ) = nil
  then "Test 2 qsearch OK!"
  else error(0, "Test 2 qsearch fails");


"Test 2 qsearch OK!"


if qsearch(qdemo2, 'F, function EQ) = '(A D E F)
  then "Test 3 qsearch OK!"
  else error(0, "Test 3 qsearch fails");


"Test 3 qsearch OK!"



%------------------------- Exercise #3 -------------------------

record commchain
/* A COMMCHAIN is an n-ary tree with superior and
 subordinate links. */
with 
  name := NIL          /* Name of this node. */,
  superior := NIL      /* Pointer to superior node. */,
  subordinates := NIL  /* List of subordinates. */;


commchain



expr procedure backchain(l, sup);
/* BACKCHAIN(L, SUP) -- Fill in the SUPERIOR fields of
  each record in the n-ary tree (links in the SUBORDINATES
  field) to the lowest level. SUP is the current 
  superior. */
if null l then nil
 else << superior l := sup;
         for each sb in subordinates l
             do backchain(sb, l) >>;


backchain


/* Demo the back chain. */
global '(cch);


nil

cch :=
  commchain(
    name := 'TOP,
    subordinates :=
      {commchain(name := 'LEV1-A),
       commchain(
          name := 'LEV1-B,
          subordinates := 
            {commchain(name := 'LEV2-A),
             commchain(name := 'LEV2-B)}),
       commchain(name := 'LEV1-C)});


[commchain top nil ([commchain lev1!-a nil nil] [commchain lev1!-b nil ([
commchain lev2!-a nil nil] [commchain lev2!-b nil nil])] [commchain lev1!-c nil
nil])]


% Wrap this up to avoid printing problems. 
<< backchain(cch, 'COMMANDER); NIL >>;


nil



if superior cch EQ 'COMMANDER
  then "Test 1 backchain OK!"
  else error(0, "Test 1 backchain Fails!");


"Test 1 backchain OK!"


if name superior car subordinates cch EQ 'TOP
  then "Test 2 backchain OK!"
  else error(0, "Test 2 backchain Fails!");


"Test 2 backchain OK!"


if name superior car subordinates cadr subordinates cch
      eq 'LEV1-B
  then "Test 3 backchain OK!"
  else error(0, "Test 3 backchain Fails!");


"Test 3 backchain OK!"



% ##### Local Variable Exercises #####

%------------------------- Exercise #1 -------------------------

expr procedure lookup(v, a);
/* LOOKUP(V, A) -> Look for V in A and signal an error if not present.*/
(if rv then cdr rv else error(0, {v, "not in association list"}))
  where rv := assoc(v, a);


lookup



if lookup('a, '((a . b) (c . d))) = 'b
  then "Test 1 lookup success"
  else error(0, "Test 1 lookup fails");


"Test 1 lookup success"


if errorset(quote lookup('f, '((a . b) (c . d))), nil, nil) = 0
  then "Test 2 lookup success"
  else error(0, "Test 2 lookup fails");


"Test 2 lookup success"


%------------------------- Exercise #2 -------------------------

expr procedure quadratic(a, b, c);
/* QUADRATIC(A, B, C) -- Returns both solutions of the
  quadratic equation A*X^2 + B*X + C */
{(-B + U) / V, (-B - U) / V}
  where U := SQRT(B^2 - 4*A*C),
        V := 2.0 * A;


quadratic


if quadratic(1.0, 2.0, 1.0) = '(-1.0 -1.0)
  then "Test 1 quadratic OK!"
  else error(0, "Test 1 quadratic Fails!");


"Test 1 quadratic OK!"


if quadratic(1.0, 0.0, -1.0) = '(1.0 -1.0)
  then "Test 2 quadratic OK!"
  else error(0, "Test 2 quadratic Fails!");


"Test 2 quadratic OK!"



%------------------------- Exercise #3 -------------------------
expr procedure lineintersection(x1, y1,
                                x2, y2,
                                x3, y3,
                                x4, y4);
/* LINEINTERSECTION(X1,Y1,X2,Y2,X3,Y3,X4,Y4) -
  Computes the intersection of line X1,Y1 ->
  X2,Y2 with X3,Y3 -> X4,Y4 if any. Returns NIL
  if no such intersection. */
(if zerop denom or zerop d1 or zerop d2 then nil
    else
     ((if p1 < 0 or p1 > d1 or p2 < 0 or p2 > d2
       then nil
       else (x1 + (x2 - x1) * p1 / d1) .
            (y1 + (y2 - y1) * p1 / d1))
          where p1 := num1 / denom,
                p2 := num2 / denom)
    where 
      num1 := d1*(x1*y3 - x1*y4 - x3*y1 + x3*y4
              + x4*y1 - x4*y3),
      num2 := d2*(- x1*y2 + x1*y3 + x2*y1 - x2*y3
              - x3*y1 + x3*y2))
where d1 :=sqrt((x2 - x1)^2 + (y2 - y1)^2),
      d2 := sqrt((x4 - x3)^2 + (y4 - y3)^2),
      denom := x1*y3 - x1*y4 - x2*y3 + x2*y4
               - x3*y1 + x3*y2 + x4*y1 - x4*y2;


lineintersection


if lineintersection(1, 1, 3, 3, 1, 2, 5, 2) = '(2.0 . 2.0)
  then "Test 1 LINEINTERSECTION success!"
  else error(0, "Test 1 LINEINTERSECTION fails intersect test");


"Test 1 LINEINTERSECTION success!"


% intersection at start and end points.
if lineintersection(1, 1, 2, 2, 1, 1, 1, 0) = '(1.0 . 1.0)
  then "Test 2 LINEINTERSECTION success!"
  else error(0, "Test 2LINEINTERSECTION fails intersect at start test");


"Test 2 LINEINTERSECTION success!"

if lineintersection(1, 1, 2, 2, 0, 1, 2, 2) = '(2.0 . 2.0)
  then "Test 3 LINEINTERSECTION success!"
  else error(0,
            "Test 3 LINEINTERSECTION fails intersect at endpoint test");


"Test 3 LINEINTERSECTION success!"

if lineintersection(1, 1, 2, 2, 2, 2, 3, 4) = '(2.0 . 2.0)
  then "Test 4 LINEINTERSECTION success!"
  else error(0,
      "Test 4 LINEINTERSECTION fails intersect end - begin point test");


"Test 4 LINEINTERSECTION success!"


% Now try no intersection test.
if null lineintersection(1, 1, 2, 3, 2, 4, 4, 5)
  then "Test 5 LINEINTERSECTION success!"
  else error(0,
            "Test 5 LINEINTERSECTION fails quadrant 1 no intersection");


"Test 5 LINEINTERSECTION success!"

if null lineintersection(1, 1, 2, 2, 1.75, 1.5, 5, 1.75)
  then "Test 6 LINEINTERSECTION success!"
  else error(0,
            "Test 6 LINEINTERSECTION fails quadrant 2 no intersection");


"Test 6 LINEINTERSECTION success!"




%------------------------- Exercise #4 -------------------------

expr procedure stdev x;
/* STDEV(X) - compute the standard deviation of the
  numbers in list X. */
if null x then 0
else (sqrt((for each v in x sum (v - avg)^2) / n)
         where avg := (for each v in x sum v) / n)
           where n := length x;


stdev


if stdev '(3.0 3.0 3.0) neq 0.0 then
  error(0, "Test 1 STDEV fails");


nil



% ##### Array Exercises #####

%------------------------- Exercise #1 -------------------------
expr procedure vaverage v;
/* VAVERAGE(V) -- compute the average of all numeric
  elements of the vector v. */
(if cnt > 0 then
    ((for i:=0:upbv v when numberp v[i] sum v[i]) / float cnt)
  else 0.0)
 where cnt := for i:=0:upbv v count numberp v[i];


vaverage


if vaverage array(1,2,3) = 2.0
  then "Test 1 vaverage is OK"
  else error(0, "Test 1 vaverage fails");


"Test 1 vaverage is OK"


if vaverage array(3, 'a, 3, 6.0, 'f) = 4.0
  then "Test 2 vaverage is OK"
  else error(0, "Test 2 vaverage fails");


"Test 2 vaverage is OK"


if vaverage array('a, 'b) = 0.0
  then "Test 3 vaverage is OK"
  else error(0, "Test 3 vaverage fails");


"Test 3 vaverage is OK"


%------------------------- Exercise #2 -------------------------

expr procedure MAPPEND(a, b);
/* MAPPEND(A, B) -- Appends array B to array A and
  returns a new array with both. */
begin scalar c, ua;
  c := mkvect((ua := 1 + upbv a) + upbv b);
  for i:=0:upbv a do c[i] := a[i];
  for i:=0:upbv b do c[i + ua] := b[i];
  return c
end;


+++ mappend redefined

mappend


global '(a1 a2);


nil

a1 := array(1, 2, 3);


[1 2 3]

a2 := array(3, 4, 5, 6);


[3 4 5 6]


if mappend(a1, a2) = array(1,2,3,3,4,5,6)
  then "Test 1 MAPPEND is OK"
  else error(0, "Test 1 MAPPEND fails");


"Test 1 MAPPEND is OK"


if mappend(mkvect 0, mkvect 0) = mkvect 1
  then "Test 2 MAPPEND is OK"
  else error(0, "Test 2 MAPPEND fails");


"Test 2 MAPPEND is OK"



%------------------------- Exercise #3 -------------------------

expr procedure indx(a, v);
/* INDX(A, V) -- returns index of A in V using EQ test,
  otherwise NIL. */
for i:=0:upbv v
    until a eq v[i]
    returns if i <= upbv v then i


if indx('a, array(1, 2, 'a, 34)) = 2
  then "Test 1 indx OK"
  else error(0, "Test 1 indx fails");


indx


if null indx('a, array(1, 2, 3, 4))
  then "Test 2 indx OK"
  else error(0, "Test 2 indx fails");


"Test 2 indx OK"



%------------------------- Exercise #4 -------------------------
expr procedure mpy4x4(a, b);
/* MPY4X4(A, B) -- Create a new 4x4 matrix and return with
  the product of A and B in it. */
for row:=0:3
    with c, s
    initially c := mkarray(3,3)
    do << for col := 0:3 do
              do c[row,col] :=
                   for p := 0:3 sum a[row,p] * b[p,col] >>
    returns c;


mpy4x4



expr procedure translate4x4(x, y, z);
/* TRANSLATE4X4(X, Y, Z) -- Generate and return a
 4x4 matrix to translate X, Y, Z. */
array(array(1.0, 0.0, 0.0, 0.0),
      array(0.0, 1.0, 0.0, 0.0),
      array(0.0, 0.0, 1.0, 0.0),
      array(x,   y,   z,   1.0));


translate4x4


expr procedure rotatex4x4 th;
/* ROTATEX4X4(TH) -- Generate a 4x4 rotation matrix about
  the X axis, TH radians. */
array(array(1.0,     0.0,    0.0,     0.0),
      array(0.0,     cos th, -sin th, 0.0),
      array(0.0,     sin th, cos th,  0.0),
      array(0.0,     0.0,    0.0,     1.0));


rotatex4x4




expr procedure mappoint(x, y, z, m);
/* MAPPOINT(X, Y, Z, M) -- Returns the transformed point
  X, Y, Z by the 4x4 matrix M. */
{x*m[0,0] + y*m[1,0] + z*m[2,0] + m[3,0],
 x*m[0,1] + y*m[1,1] + z*m[2,1] + m[3,1],
 x*m[0,2] + y*m[1,2] + z*m[2,2] + m[3,2]};


mappoint



/* tmat is test matrix to rotate about x. In our tests we
  have to construct the resulting numbers on the fly
  because when input, they aren't the same for EQUAL. */
global '(tmat);


nil

tmat := rotatex4x4(45.0 / 57.29577);


[[1.0 0.0e+000 0.0e+000 0.0e+000] [0.0e+000 0.70710668897748 -0.7071068733956
0.0e+000] [0.0e+000 0.7071068733956 0.70710668897748 0.0e+000] [0.0e+000 0.0e+000
0.0e+000 1.0]]


if mappoint(0.0, 0.0, 0.0, tmat) = '(0.0 0.0 0.0)
  then "Test 1 4x4 OK"
  else error(0, "Test 1 4x4 failed");


"Test 1 4x4 OK"

if mappoint(1.0, 0.0, 0.0, tmat) = '(1.0 0.0 0.0)
  then "Test 2 4x4 OK"
  else error(0, "Test 2 4x4 failed");


"Test 2 4x4 OK"

if mappoint(0.0, 1.0, 0.0, tmat) =
     {0.0, cos(45.0 / 57.29577), - sin(45.0 / 57.29577)}
  then "Test 3 4x4 OK"
  else error(0, "Test 3 4x4 failed");


"Test 3 4x4 OK"

if mappoint(1.0, 1.0, 0.0, tmat) =
     {1.0, cos(45.0 / 57.29577), - sin(45.0 / 57.29577)}
  then "Test 4 4x4 OK"
  else error(0, "Test 4 4x4 failed");


"Test 4 4x4 OK"

if mappoint(0.0, 0.0, 1.0, tmat) = 
     {0.0, sin(45.0 / 57.29577), cos(45.0 / 57.29577)}
  then "Test 5 4x4 OK"
  else error(0, "Test 5 4x4 failed");


"Test 5 4x4 OK"

if mappoint(1.0, 0.0, 1.0, tmat) = 
     {1.0, sin(45.0 / 57.29577), cos(45.0 / 57.29577)}
  then "Test 6 4x4 OK"
  else error(0, "Test 6 4x4 failed");


"Test 6 4x4 OK"

if mappoint(0.0, 1.0, 1.0, tmat) =
     {0.0, cos(45.0 / 57.29577) + sin(45.0 / 57.29577),
      cos(45.0 / 57.29577) - sin(45.0 / 57.29577)}
  then "Test 7 4x4 OK"
  else error(0, "Test 7 4x4 failed");


"Test 7 4x4 OK"

if mappoint(1.0, 1.0, 1.0, tmat) = 
     {1.0, cos(45.0 / 57.29577) + sin(45.0 / 57.29577),
      cos(45.0 / 57.29577) - sin(45.0 / 57.29577)}
  then "Test 8 4x4 OK"
  else error(0, "Test 8 4x4 failed");


"Test 8 4x4 OK"



/* Now try the multiplication routine. */
tmat := mpy4x4(rotatex4x4(45.0 / 57.29577),
               translate4x4(1.0, 2.0, 3.0));


[[1.0 0.0e+000 0.0e+000 0.0e+000] [0.0e+000 0.70710668897748 -0.7071068733956
0.0e+000] [0.0e+000 0.7071068733956 0.70710668897748 0.0e+000] [1.0 2.0 3.0 1.0]
]

if mappoint(0.0, 0.0, 0.0, tmat) = '(1.0 2.0 3.0)
  then "Test 9 4x4 OK"
  else error(0, "Test 9 4x4 failed");


"Test 9 4x4 OK"

if mappoint(0.0, 0.0, 1.0, tmat) =
     {1.0, 2.0 + sin(45.0 / 57.29577),
      3.0 + cos(45.0 / 57.29577)}
  then "Test 10 4x4 OK"
  else error(0, "Test 10 4x4 failed");


"Test 10 4x4 OK"

  

%------------------------- Exercise 4 -------------------------

expr procedure ltident n;
/* LTIDENT(N) -- Create and return a lower triangular,
   square, identity matrix with N+1 rows. */
for i:=0:n
    with a
    initially a := mkvect n
    do << a[i] := mkvect i;
          for j:=0:i - 1 do a[i,j] := 0.0;
          a[i,i] := 1.0 >>
    returns a;


ltident


expr procedure ltmpy(a, b);
/* LTMPY(A, B) -- Compute the product of two square,
  lower triangular matrices of the same size and return.
  Note that the product is also lower triangular. */
(for i:=0:rows
     with c
     initially c := mkvect rows
     do << c[i] := mkvect i;
           for j:=0:i do
               c[i,j] := for k:=j:i sum a[i,k] * b[k,j] >>
     returns c)
  where rows := upbv a;


ltmpy


if ltident 2 = array(array(1.0),
                     array(0.0, 1.0),
                     array(0.0, 0.0, 1.0))
  then "Test 1 ltident OK"
  else "Test 1 ltident fails";


"Test 1 ltident OK"


if ltident 0 = array(array(1.0))
  then "Test 2 ltident OK"
  else "Test 2 ltident fails";


"Test 2 ltident OK"


if ltmpy(ltident 2, ltident 2) = ltident 2
  then "Test 3 ltident OK"
  else "Test 3 ltident fails";


"Test 3 ltident OK"


if ltmpy(array(array(1.0),
               array(1.0, 2.0),
               array(1.0, 2.0, 3.0)),
         array(array(1.0),
               array(1.0, 2.0),
               array(1.0, 2.0, 3.0))) = 
   array(array(1.0),
         array(3.0, 4.0),
         array(6.0, 10.0, 9.0))
  then "Test 4 ltmpy OK"
  else error(0, "Test 4 ltmpy fails");


"Test 4 ltmpy OK"


if ltmpy(array(array(1.2),
               array(3.4, 5.0),
               array(1.0,-2.3,-1.3)), ltident 2)
     = array(array(1.2),
             array(3.4, 5.0),
             array(1.0, -2.3, -1.3))
  then "Test 5 ltmpy OK"
  else error(0, "Test 5 ltmpy fails");


"Test 5 ltmpy OK"


                

%------------------------- Exercise #5 -------------------------

expr procedure coerce(a, b, pth, cmat);
/* COERCE(A,B,PTH,CMAT) -- return a list of functions 
  to coerce type A (an index into CMAT) into type B. PTH
  is NIL   to start and CMAT the coercion table arranged
  with "from" type as rows, "to" type as columns. */
if cmat[a,b] then cmat[a,b] . pth
else
  for j:=0:upbv cmat[a]
      with cp
      until j neq a and cmat[a,j] and
            not (cmat[a,j] memq pth) and
            not(cmat[j,a] memq pth) and
            (cp := coerce(j, b, cmat[a,j] . pth, cmat))
      returns cp;


coerce


/* Create the coercion array. Here int=0, string=1,
  float=2, complex=3, and gaussian=4 */
global '(cpath);


nil

cpath :=
 array(array('ident,   'int2str, 'float,   nil,      nil),
       array('str2int, 'ident,   'str2flt, nil,      nil),
       array('fix,     'flt2str, 'ident,   'flt2cplx,nil),
       array(nil,      nil,      nil,      'ident, 'cfix),
       array(nil,      nil,      nil,    'cfloat, 'ident));


[[ident int2str float nil nil] [str2int ident str2flt nil nil] [fix flt2str ident
flt2cplx nil] [nil nil nil ident cfix] [nil nil nil cfloat ident]]



% Coerce int to complex.
if coerce(0, 3, nil, cpath) = '(FLT2CPLX STR2FLT INT2STR)
  then "Test 1 coerce OK"
  else error(0, "Test 1 coerce fails");


"Test 1 coerce OK"


% Coerce Complex into int.
if coerce(3, 0, nil, cpath) = NIL
  then "Test 2 coerce OK"
  else error(0, "Test 2 coerce fails");


"Test 2 coerce OK"


% Coerce int into gaussian.
if coerce(0, 4, nil, cpath) = 
       '(CFIX FLT2CPLX STR2FLT INT2STR)
  then "Test 3 coerce OK"
  else error(0, "Test 3 coerce fails");


"Test 3 coerce OK"


               
    
%------------------------- Exercise #6 -------------------------

expr procedure cellvon(a, b, fn);
/* CELLVON(A, B, FN) -- Compute the next generation of the
  cellular matrix A and place it into B. Use the VonNeumann
  neighborhood and the function FN to compute the next
  generation. The space edges are wrapped into a torus*/
for r:=0:rows
    with rows, cols
    initially << rows := upbv a; cols := upbv a[1] >>
    do for c:=0:cols
        do b[r,c] := apply(fn,
             {a[r,c],
              a[torus(r + 1, rows), torus(c - 1, cols)],
              a[torus(r + 1, rows), c],
              a[torus(r + 1, rows), torus(c + 1, cols)],
              a[r, torus(c + 1, cols)],
              a[torus(r - 1, rows), torus(c + 1, cols)],
              a[torus(r - 1, rows), c],
              a[torus(r - 1, rows), torus(c - 1, cols)],
              a[r, torus(c - 1, cols)]});


cellvon


expr procedure torus(i, v);
/* TORUS(I, V) -- A positive modulus: if I is less than
  0, wrap to V, or if it exceeds V, wrap to I. */
if i < 0 then v 
  else if i > v then 0
  else i;


torus


expr procedure life(c, n1, n2, n3, n4, n5, n6, n7, n8);
/* LIFE(C, N1 ... N8) -- Game of life rules. Here C is
  the cell being examined and N1-N8 are the VonNeumann
  neighbor states. */
(if c = 1 then if cnt = 2 or cnt = 3 then 1 else 0
  else if cnt = 3 then 1 else 0)
 where cnt = n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8;


life


/* LIFESTATES contains a vector of states and what
  character to print. */
global '(LIFESTATES);


nil

LIFESTATES := array(" ", "*");


[" " "*"]


expr procedure pcell(gen, a, pr);
/* PCELL(GEN, A) -- Display the state of the GEN generation
  of the cellular matrix A. Display a * for state=1, and
  a blank for state 0. */
for r:=0:rows
    with rows, cols
    initially << rows := upbv a; cols := upbv a[1];
                 terpri(); prin2 "Generation: "; print gen >>
    do << terpri();
          for c:=0:cols do prin2 pr[a[r,c]] >>;


pcell




expr procedure rungame(a, n, fn, pr);
/* RUNGAME(A, N, FN, PR) -- Run through N generations
  starting with the cellular matrix A and using the
  function FNto compute the new generation. Use the array
  PR to display the state. */
for i:=1:n
    with tmp, b
    initially b := mkarray(upbv a, upbv a[1])
    do << pcell(i, a, pr);
          cellvon(a, b, function life);
          tmp := a;  a := b;  b := tmp >>;
*** local variable fn in procedure rungame not used 



rungame

 

/* SEED is the seed array with 1's for on state, 0 for
  off. */
global '(seed);


nil

seed := array(
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 1, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 1, 0, 0, 0),
  array(0, 0, 0, 0, 1, 1, 1, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0));


[[0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 1 0
0 0 0] [0 0 0 0 0 0 1 0 0 0] [0 0 0 0 1 1 1 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0
0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0]]


rungame(seed, 10, function life, LIFESTATES);


Generation: 1

          
          
          
     *    
      *   
    ***   
          
          
          
          
Generation: 2

          
          
          
          
    * *   
     **   
     *    
          
          
          
Generation: 3

          
          
          
          
      *   
    * *   
     **   
          
          
          
Generation: 4

          
          
          
          
     *    
      **  
     **   
          
          
          
Generation: 5

          
          
          
          
      *   
       *  
     ***  
          
          
          
Generation: 6

          
          
          
          
          
     * *  
      **  
      *   
          
          
Generation: 7

          
          
          
          
          
       *  
     * *  
      **  
          
          
Generation: 8

          
          
          
          
          
      *   
       ** 
      **  
          
          
Generation: 9

          
          
          
          
          
       *  
        * 
      *** 
          
          
Generation: 10

          
          
          
          
          
          
      * * 
       ** 
       *  
          
nil



%------------------------- Exercise #7 -------------------------

expr procedure compact heap;
/* compact(HEAP) -- HEAP is an array of blocks of
  sequentially allocated items. The first entry in each 
  block is INUSE, the second the total number of entries
  + 2 (for the header). The remainder are random values.
  Free blocks are the same but instead have the header
  FREE. Returns a compacted structure with a single FREE
  entry at the end with entries changed to *. Returns the
  number of free entries. */
begin scalar dest, src, last, u;
  last := dest := src := 0;
loop: if src > upbv heap then
        if src = dest then return 0
        else << heap[dest] := 'FREE;
                heap[dest+1] := src - dest;
                for i:=dest+2:upbv heap do heap[i] := '!*;
                return heap[dest+1] >>;
  if heap[src] eq 'FREE then
       src := heap[src+1] + src
  else << u := heap[src+1] + src - 1;
          for i:=src:u do << heap[dest] := heap[i];
                             dest := dest + 1 >>;
          src := u + 1 >>;
  go to loop
end;


compact



/* A simple array to test. */
global '(H);


nil

H := array('INUSE, 3, 0,
           'FREE, 4, '!*, '!*,
           'INUSE, 4, 0, 1,
           'FREE, 3, '!*,
           'FREE, 5, '!*, '!*, '!*,
           'INUSE, 5, 0, 1, 2,
           'INUSE, 5, 3, 4, 5);


[inuse 3 0 free 4 !* !* inuse 4 0 1 free 3 !* free 5 !* !* !* inuse 5 0 1 2 inuse
5 3 4 5]


if compact H = 12
  then "Test 1 compact OK!"
  else error(0, "Test 1 compact fails!");


"Test 1 compact OK!"

if H = array('INUSE, 3, 0, 'INUSE, 4, 0, 1, 'INUSE,
             5, 0, 1, 2, 'INUSE, 5, 3, 4, 5,
             'FREE, 12, '!*, '!*, '!*, '!*, '!*, '!*,
             '!*, '!*, '!*, '!*)
  then "Test 2 compact OK!"
  else error(0, "Test 2 compact fails!");


"Test 2 compact OK!"


/* Test a completely full one. */
H := array('INUSE, 3, 0, 'INUSE, 5, 1, 2, 3);


[inuse 3 0 inuse 5 1 2 3]

if compact H = 0
  then "Test 3 compact OK!"
  else error(0, "Test 3 compact fails!");


"Test 3 compact OK!"

if H = array('INUSE, 3, 0, 'INUSE, 5, 1, 2, 3)
  then "Test 4 compact OK!"
  else error(0, "Test 4 compact fails!");


"Test 4 compact OK!"



/* Test a completely empty one. */
H := array('FREE, 3, '!*, 'FREE, 5, '!*, '!*, '!*);


[free 3 !* free 5 !* !* !*]

if compact H = 8 
  then "Test 5 compact OK!"
  else error(0, "Test 5 compact fails!");


"Test 5 compact OK!"

if H = array('FREE, 8, '!*, '!*, '!*, '!*, '!*, '!*)
  then "Test 6 compact OK!"
  else error(0, "Test 6 compact fails!");


"Test 6 compact OK!"



%------------------------- Exercise #8 -------------------------

expr procedure HISTOGRAM(v, n);
/* HISTOGRAM(V,N) -- V is an arbitrarily size vector of
  numbers. Compute its an N element histogram over its
  range and return it. */
begin scalar minv, maxv, h, range;
  minv := maxv := v[0];
  for i:=1:upbv v
      do << if v[i] < minv then minv := v[i];
            if v[i] > maxv then maxv := v[i] >>;
  range := maxv - minv;
  h := mkvect(n - 1);
  for i:=0:n - 1 do h[i] := 0;
  for i:=0:upbv v
      with hn
      do << hn := fix(n * (v[i] - minv) / range);
            if hn = n then hn := hn - 1;
            h[hn] := h[hn] + 1 >>;
  return h
end;


histogram


global '(v1);


nil

<< v1 := mkvect 100;
   for i:=0:100 do v1[i] := float i >>;


nil


if HISTOGRAM(v1, 1) = array(101)
  then "Test 1 HISTOGRAM OK!"
  else error(0, "Test 1 HISTOGRAM Fails!");


"Test 1 HISTOGRAM OK!"


if HISTOGRAM(v1, 2) = array(50, 51)
  then "Test 2 HISTOGRAM OK!"
  else error(0, "Test 2 HISTOGRAM Fails!");


"Test 2 HISTOGRAM OK!"


if HISTOGRAM(v1, 7) = array(15, 14, 14, 15, 14, 14, 15)
  then "Test 3 HISTOGRAM OK!"
  else error(0, "Test 3 HISTOGRAM Fails!");


"Test 3 HISTOGRAM OK!"



%------------------------- Exercise #9 -------------------------

expr procedure rarray n;
/* RARRAY(N) - generate an NxN matrix with uniform
  distribution random numbers in the range 0.0 -> 1.0. */
for x:=0:n
    with a
    initially a := mkarray(n,n)
    returns a
    do for y:=0:n do a[x,y] := random(1000) / 1000.0;


rarray


if upbv rarray 4 =  4
  then "Test 1 rarray OK"
  else error(0, "Test 1 rarray fails");


"Test 1 rarray OK"



expr procedure addcircle(a, r, xc, yc, v);
/* ADDCIRCLE(A, R, XC, YC, V) -- Add V to each cell within
  distance R from center point XC, YC and return a new
  matrix with these values. Values always remain in the
  range 0.0 -> 1.0. */
begin scalar uax, uay, b;
  b := mkarray(uax := upbv a, uay := upbv a[0]);
  for x:=0:uax do
    for y:=0:uay do
       b[x,y] := if sqrt((x - xc)^2 + (y - yc)^2) <= r
            then min(1.0, v + a[x,y]) else a[x,y];
  return b
end;


addcircle


global '(xxx);


nil

xxx := array(array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0));


[[0 0 0 0 0] [0 0 0 0 0] [0 0 0 0 0] [0 0 0 0 0] [0 0 0 0 0]]


% This will fail if sqrt isn't very accurate. 
if addcircle(xxx, 2.0, 2, 2, 0.75) = 
  array(array(0,    0,    0.75, 0,    0),
        array(0,    0.75, 0.75, 0.75, 0),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0,    0.75, 0.75, 0.75, 0),
        array(0,    0,    0.75, 0,    0))
  then "Test 1 addcircle OK!"
  else error(0, "Test 1 addcircle fails!");


"Test 1 addcircle OK!"


if addcircle(xxx, 10.0, 2, 2, 0.75) = 
  array(array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75))
  then "Test 2 addcircle OK!"
  else error(0, "Test 2 addcircle fails!");


"Test 2 addcircle OK!"



%------------------------- Exercise #10 -------------------------

expr procedure areaaverage(a, n);
/* AREAAVERAGE(A, N) -- Compute the average of the NxN
  neighborhood of each cell in the matrix A and return a
  new matrix with these values. */
begin scalar uax, uay, sm, cnt, b, n2;
  n2 := n / 2;
  b := mkarray(uax := upbv a, uay := upbv a[1]);
  for x := 0:uax do
   for y := 0:uay do
     << sm := 0.0;
        cnt := 0;
        for xp := max(0, x - n2):min(uax, x + n2) do
          for yp := max(0, y - n2):min(uay, y + n2) do
            << sm := sm + a[xp,yp];
               cnt := cnt + 1 >>;
        b[x,y] := sm / cnt >>;
  return b
end;


areaaverage


global '(ninth);


nil

xxx[2,2] := 1.0;


1.0

ninth := 1.0 / 9.0;


0.11111111111111


if areaaverage(xxx, 3) =
  array(array(0.0, 0.0,   0.0,   0.0,   0.0),
        array(0.0, ninth, ninth, ninth, 0.0),
        array(0.0, ninth, ninth, ninth, 0.0),
        array(0.0, ninth, ninth, ninth, 0.0),
        array(0.0, 0.0,   0.0,   0.0,   0.0))
  then "Test 1 areaaverage OK!"
  else error(0, "Test 1 areaaverage Fails!");


"Test 1 areaaverage OK!"



%------------------------- Exercise #11 -------------------------

expr procedure laplace a;
/* LAPLACE(A) -- Compute the Laplacian on A but assuming
  0.0 at the borders. Returns a new array the same size
  as A. */
begin scalar uax, uay, b, sm;
  b := mkarray(uax := upbv a, uay := upbv a[0]);
  for x := 0:uax do
   for y := 0:uay do
     << sm := 0.0;
        for xp := max(0, x - 1):min(uax, x + 1)
          when xp neq x do
          for yp := max(0, y - 1):min(uay, y + 1)
            when yp neq y
            do sm := sm + a[xp,yp];
        b[x,y] := max(0.0, min(5.0 * a[x,y] - sm, 1.0)) >>;
  return b
end;


laplace



xxx := array(array(0,0,0,0,0),
             array(0,1,1,1,0),
             array(0,1,1,1,0),
             array(0,1,1,1,0),
             array(0,0,0,0,0));


[[0 0 0 0 0] [0 1 1 1 0] [0 1 1 1 0] [0 1 1 1 0] [0 0 0 0 0]]

if laplace xxx = array(array(0.0, 0.0, 0.0, 0.0, 0.0),
                       array(0.0, 1.0, 1.0, 1.0, 0.0),
                       array(0.0, 1.0, 1.0, 1.0, 0.0),
                       array(0.0, 1.0, 1.0, 1.0, 0.0),
                       array(0.0, 0.0, 0.0, 0.0, 0.0))
  then "Test 1 laplace OK!"
  else error(0, "Test 1 laplace fails!");


"Test 1 laplace OK!"



%------------------------- Exercise #12 -------------------------

expr procedure threshold(a, vl, vh);
/* THRESHOLD(A, VL, VH) -- Returns a new matrix of the same
  size as A with each cell set to 1.0 that is 
  VL <= A(i,j) <= VH. Others are set to 0.0. */
for x := 0:uax
    with uax, uay, b
    initially b := mkarray(uax := upbv a,
                           uay := upbv a[0])
    returns b
    do for y := 0:uay
         do b[x,y] := 
               if a[x,y] >= vl and a[x,y] <= vh then 1.0
                                                else 0.0;


threshold


xxx := mkarray(4,4);


[[nil nil nil nil nil] [nil nil nil nil nil] [nil nil nil nil nil] [nil nil nil
nil nil] [nil nil nil nil nil]]

for i:=0:4 do for j:=0:4 do xxx[i,j] := i * j;


nil


if threshold(xxx, 8, 10) = array(
  array(0.0, 0.0, 0.0, 0.0, 0.0),
  array(0.0, 0.0, 0.0, 0.0, 0.0),
  array(0.0, 0.0, 0.0, 0.0, 1.0),
  array(0.0, 0.0, 0.0, 1.0, 0.0),
  array(0.0, 0.0, 1.0, 0.0, 0.0))
  then "Test 1 threshold OK!"
  else error(0, "Test 1 threshold Fails!");


"Test 1 threshold OK!"




expr procedure dump(a, f);
/* DUMP(A,F) -- Dump an array A into a PicTex format
  file for document processing. */
begin scalar fh;
  fh := wrs open(f, 'output);
  for x:=0:upbv a do
    for y:=0:upbv a[0] do
      printf("\setshadegrid span <%wpt>%n\vshade %d %d %d %d %d %d /%n",
             max(0.5, 5.5 - a[x,y]*5.0),
             x, y, y+1, x+1, y, y+1);
  close wrs fh;
end;


dump



% ##### Macro Exercises #####

%------------------------- Exercise -----------------------
macro procedure appendl x;
/* APPENDL( ...) - append all the lists together. */
 expand(cdr x, 'append);


appendl


if appendl('(a b), '(c d), '(e f)) = '(a b c d e f)
  then "Test 1 appendl OK!"
  else error(0, "Test 1 appendl fails!");


"Test 1 appendl OK!"

if appendl '(a b c) = '(a b c)
  then "Test 2 appendl OK!"
  else error(0, "Test 2 appendl fails!");


"Test 2 appendl OK!"

if appendl nil = nil
  then "Test 3 appendl OK!"
  else error(0, "Test 3 appendl fails!");


"Test 3 appendl OK!"


%------------------------- Exercise ------------------------
macro procedure nconcl x;
/* NCONCL(...) - destructive concatenation of all the
  lists. */
  expand(cdr x, 'nconc);


nconcl


global '(b1 b2 b3);


nil

b1 := '(a b);


(a b)

b2 := '(c d);


(c d)

b3 := '(e f);


(e f)

if nconcl(b1, b2, b3) = '(a b c d e f)
  then "Test 1 nconcl OK!"
  else error(0, "Test 1 nconcl fails!");


"Test 1 nconcl OK!"

if b1 = '(a b c d e f)
  then "Test 2 nconcl OK!"
  else error(0, "Test 2 nconcl fails!");


"Test 2 nconcl OK!"

if b2 = '(c d e f)
  then "Test 3 nconcl OK!"
  else error(0, "Test 3 nconcl fails!");


"Test 3 nconcl OK!"

if b3 = '(e f)
  then "Test 4 nconcl OK!"
  else error(0, "Test 4 nconcl fails!");


"Test 4 nconcl OK!"



%------------------------- Exercise ------------------------
smacro procedure d(x1, y1, x2, y2);
/* D(X1, Y1, X2, Y2) - Euclidean distance between points
  (X1,Y1) -> (X2,Y2) */
sqrt((x1 - x2)^2 + (y1 - y2)^2);


d


% This fails with poor sqrt.
if d(0, 0, 3, 4) = 5.0
  then "Test 1 d OK!"
  else error(0, "Test 1 d Fails!");


"Test 1 d OK!"

if d(0, 0, 1, 1) = sqrt 2
  then "Test 2 d OK!"
  else error(0, "Test 2 d Fails!");


"Test 2 d OK!"


%------------------------- Exercise -------------------------
macro procedure pop x;
/* POP(X) - Assuming X is an identifier, pop the stack
  and return the popped value. */
(`(prog (!$V!$)
     (setq !$V!$ (car #v))
     (setq #v (cdr #v))
     (return !$V!$))) where v := cadr x;


pop


xxx := '(A B);


(a b)

if pop xxx eq 'A
  then "Test 1 POP ok!"
  else error(0, "Test 1 POP fails!");


"Test 1 POP ok!"

if xxx = '(B) 
  then "Test 1 POP ok!"
  else error(0, "Test 1 POP fails!");


"Test 1 POP ok!"

if pop xxx eq 'B
  then "Test 2 POP ok!"
  else error(0, "Test 2 POP fails!");


"Test 2 POP ok!"

if xxx eq NIL
  then "Test 2 POP ok!"
  else error(0, "Test 2 POP fails!");


"Test 2 POP ok!"


%------------------------- Exercise -------------------------

macro procedure push x;
/* PUSH(ST, V) - push V onto ST (an identifier) and 
  return V. */
`(progn (setq #st (cons #v #st))
        #v)
  where st := cadr x,
        v := caddr x;


push


if push(xxx, 'A) = 'A
  then "Test 1 push OK!"
  else error(0, "Test 1 push fails");


"Test 1 push OK!"

if xxx = '(A)
  then "Test 1 push OK!"
  else error(0, "Test 1 push fails");


"Test 1 push OK!"

if push(xxx, 'B) = 'B
  then "Test 2 push OK!"
  else error(0, "Test 2 push fails");


"Test 2 push OK!"

if xxx = '(B A)
  then "Test 2 push OK!"
  else error(0, "Test 2 push fails");


"Test 2 push OK!"

  
%------------------------- Exercise -------------------------

macro procedure format x;
/* FORMAT("str", ...) - A formatted print utility. It
  looks for %x things in str, printing everything else.
  A property of printf!-format will cause a call on
  the named function with the corresponding argument.
  This should return a print form to use. A property
  printf!-expand calls a function without an argument.
  Common controls are:
    %n new line
    %p prin2 call.
    %w prin1 call.
*/
begin scalar str, localstr, m;
  str := explode2 cadr x;
  x := cddr x;
loop: if null str then
    << if localstr then
          m := {'prin2, makestring reversip localstr} . m;
       return 'progn . reverse m  >>;
  if eqcar(str, '!%) then
     if cdr str then
       if fn := get(cadr str, 'printf!-format) then
         << if localstr then 
              << m := {'prin2, makestring reversip localstr} . m;
                 localstr := nil >>;
            m := apply(fn, {car x}) . m;
            x := cdr x;
            str := cddr str; 
            go to loop >>
       else if fn := get(cadr str, 'printf!-expand) then
         << if localstr then
              << m := {'prin2, makestring reverse localstr} . m;
                 localstr := nil >>;
            m := apply(fn, nil) . m;
            str := cddr str; 
            go to loop >>;
  localstr := car str . localstr;
  str := cdr str;
  go to loop
end;


format


expr procedure makestring l;
/* MAKESTRING(L) - convert the list of character L into
  a string. */
 compress('!" . append(l, '(!")));


makestring


expr procedure printf!-terpri;
/* PRINTF!-TERPRI() - Generates a TERPRI call for %n */
 '(terpri);


printf!-terpri

put('!n, 'printf!-expand, 'printf!-terpri);


printf!-terpri

put('!N, 'printf!-expand, 'printf!-terpri);


printf!-terpri


expr procedure printf!-prin1 x;
/* PRINTF!-PRIN1(X) - Generates a PRIN1 call for %w */
 {'prin1, x};


printf!-prin1

put('!w, 'printf!-format, 'printf!-prin1);


printf!-prin1

put('!W, 'printf!-format, 'printf!-prin1);


printf!-prin1


expr procedure printf!-prin2 x; 
/* PRINTF!-PRIN2(X) - Generates a PRIN2 call for %p */
 {'prin2, x};


printf!-prin2

put('!p, 'printf!-format, 'printf!-prin2);


printf!-prin2

put('!P, 'printf!-format, 'printf!-prin2);


printf!-prin2


%------------------------- Exercise -------------------------
macro procedure rmsg x;
/* RMSG("str", ...) - A formatted string utility. It
  looks for %x things in str, copying everything else.
  A property of rmsg!-format will cause a call on
  the named function with the corresponding argument.
  This should return a explode form to use. A property
  rmsg!-expand calls a function without an argument.
  Common controls are:
    %n new line
    %p explode2 call.
    %w explode call.
*/
begin scalar str, localstr, m;
  str := explode2 cadr x;
  x := cddr x;
loop: if null str then
    << if localstr then
          m := mkquote reversip localstr . m;
       return `(makestring (nconcl #@(reversip m)))  >>;
  if eqcar(str, '!%) then
     if cdr str then
       if fn := get(cadr str, 'rmsg!-format) then
         << if localstr then 
              << m := mkquote reversip localstr . m;
                 localstr := nil >>;
            m := apply(fn, {car x}) . m;
            x := cdr x;
            str := cddr str; 
            go to loop >>
       else if fn := get(cadr str, 'rmsg!-expand) then
         << if localstr then
              << m := mkquote reversip localstr . m;
                 localstr := nil >>;
            m := apply(fn, nil) . m;
            str := cddr str; 
            go to loop >>;
  localstr := car str . localstr;
  str := cdr str;
  go to loop
end;


rmsg


expr procedure makestring l;
/* MAKESTRING(L) - convert the list of character L into
  a string. */
 compress('!" . append(l, '(!")));


+++ makestring redefined

makestring


expr procedure rmsg!-terpri;
/* RMSG!-TERPRI() - Generates an EOL. */
mkquote {!$eol!$};


rmsg!-terpri

put('!n, 'rmsg!-expand, 'rmsg!-terpri);


rmsg!-terpri

put('!N, 'rmsg!-expand, 'rmsg!-terpri);


rmsg!-terpri


expr procedure rmsg!-prin1 x;
/* RMSG!-PRIN1(X) - Generates an EXPLODE call */
 `(fixstr (explode #x));


rmsg!-prin1

put('!w, 'rmsg!-format, 'rmsg!-prin1);


rmsg!-prin1

put('!W, 'rmsg!-format, 'rmsg!-prin1);


rmsg!-prin1


expr procedure rmsg!-prin2 x; 
/* RMSG!-PRIN2(X) - Generates an EXPLODE2 call for x. */
 `(explode2 #x);


rmsg!-prin2

put('!p, 'rmsg!-format, 'rmsg!-prin2);


rmsg!-prin2

put('!P, 'rmsg!-format, 'rmsg!-prin2);


rmsg!-prin2


expr procedure fixstr x;
/* FIXSTR(X) - Double up "'s in x. */
if null x then nil
  else if eqcar(x, '!") then '!" . '!" . fixstr cdr x
  else car x . fixstr cdr x;


fixstr



if rmsg "abc" = "abc"
  then "Test 1 rmsg OK!"
  else error(0, "Test 1 rmsg fails!");


"Test 1 rmsg OK!"


if rmsg("Test %w test", 12) = "Test 12 test"
  then "Test 2 rmsg OK!"
  else error(0, "Test 2 rmsg fails!");


"Test 2 rmsg OK!"


if rmsg("Test %w string", "foo") = "Test ""foo"" string"
  then "Test 3 rmsg OK!"
  else error(0, "Test 3 rmsg fails!");


"Test 3 rmsg OK!"


if rmsg("Test %w now %p", "foo", "foo") = "Test ""foo"" now foo"
  then "Test 4 rmsg OK!"
  else error(0, "Test 4 rmsg fails!");


"Test 4 rmsg OK!"


%------------------------- Exercise -------------------------
define CFLAG = T;


nil


macro procedure ifcflag x;
/* IFCLFAG(X) - generate the code for X if CFLAG is non-NIL,
  otherwise generate NIL (this can't be used everywhere). */
if CFLAG then cadr x else nil;


ifcflag


ifCFLAG expr procedure pslfoo x; car x;


pslfoo

if getd 'pslfoo
  then "Test 1 ifCFLAG OK!"
  else error(0, "Test 1 ifCFLAG fails!");


"Test 1 ifCFLAG OK!"



% ##### Interactive Exercises #####

%------------------------- Exercise #2 -------------------------

/* Lists functions that have been embedded with count code. */
global '(EMBEDDED!*);


nil

EMBEDDED!* := NIL;


nil


expr procedure embed f;
/* EMBED(F) - wrap function F with counter code. Error if F is
   not interpreted. Put the information under property COUNT and
   add to the global list EMBEDDED!*. */
begin scalar def, args, nfn;
  if not(def := getd f) then  error(0, {f, "is undefined"});
  if codep cdr def then error(0, {f, "is not interpreted"});
  put(f, 'COUNT, 0);
  if f memq EMBEDDED!* then return NIL;
  EMBEDDED!* := f . EMBEDDED!*;
  putd(nfn := intern gensym(), car def, cdr def);
  putd(f, car def,
       {'lambda, caddr def,
        {'progn,
           {'put, mkquote f, mkquote 'COUNT,
                  {'add1, {'get, mkquote f, mkquote 'COUNT}}},
           nfn . caddr def}});
  return f
end;
*** local variable args in procedure embed not used 



embed



expr procedure stats;
/* STATS() - list all the embedded functions and their 
   counts. */
for each f in EMBEDDED!*
    do << prin1 f; prin2 "  "; print get(f, 'COUNT) >>;


stats



expr procedure pcnt x;
/* PCNT(X) - returns the number of dotted-pairs in X (vectors
  can hide dotted-pairs). */
if atom x then 0
  else 1 + pcnt car x + pcnt cdr x;


pcnt


if embed 'pcnt eq 'pcnt 
  then "Test 1 embed OK!"
  else error(0, "Test 1 embed Fails!");


+++ pcnt redefined

"Test 1 embed OK!"

if get('pcnt, 'count) = 0
  then "Test 2 embed OK!"
  else error(0, "Test 2 embed Fails!");


"Test 2 embed OK!"

if pcnt '(a . (b . c)) = 2
  then "Test 3 embed OK!"
  else error(0, "Test 3 embed Fails!");


"Test 3 embed OK!"

if get('pcnt, 'COUNT) = 5
  then "Test 4 embed OK!"
  else error(0, "Test 4 embed Fails!");


"Test 4 embed OK!"

if EMBEDDED!* = '(PCNT)
  then "Test 5 embed OK!"
  else error(0, "Test 5 embed Fails!");


"Test 5 embed OK!"


% Just a visual check.
stats();

pcnt  5

nil



%   ##### Test the inspector module #####
%
% We set LINELENGTH to various values to check how good we do on output.
% Don't let the default screw up the test:
LINELENGTH 80;


t


% Describe some of the basic data types.
% Dotted-pairs.
describe '(a . b);

A dotted-pair or list

nil


% Vectors;
global '(xvar);


nil

xvar := mkvect 3;


[nil nil nil nil]

describe xvar;

A vector with 4 elements

nil


% Records.
record insprec /* A record for testing. */
  with
    field1 := 'a;


insprec

xvar := insprec();


[insprec a]

describe xvar;

A insprec record with 
   1: a

nil

describe 'insprec;

insprec is a record constructor with the following fields
** not implemented. **

nil


% A code pointer (usually).
describe cdr getd 'car;

car is an EXPR with an unknown number of arguments

nil


% Numbers.
describe 1;

A fixed number

nil

describe 3.14159;

A floating-point number

nil


% Strings
describe "This is a string";

A string

nil


% identifiers of various sourts.
describe 'car;

car is an EXPR with one argument

nil

describe 'a!-plain!-jane!-identifier;

Don't know anything about a!-plain!-jane!-identifier

nil
  
describe nil;

Identifier 'nil' is fluid

nil
   % This message is sort of funny in odd ways.


% Now let's get serious. Here's a global with no active comment. The
% remprop is something you shouldn't know about but allows us to run
% the test file multiple times and get the same results.
remprop('TheCow, 'NEWNAM);


nil

DEFINE TheCow = "How now brown cow";


nil

describe 'TheCow;

thecow is a constant defined as "How now brown cow"

nil


off saveactives;


nil

/* I never saw a purple cow, I never hope to see one now. */
global '(PurpleCow);


nil

describe 'PurpleCow;

Identifier 'purplecow' is global

nil


on saveactives;


nil

/* But I'd rather see one than be one! */
global '(Pcow);


nil

describe 'Pcow;

Identifier 'pcow' is global defined line 2236 in file ../xmpl/rlisp88.tst
but i'd rather see one than be one! 

nil


% Now we march on to procedures.
% Here's one with no comment and we don't save it.
off saveactives;


nil

remd 'comtest1;


nil

expr procedure comtest1 x;
print x;


comtest1

describe 'comtest1;

comtest1 is an EXPR with one argument

nil


% Here's one with no comment and we do save it.
on saveactives;


nil

remd 'comtest2;


nil

expr procedure comtest2(x, y);
print x;
*** local variable y in procedure comtest2 not used 



comtest2

describe 'comtest2;

comtest2 is an EXPR with 2 arguments

nil


% Here's one with a comment but we don't save it.
off saveactives;


nil

remd 'comtest3;


nil

expr procedure comtest3(x, y, z);
/* You should never see this comment. */
print x;
*** local variable y in procedure comtest3 not used 

*** local variable z in procedure comtest3 not used 



comtest3

describe 'comtest3;

comtest3 is an EXPR with 3 arguments

nil


% Here's one with a comment and we should see it.
on saveactives;


nil

remd 'comtest4;


nil

expr procedure comtest4(x, y, z, xx);
/* COMTEST4(X, Y, Z, XX) - A well commented routine. This routine
  does almost nothing, but a good article thereof. */
print x;
*** local variable y in procedure comtest4 not used 

*** local variable z in procedure comtest4 not used 

*** local variable xx in procedure comtest4 not used 



comtest4

describe 'comtest4;

comtest4 is an EXPR with 4 arguments
Function ends on line 2265 in file ../xmpl/rlisp88.tst
comtest4(x, y, z, xx) - a well commented routine. this routine
does almost nothing, but a good article thereof. 

nil


% Now try MACROS.

remd 'comtest5;


nil

macro procedure comtest5 x;
/* COMTEST5(X) - A macro that doesn't really do much of anything. */
{'car, cadr x};


comtest5

describe 'comtest5;

comtest5 is a MACRO
Function ends on line 2272 in file ../xmpl/rlisp88.tst
comtest5(x) - a macro that doesn't really do much of anything. 

nil



smacro procedure comtest6 x;
/* COMTEST6(X) - a SMACRO with an active comment. This smacro expands
  to take CAR of its argument. */
car x;


comtest6

describe 'comtest6;

comtest6 is an SMACRO with one argument
Function ends on line 2277 in file ../xmpl/rlisp88.tst
comtest6(x) - a smacro with an active comment. this smacro expands
to take car of its argument. 

nil



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Module testing.

/* This is a test module which occurs at the top level just to make
  sure that the module type works. */
module testmodule;


nil

endmodule;


nil

describe 'testmodule;

Can't find source or fasl file for module testmodule
this is a test module which occurs at the top level just to make
sure that the module type works. 

nil


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Format testing. Put a big comment out there and look at it with
% various line lengths.

/* ********************
This is a test comment. We'll try do different things with it in
different contexts. Does it work?

  expr procedure fact n;
    if n < 2 then 1 else n * fact(n - 1);

Well hoop de doo! Is there anything else funny?

 +------------+----------+
 |  Column 1  |  Col. 2  |
 +------------+----------+
 | Aardvarks  |      345 |
 +------------+----------+
 | Zarfs      |        3 |
 +------------+----------+
/// */
global '(testvariable);


nil


describe 'testvariable;

Identifier 'testvariable' is global defined line 2292 in file 
../xmpl/rlisp88.tst
********************
this is a test comment. we'll try do different things with it in
different contexts. does it work?

  expr procedure fact n;
    if n < 2 then 1 else n * fact(n - 1);

well hoop de doo! is there anything else funny?

 +------------+----------+
 |  column 1  |  col. 2  |
 +------------+----------+
 | aardvarks  |      345 |
 +------------+----------+
 | zarfs      |        3 |
 +------------+----------+
/// 

nil

LINELENGTH 60;


80

describe 'testvariable;

Identifier 'testvariable' is global defined line 2292
 in file ../xmpl/rlisp88.tst
********************
this is a test comment. we'll try do different things with i
t in
different contexts. does it work?

  expr procedure fact n;
    if n < 2 then 1 else n * fact(n - 1);

well hoop de doo! is there anything else funny?

 +------------+----------+
 |  column 1  |  col. 2  |
 +------------+----------+
 | aardvarks  |      345 |
 +------------+----------+
 | zarfs      |        3 |
 +------------+----------+
/// 

nil

LINELENGTH 50;


60

describe 'testvariable;

Identifier 'testvariable' is global defined line 
2292 in file ../xmpl/rlisp88.tst
********************
this is a test comment. we'll try do different thi
ngs with it in
different contexts. does it work?

  expr procedure fact n;
    if n < 2 then 1 else n * fact(n - 1);

well hoop de doo! is there anything else funny?

 +------------+----------+
 |  column 1  |  col. 2  |
 +------------+----------+
 | aardvarks  |      345 |
 +------------+----------+
 | zarfs      |        3 |
 +------------+----------+
/// 

nil

LINELENGTH 40;


50

describe 'testvariable;

Identifier 'testvariable' is global
 defined line 2292 in file 
../xmpl/rlisp88.tst
********************
this is a test comment. we'll try do dif
ferent things with it in
different contexts. does it work?

  expr procedure fact n;
    if n < 2 then 1 else n * fact(n - 1)
;

well hoop de doo! is there anything else
 funny?

 +------------+----------+
 |  column 1  |  col. 2  |
 +------------+----------+
 | aardvarks  |      345 |
 +------------+----------+
 | zarfs      |        3 |
 +------------+----------+
/// 

nil

LINELENGTH 30;


40

describe 'testvariable;

Identifier 'testvariable' is 
global defined line 2292
 in file ../xmpl/rlisp88.tst
********************
this is a test comment. we'll 
try do different things with i
t in
different contexts. does it wo
rk?

  expr procedure fact n;
    if n < 2 then 1 else n * f
act(n - 1);

well hoop de doo! is there any
thing else funny?

 +------------+----------+
 |  column 1  |  col. 2  |
 +------------+----------+
 | aardvarks  |      345 |
 +------------+----------+
 | zarfs      |        3 |
 +------------+----------+
/// 

nil

LINELENGTH 20;


30

describe 'testvariable;

Identifier '
testvariable' is 
global defined line 
2292 in file 
../xmpl/rlisp88.tst
********************
this is a test comme
nt. we'll try do dif
ferent things with i
t in
different contexts. 
does it work?

  expr procedure fac
t n;
    if n < 2 then 1 
else n * fact(n - 1)
;

well hoop de doo! is
 there anything else
 funny?

 +------------+-----
-----+
 |  column 1  |  col
. 2  |
 +------------+-----
-----+
 | aardvarks  |     
 345 |
 +------------+-----
-----+
 | zarfs      |     
   3 |
 +------------+-----
-----+
/// 

nil

LINELENGTH 10;


20

describe 'testvariable;


Identifier '
testvariable
' is 
global
 defined line 
2292
 in file 
../xmpl/rlisp88.tst
**********
**********
this is a 
test comme
nt. we'll 
try do dif
ferent thi
ngs with i
t in
different 
contexts. 
does it wo
rk?

  expr pro
cedure fac
t n;
    if n <
 2 then 1 
else n * f
act(n - 1)
;

well hoop 
de doo! is
 there any
thing else
 funny?

 +--------
----+-----
-----+
 |  column
 1  |  col
. 2  |
 +--------
----+-----
-----+
 | aardvar
ks  |     
 345 |
 +--------
----+-----
-----+
 | zarfs  
    |     
   3 |
 +--------
----+-----
-----+
/// 

nil



% ##### Records Package #####

global '(rec1 rec2);


nil


% Simple test.
record rtest1;


rtest1

rec1 := rtest1();


[rtest1]


if rec1 neq array 'rtest1 then
  error(0, "Test 1 RECORD fails creation test!");


nil

if null rtest1p rec1 then
  error(0, "Test 1 RECORD fails predicate test!");


nil



% A record with two fields.
record rtest2 with field1 := 0, field2 := 1;


rtest2


% Test default creation.
rec2 := rtest2();


[rtest2 0 1
]

if rec2 neq array('rtest2, 0, 1) then
  error(0, "Test 2 RECORD fails to create a record");


nil

if null rtest2p rec2 then
  error(0, "Test 2 RECORD fails predicate test");


nil

if rtest2p rec1 then
  error(0, "Test 2 RECORD fails to test record differences");


nil




% Build a record with a predicate. Remove any old occurrence.
remd 'rtest3!?;


nil

record rtest3 with field1 := 0, field2 := 1 has predicate = rtest3!?;


rtest3


if not getd 'rtest3!? then 
  error(0, "Test 3 RECORD fails - no predicate built");


nil

if rtest3!? rec2 then
  error(0, "Test 3 RECORD fails - predicate returns T on non RTEST3 record");


nil

for each x in {'identifier, 12, 12.3, "a string", cdr getd 'car,
               '(a list), array("an", "array")}
  when rtest3!? x
  do error(0, {"Test 3 RECORD fails - predicate returns T on", x});


nil


rec2 := rtest3();


[rtest3 0 1
]

if not rtest3!? rec2 then
  error(0, "Test 3 RECORD fails - predicate returns NIL on record");


nil



% Check that the no-predicate option works.
remd 'rtest4p;


nil
      % Just to make sure.
record rtest4 with a := 34, b := 56 has no predicate;


rtest4

if getd 'rtest4p then
  error(0, "Test 4 RECORD fails - NO PREDICATE option generates a predicate");


nil



% Verify that the CONSTRUCTOR option works.
remd 'rtest5;


nil

remd 'make-rtest5;


nil

record rtest5 with r5a := 0, r5b := 1 has constructor;


rtest5


if getd 'rtest5 then
  error(0, "Test 5 RECORD fails - CONSTRUCTOR generates simple constructor");


nil

if not getd 'make-rtest5 then
  error(0, "Test 5 RECORD fails - CONSTRUCTOR doesn't generate constructor");


nil

if not rtest5p make-rtest5() then
  error(0, "Test 5 RECORD fails - CONSTRUCTOR doesn't generate record");


nil


% Verify that the named constructor works.
remd 'rtest6;


nil
 remd 'please-make-rtest6;


nil

record rtest6 with r6a := 0 has constructor = please!-make!-arecord;


rtest6


if getd 'rtest6 then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR generates simple constructor");


nil

if getd 'make-rtest6 then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR generates make- constructor");


nil

if not getd 'please-make-arecord then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR doesn't generate constructor");


nil

if not rtest6p please-make-arecord() then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR doesn't generate record");


nil



end;
(TIME: 
rlisp88
1999 2009)

nil