Artifact 93ef34e51f1388e61efd969a53612bc71be1cc7439579fc6d60bfd7cfa8f3920:
- File
r35/xmpl/rlisp88.tst
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 79596) [annotate] [blame] [check-ins using] [more...]
% 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; % 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); v1 := mkarray 5; for i:=0:5 do v1[i] := 3**i; v1; % 2. 2D array. global '(v3x3); v3x3 := mkarray(2, 2); for row := 0:2 do for col := 0:2 do v3x3[row, col] := if row = col then 1.0 else 0.0; v3x3; % 3. Triangular array. global '(tri); tri := mkarray 3; for row := 0:3 do tri[row] := mkarray row; for row := 0:3 do for col := 0:row do tri[row,col] := row * col; tri; % 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 45.0; % 5. Random elements. % Now create a vector with random elements. M3 := ARRAY('A, 3 + 4, ARRAY("String", 'ID), '(a b)); M3[2, 1]; M4 := ARRAY(ARRAY('a, 'b), ARRAY('c, 'd)); M4[1]; % 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(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)))); % 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 */; % 2: Creation. global '(r1 r2 r3); r1 := mapf(); r2 := mapf(mapf!:name := "foobar", mapf!:road-count := 34); r3 := list('a . r1, 'b . r2); % 3: Accessing. mapf!:number r1; mapf!:road-count cdr assoc('b, r3); % 4: Assignment. mapf!:number r1 := 7622; mapf!:road-count cdr assoc('b, r3) := 376; mapf!:node-count(mapf!:name r2 := mapf()) := 34; r2; % 5. Options. RECORD complex /* Stores complex reals */ WITH R := 0.0 /* Real part */, I := 0.0 /* Imaginary part */ HAS CONSTRUCTOR; Make-Complex(I := 34.0, R := 12.0); RECORD Rational /* Representation of rational numbers */ WITH Num := 0 /* Numerator */, Den := 1 /* Denominator */ HAS CONSTRUCTOR = rat; 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); 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(34, 12); 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; % 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(EventData := '(MOVE 34.5 52.5)); % 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 '(Now is the time to use RLISP); % 2) Basic iteration in both directions. FOR i:=5 STEP -2 UNTIL 0 DO PRINT i; FOR i:=1:3 DO PRINT i; % 3) COLLECT option. FOR EACH leftpart IN '(A B C) EACH rightpart IN '(1 2 "string") COLLECT leftpart . rightpart; % 4) IN/ON iterators. FOR EACH X IN '(a b c) DO PRINT x; FOR EACH x ON '(a b c) DO PRINT x; % 5) EVERY option. FOR EACH x IN '(A B C) EVERY IDP x RETURNS "They are all id's"; FOR EACH x IN '(A B 12) EVERY IDP x RETURNS "They are all id's"; % 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 '(The quick brown bert died); % 7) MAXIMIZE/MINIMIZE options. FOR EACH x IN '(A B 12 -34 2.3) WHEN NUMBERP x MAXIMIZE x; FOR EACH x IN '(A B 12 -34 2.3) WHEN NUMBERP x MINIMIZE x; % 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(FUNCTION ATOM, '(a (BANG 12) "OOPS!")); % 9) SOME option. FOR EACH x IN '(a b 12) SOME NUMBERP x DO PRINT x; % 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 '(a b c 1 2 3); % 11) WHEN/UNLESS options. FOR EACH x IN '(A 12 "A String" 32) WHEN NUMBERP x COLLECT x; % ##### 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"); if -1 neq - 1 then error(0, "-1 doesn't parse"); expr procedure factorial n; if n < 2 then 1 else n * factorial(n - 1); if +2432902008176640000 neq factorial 20 then error(0, "bignum + doesn't work"); if -2432902008176640000 neq - factorial 20 then error(0, "bignum - doesn't work"); % This actually blew up at one time. if -3.14159 neq - 3.14159 then error(0, "negative floats don't work"); if +3.14159 neq 3.14159 then error(0, "positive floats don't work"); % ##### 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; expr procedure SafeCdr x; /* Returns CDR of a list or NIL. */ if atom x then nil else cdr x; expr procedure SafeFirst x; SafeCar x; expr procedure SafeSecond x; SafeCar SafeCdr x; expr procedure SafeThird x; SafeSecond SafeCdr x; % ##### 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); if delassoc('a, '((a b) (c d))) = '((c d)) then "Test 1 delassoc OK" else error(0, "Test 1 delassoc failed"); 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"); 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"); 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"); %------------------------- Exercise #2 ------------------------- expr procedure gcd(u, v); if v = 0 then u else gcd(v, remainder(u, v)); if gcd(2, 4) = 2 then "Test 1 GCD OK" else error(0, "Test 1 GCD fails"); if gcd(13, 7) = 1 then "Test 2 GCD OK" else error(0, "Test 2 GCD fails"); if gcd(15, 10) = 5 then "Test 3 GCD OK" else error(0, "Test 3 GCD fails"); if gcd(-15, 10) = -5 then "Test 4 GCD OK" else error(0, "Test 4 GCD fails"); if gcd(-15, 0) = -15 then "Test 5 GCD OK" else error(0, "Test 5 GCD fails"); %-------------------- 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); % Test an EQ intersection. properintersection('(a b), '(b c)); if properintersection('(a b), '(b c)) = '(b) then "Test 1 properintersection OK" else error(0, "Test 1 properintersection fails"); % Test an EQUAL intersection. properintersection('((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 an EQUAL intersection, out of order. properintersection('((a) b (c)), '(b (c) (a))); if properintersection('((a) b (c)), '(b (c) (a))) = '((a) b (c)) then "Test 3 properintersection OK" else error(0, "Test 3 properintersection fails"); % Test an empty intersection. properintersection('((a) b (c)), '(a (b) c)); if properintersection('((a) b (c)), '(a (b) c)) = nil then "Test 4 properintersection OK" else error(0, "Test 4 properintersection fails"); %-------------------- 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('c, '(a (b (d nil nil) (c nil nil)) (e nil nil)), nil); 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"); TreeVisit('h, '(a (b (d nil nil) (c nil nil)) (e (f nil nil) (g (h nil nil) nil)) ), nil); 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"); 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"); 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"); 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"); %-------------------- 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); 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); 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"); if lookfor('(now is), '(now we have nothing is)) = NIL then "Test 2 lookfor OK" else error(0, "Test 2 lookfor fails"); if lookfor('(now is), '(well hello!, now)) = NIL then "Test 3 lookfor OK" else error(0, "Test 3 lookfor fails"); %-------------------- 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); if add('(9 9), '(9 9), 0, 10) = '(8 9 1) then "Test 1 add OK" else error(0, "Test 1 add fails"); if add('(-9 -9), '(9 9), 0, 10) = '(0 0) then "Test 2 add OK" else error(0, "Test 2 add fails"); 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"); 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"); if add('(13 12), '(15 1), 0, 16) = '(12 14) then "Test 5 add OK" else error(0, "Test 5 add fails"); %-------------------- 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); if clength('(a b c), nil) = 3 then "Test 1 clength OK" else error(0, "Test 1 clength fails"); << xxx := '(a b c); cdr lastpair xxx := xxx; nil >>; if clength(xxx, nil) = 3 then "Test 2 clength OK" else error(0, "Test 1 clength fails"); if clength(append('(a b c), xxx), nil) = 6 then "Test 3 clength OK" else error(0, "Test 1 clength fails"); %------------------------- 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; if fringe nil = '(NIL) then "Test 1 fringe OK" else error(0, "Test 1 fringe fails"); if fringe '(a b . c) = '(a b c) then "Test 2 fringe OK" else error(0, "Test 2 fringe fails"); if fringe '((((a) . b) (c . d)) . e) = '(a b c d e) then "Test 3 fringe OK" else error(0, "Test 3 fringe fails"); %------------------------- 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); if delall('X, nil) = NIL then "Test 1 delall OK" else error(0, "Test 1 delall fails"); if delall('X, '(X)) = NIL then "Test 2 delall OK" else error(0, "Test 2 delall fails"); if delall('X, '(A)) = '(A) then "Test 3 delall OK" else error(0, "Test 3 delall fails"); if delall('(X B), '(A (B) (X B))) = '(A (B)) then "Test 4 delall OK" else error(0, "Test 4 delall fails"); if delall('(X B), '((X B) (X B))) = NIL then "Test 5 delall OK" else error(0, "Test 5 delall fails"); if delall('(X B), '((X B) X B (X B))) = '(X B) then "Test 6 delall OK" else error(0, "Test 6 delall fails"); % ------------------------- 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); 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"); 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"); if startswith('(P R E), '(P R E)) = T then "Test 3 startswith OK!" else error(0, "Test 3 startswith fails"); if startswith('(P R E), '(P R)) = NIL then "Test 4 startswith OK!" else error(0, "Test 4 startswith fails"); if startswith('(P R E), NIL) = NIL then "Test 5 startswith OK!" else error(0, "Test 5 startswith fails"); if startswith('(P R E), '(P P R E)) = NIL then "Test 6 startswith OK!" else error(0, "Test 6 startswith fails"); % ##### 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; if goodlist '(a b c) = T then "Test 1 goodlist OK" else error(0, "Test 1 goodlist fails"); if goodlist nil = T then "Test 2 goodlist OK" else error(0, "Test 2 goodlist fails"); if goodlist '(a . b) = NIL then "Test 3 goodlist OK" else error(0, "Test 3 goodlist fails"); %------------------------- 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); if fmember('a, '(b c a d), function EQ) = '(a d) then "Test 1 fmember is OK" else error(0, "Test 1 fmember fails"); if fmember('(a), '((b c) (a) d), function EQ) = NIL then "Test 2 fmember is OK" else error(0, "Test 2 fmember fails"); if fmember('(a), '((b c) (a) d), function EQUAL) = '((a) d) then "Test 3 fmember is OK" else error(0, "Test 3 fmember fails"); if fmember(34, '(1 2 56 12), function LESSP) = '(56 12) then "Test 4 fmember is OK" else error(0, "Test 4 fmember fails"); %------------------------- 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); if findem('(a 1 23 b "foo"), function idp) = '(a b) then "Test 1 findem OK!" else error(0, "Test 1 findem fails"); 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"); %------------------------- 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); % Basic ascending order sort. insert(6, '(1 5 10), function geq); if insert(6, '(1 5 10), function geq) = '(1 5 6 10) then "Test 1 insert (>=) OK" else error(0, "Test 1 insert (>=) fails"); % Try inserting element at end of list. insert(11, '(1 5 10), function geq); if insert(11, '(1 5 10), function geq) = '(1 5 10 11) then "Test 2 insert (>=) OK" else error(0, "Test 2 insert (>=) fails"); % Tru inserting something at the list beginning. insert(-1, '(1 5 10), function geq); if insert(-1, '(1 5 10), function geq) = '(-1 1 5 10) then "Test 3 insert (>=) OK" else error(0, "Test 3 insert (>=) fails"); % Insert into an empty list. insert('34, nil, function leq); if insert(34, nil, function leq) = '(34) then "Test 4 insert (<=) OK" else error(0, "Test 4 insert (<=) fails"); % Use a funny insertion function for (order . any); expr procedure cargeq(a, b); car a >= car b; insert('(34 . any), '((5 . now) (20 . and) (30 . then) (40 . but)), function cargeq); 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"); % ###### 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; if floatlist '(3 3.4 a nil) = '(3.4) then "Test 1 floatlist OK" else error(0, "Test 1 floatlist fails"); 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"); if floatlist '(a b c) = NIL then "Test 3 floatlist OK" else error(0, "Test 3 floatlist fails"); %------------------------- 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; if revpairnum '(a b c) = '((3 . a) (2 . b) (1 . c)) then "Test 1 revpairnum OK" else error(0, "Test 1 revpairnum fails"); if revpairnum nil = nil then "Test 2 revpairnum OK" else error(0, "Test 2 revpairnum fails"); if revpairnum '(a) = '((1 . a)) then "Test 3 revpairnum OK" else error(0, "Test 3 revpairnum fails"); %------------------------- 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}; if lflatten '(a (b) c (e (e))) = '(a b c e e) then "Test 1 lflatten OK" else error(0, "Test 1 lflatten fails"); if lflatten '(a b c) = '(a b c) then "Test 2 lflatten OK" else error(0, "Test 2 lflatten fails"); if lflatten nil = nil then "Test 3 lflatten OK" else error(0, "Test 3 lflatten fails"); if lflatten '(a (b (c (d)))) = '(a b c d) then "Test 4 lflatten OK" else error(0, "Test 4 lflatten fails"); %------------------------- Exercise #4 ------------------------- expr procedure realstuff l; /* REALSTUFF(L) returns the number of non-nil items in l. */ for each x in l count x; if realstuff '(a b nil c) = 3 then "Test 1 realstuff OK" else error(0, "Test 1 realstuff fails"); if realstuff '(nil nil nil) = 0 then "Test 2 realstuff OK" else error(0, "Test 2 realstuff fails"); if realstuff '(a b c d) = 4 then "Test 3 realstuff OK" else error(0, "Test 3 realstuff fails"); %------------------------- 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 '(The man in the field is happy); %------------------------- 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 >>; xxx := [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"); xxx := [1]; if bsort xxx = [1] then "Test 2 bsort OK" else error(0, "Test 2 bsort fails"); %------------------------- 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 >> >>; xxx := [1,2,'a]; if atom errorset(quote bsortt xxx, nil, nil) then "Test 1 bsortt OK" else error(0, "Test 1 bsortt fails"); xxx := [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"); % ------------------------- 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; if average '(a 12 34) = 23 then "Test 1 average OK" else error(0, "Test 1 average fails"); if average '(a b c) = 0 then "Test 2 average OK" else error(0, "Test 2 average fails"); if average '(a b c 5 6) = 5 then "Test 3 average OK" else error(0, "Test 3 average fails"); if average '(a b c 5 6.0) = 5.5 then "Test 4 average OK" else error(0, "Test 4 average fails"); %------------------------- 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}; if boundingbox '((0 . 1) (4 . 5)) = '(0 4 1 5) then "Test 1 boundingbox OK" else error(0, "Test 1 boundingbox fails"); if boundingbox nil = '(0 0 0 0) then "Test 2 boundingbox OK" else error(0, "Test 2 boundingbox fails"); 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"); %------------------------- 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); 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"); if maxlists(nil, '(44.22 0.9 1.3)) = nil then "Test 2 maxlists OK" else error(0, "Test 2 maxlists fails"); if maxlists('(44.22 0.9 1.3), nil) = nil then "Test 3 maxlists OK" else error(0, "Test 3 maxlists fails"); 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"); %------------------------- 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; if numberedlist nil = nil then "Test 1 numberedlist is OK" else error(0, "Test 1 numberedlist fails"); if numberedlist '(a) = '((a . 0)) then "Test 2 numberedlist is OK" else error(0, "Test 2 numberedlist fails"); if numberedlist '(a b c) = '((a . 0) (b . 1) (c . 2)) then "Test 2 numberedlist is OK" else error(0, "Test 2 numberedlist fails"); %------------------------- 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; global '(x11); x11 := '((!! . 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"); if x11 = '(a (b c) (d (!! . 34))) then "Test 2 reduce OK" else error(0, "Test 2 reduce fails"); % ##### 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; xxx := '((!!. a) (!! . b) c (!! . d)); if removeflags xxx = '(a b c (!! . d)) then "Test 1 removeflags OK" else error(0, "Test 1 removeflags fails"); if xxx = '(a b c (!! . d)) then "Test 2 removeflags OK" else error(0, "Test 2 removeflags fails"); %------------------------- 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; if read2char '!* = {!$EOL!$, 'A, 'B, 'C, '!*} then "Test 1 read2char OK" else error(0, "Test 1 read2char fails"); ABC* %------------------------- 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; if skipblanks '(! ! ! a b) neq '(a b) then error(0, "Skipblanks fails test #1"); if skipblanks nil then error(0, "Skipblanks fails test #2"); if skipblanks '(! ! ! ) then error(0, "Skipblanks fails test #3"); if skipblanks '(! ! a b ! ) neq '(a b ! ) then error(0, "Skipblanks fails test #4"); %------------------------- 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); if ntoken '(! ! a b ! ) neq '((a b) . (! )) then error(0, "ntoken fails test #1"); if ntoken nil then error(0, "ntoken fails test #2"); if ntoken '(! ! ! ) then error(0, "ntoken fails test #3"); if ntoken '(! ! a b) neq '((a b) . nil) then error(0, "ntoken fails test #4"); % ##### 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; if r2nums() = '(2 3) then "Test 1 r2nums OK" else error(0, "Test 1 r2nums failed"); 2 3 %------------------------- 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; fluid '(val); val := readcoordinate(); @ 57.29577 if val < 1.000001 AND val > 0.999999 then "Test 1 readcoordinate OK" else error(0, "Test 1 readcoordinate failed"); % This fails with poor arithmetic. val := readcoordinate(); (57 17 44.772) if val < 1.000001 AND val > 0.999999 then "Test 2 readcoordinate OK" else error(0, "Test 2 readcoordinate failed"); unfluid '(val); if readcoordinate() = 1.0 then "Test 3 readcoordinate OK" else error(0, "Test 3 readcoordinate failed"); 1.0 %------------------------- 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; fluid '(xxx yyy); % New - added to aid CSL. xxx := '(a b c nil d); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 1 dellallnils OK" else error(0, "Test 1 delallnils Fails!"); xxx := '(a nil b nil c nil d); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 2 dellallnils OK" else error(0, "Test 2 delallnils Fails!"); xxx := '(a nil b nil c nil d nil); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 3 dellallnils OK" else error(0, "Test 3 delallnils Fails!"); xxx := '(a nil nil nil nil b c d); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 4 dellallnils OK" else error(0, "Test 4 delallnils Fails!"); xxx := '(nil a b c d); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 5 dellallnils OK" else error(0, "Test 5 delallnils Fails!"); xxx := '(nil nil nil a b c d); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 6 dellallnils OK" else error(0, "Test 6 delallnils Fails!"); xxx := '(a b c d nil nil nil); yyy := delallnils xxx; if yyy = '(a b c d) and yyy eq xxx then "Test 7 dellallnils OK" else error(0, "Test 7 delallnils Fails!"); %------------------------- 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 >>; % 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; dprin1 '(a . b); dprin1 '(a 1 "foo"); dprin1 '(((a))); << x := mkvect 2; x[0] := 'a; x[1] := '(b c); x[2] := 34; >>; dprin1 {'(b c), x, 34}; % ##### Property List Exercises ##### %---------------------------- Exercise #1 ------------------------------ global '(stack!*); 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 >>; 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!*; put('!-, 'STACKFN, '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!*; put('!+, 'STACKFN, 'pplus2); expr procedure pprint; /* PPRINT() - Print the top stack element. */ print car stack!*; put('PRINT, 'STACKFN, 'pprint); pexecute '(3 4 !+); if stack!* neq '(7) then error(0, "PEXECUTE test #1 fails"); stack!* := nil; pexecute '(5 3 !- 2 4 !+ !+); if stack!* neq '(8) then error(0, "PEXECUTE test #2 fails"); %---------------------------- 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 >>; 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!* >>; put('SET, 'STACKFN, 'pset); stack!* := nil; pexecute '(4.5 quote x set 4 !+ x !+ PRINT); if stack!* neq '(13.0) then error(0, "Test 3 PEXECUTE fails"); % ##### 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 */; 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)))); /* A simple quad tree. */ global '(qdemo); qdemo := qtree(node := 'A, q1 := qtree(node := 'B), q2 := qtree(node := 'C), q3 := qtree(node := 'D, q1 := qtree(node := 'E)), q4 := qtree(node := 'F)); if qvisit qdemo = '(A B C D E F) then "Test 1 qvisit OK!" else error(0, "Test 1 qvisit Fails!"); /* The quadtree in the book. */ global '(qdemo2); 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))); if qvisit qdemo2 = '(A B C D E F G H I) then "Test 2 qvisit OK!" else error(0, "Test 2 qvisit Fails!"); if qvisit nil = NIL then "Test 3 qvisit OK!" else error(0, "Test 3 qvisit Fails!"); %------------------------- 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; if qsearch(qdemo, 'E, function EQ) = '(A D E) then "Test 1 qsearch OK!" else error(0, "Test 1 qsearch fails"); if qsearch(qdemo, 'XXX, function EQ) = nil then "Test 2 qsearch OK!" else error(0, "Test 2 qsearch fails"); if qsearch(qdemo2, 'F, function EQ) = '(A D E F) then "Test 3 qsearch OK!" else error(0, "Test 3 qsearch fails"); %------------------------- 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. */; 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) >>; /* Demo the back chain. */ global '(cch); 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)}); % Wrap this up to avoid printing problems. << backchain(cch, 'COMMANDER); NIL >>; if superior cch EQ 'COMMANDER then "Test 1 backchain OK!" else error(0, "Test 1 backchain Fails!"); if name superior car subordinates cch EQ 'TOP then "Test 2 backchain OK!" else error(0, "Test 2 backchain Fails!"); if name superior car subordinates cadr subordinates cch eq 'LEV1-B then "Test 3 backchain OK!" else error(0, "Test 3 backchain Fails!"); % ##### 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); if lookup('a, '((a . b) (c . d))) = 'b then "Test 1 lookup success" else error(0, "Test 1 lookup fails"); if errorset(quote lookup('f, '((a . b) (c . d))), nil, nil) = 0 then "Test 2 lookup success" else error(0, "Test 2 lookup fails"); %------------------------- 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; if quadratic(1.0, 2.0, 1.0) = '(-1.0 -1.0) then "Test 1 quadratic OK!" else error(0, "Test 1 quadratic Fails!"); if quadratic(1.0, 0.0, -1.0) = '(1.0 -1.0) then "Test 2 quadratic OK!" else error(0, "Test 2 quadratic Fails!"); %------------------------- 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; 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"); % 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"); 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"); 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"); % 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"); 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"); %------------------------- 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; if stdev '(3.0 3.0 3.0) neq 0.0 then error(0, "Test 1 STDEV fails"); % ##### 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]; if vaverage array(1,2,3) = 2.0 then "Test 1 vaverage is OK" else error(0, "Test 1 vaverage fails"); if vaverage array(3, 'a, 3, 6.0, 'f) = 4.0 then "Test 2 vaverage is OK" else error(0, "Test 2 vaverage fails"); if vaverage array('a, 'b) = 0.0 then "Test 3 vaverage is OK" else error(0, "Test 3 vaverage fails"); %------------------------- 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; global '(a1 a2); a1 := array(1, 2, 3); a2 := array(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"); if mappend(mkvect 0, mkvect 0) = mkvect 1 then "Test 2 MAPPEND is OK" else error(0, "Test 2 MAPPEND fails"); %------------------------- Exercise #3 ------------------------- expr procedure index(a, v); /* INDEX(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 index('a, array(1, 2, 'a, 34)) = 2 then "Test 1 index OK" else error(0, "Test 1 index fails"); if null index('a, array(1, 2, 3, 4)) then "Test 2 index OK" else error(0, "Test 2 index fails"); %------------------------- 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; 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)); 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)); 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]}; /* 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); tmat := rotatex4x4(45.0 / 57.29577); 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"); 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"); 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"); 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"); 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"); 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"); 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"); 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"); /* Now try the multiplication routine. */ tmat := mpy4x4(rotatex4x4(45.0 / 57.29577), translate4x4(1.0, 2.0, 3.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"); 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"); %------------------------- 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; 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; 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"; if ltident 0 = array(array(1.0)) then "Test 2 ltident OK" else "Test 2 ltident fails"; if ltmpy(ltident 2, ltident 2) = ltident 2 then "Test 3 ltident OK" else "Test 3 ltident fails"; 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"); 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"); %------------------------- 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; /* Create the coercion array. Here int=0, string=1, float=2, complex=3, and gaussian=4 */ global '(cpath); 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)); % 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"); % Coerce Complex into int. if coerce(3, 0, nil, cpath) = NIL then "Test 2 coerce OK" else error(0, "Test 2 coerce fails"); % 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"); %------------------------- 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)]}); 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; 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; /* LIFESTATES contains a vector of states and what character to print. */ global '(LIFESTATES); 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]] >>; 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 >>; /* SEED is the seed array with 1's for on state, 0 for off. */ global '(seed); 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)); rungame(seed, 10, function life, LIFESTATES); %------------------------- 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; /* A simple array to test. */ global '(H); 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); if compact H = 12 then "Test 1 compact OK!" else error(0, "Test 1 compact fails!"); 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 a completely full one. */ H := array('INUSE, 3, 0, 'INUSE, 5, 1, 2, 3); if compact H = 0 then "Test 3 compact OK!" else error(0, "Test 3 compact fails!"); if H = array('INUSE, 3, 0, 'INUSE, 5, 1, 2, 3) then "Test 4 compact OK!" else error(0, "Test 4 compact fails!"); /* Test a completely empty one. */ H := array('FREE, 3, '!*, 'FREE, 5, '!*, '!*, '!*); if compact H = 8 then "Test 5 compact OK!" else error(0, "Test 5 compact fails!"); if H = array('FREE, 8, '!*, '!*, '!*, '!*, '!*, '!*) then "Test 6 compact OK!" else error(0, "Test 6 compact fails!"); %------------------------- 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; global '(v1); << v1 := mkvect 100; for i:=0:100 do v1[i] := float i >>; if HISTOGRAM(v1, 1) = array(101) then "Test 1 HISTOGRAM OK!" else error(0, "Test 1 HISTOGRAM Fails!"); if HISTOGRAM(v1, 2) = array(50, 51) then "Test 2 HISTOGRAM OK!" else error(0, "Test 2 HISTOGRAM Fails!"); if HISTOGRAM(v1, 7) = array(15, 14, 14, 15, 14, 14, 15) then "Test 3 HISTOGRAM OK!" else error(0, "Test 3 HISTOGRAM Fails!"); %------------------------- 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; if upbv rarray 4 = 4 then "Test 1 rarray OK" else error(0, "Test 1 rarray fails"); 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; global '(xxx); 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)); % 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!"); 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!"); %------------------------- 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; global '(ninth); xxx[2,2] := 1.0; ninth := 1.0 / 9.0; 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!"); %------------------------- 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; 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)); 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!"); %------------------------- 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; xxx := mkarray(4,4); for i:=0:4 do for j:=0:4 do xxx[i,j] := i * j; 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!"); 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; % ##### Macro Exercises ##### %------------------------- Exercise ----------------------- macro procedure appendl x; /* APPENDL( ...) - append all the lists together. */ expand(cdr x, 'append); 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!"); if appendl '(a b c) = '(a b c) then "Test 2 appendl OK!" else error(0, "Test 2 appendl fails!"); if appendl nil = nil then "Test 3 appendl OK!" else error(0, "Test 3 appendl fails!"); %------------------------- Exercise ------------------------ macro procedure nconcl x; /* NCONCL(...) - destructive concatenation of all the lists. */ expand(cdr x, 'nconc); global '(b1 b2 b3); b1 := '(a b); b2 := '(c d); b3 := '(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!"); if b1 = '(a b c d e f) then "Test 2 nconcl OK!" else error(0, "Test 2 nconcl fails!"); if b2 = '(c d e f) then "Test 3 nconcl OK!" else error(0, "Test 3 nconcl fails!"); if b3 = '(e f) then "Test 4 nconcl OK!" else error(0, "Test 4 nconcl fails!"); %------------------------- 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); % 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!"); if d(0, 0, 1, 1) = sqrt 2 then "Test 2 d OK!" else error(0, "Test 2 d Fails!"); %------------------------- 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; xxx := '(A B); if pop xxx eq 'A then "Test 1 POP ok!" else error(0, "Test 1 POP fails!"); if xxx = '(B) then "Test 1 POP ok!" else error(0, "Test 1 POP fails!"); if pop xxx eq 'B then "Test 2 POP ok!" else error(0, "Test 2 POP fails!"); if xxx eq NIL then "Test 2 POP ok!" else error(0, "Test 2 POP fails!"); %------------------------- 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; if push(xxx, 'A) = 'A then "Test 1 push OK!" else error(0, "Test 1 push fails"); if xxx = '(A) then "Test 1 push OK!" else error(0, "Test 1 push fails"); if push(xxx, 'B) = 'B then "Test 2 push OK!" else error(0, "Test 2 push fails"); if xxx = '(B A) then "Test 2 push OK!" else error(0, "Test 2 push fails"); %------------------------- 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 >>; se se 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; expr procedure makestring l; /* MAKESTRING(L) - convert the list of character L into a string. */ compress('!" . append(l, '(!"))); expr procedure printf!-terpri; /* PRINTF!-TERPRI() - Generates a TERPRI call for %n */ '(terpri); put('!n, 'printf!-expand, 'printf!-terpri); put('!N, 'printf!-expand, 'printf!-terpri); expr procedure printf!-prin1 x; /* PRINTF!-PRIN1(X) - Generates a PRIN1 call for %w */ {'prin1, x}; put('!w, 'printf!-format, 'printf!-prin1); put('!W, 'printf!-format, 'printf!-prin1); expr procedure printf!-prin2 x; /* PRINTF!-PRIN2(X) - Generates a PRIN2 call for %p */ {'prin2, x}; put('!p, 'printf!-format, 'printf!-prin2); put('!P, 'printf!-format, '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; expr procedure makestring l; /* MAKESTRING(L) - convert the list of character L into a string. */ compress('!" . append(l, '(!"))); expr procedure rmsg!-terpri; /* RMSG!-TERPRI() - Generates an EOL. */ mkquote {!$eol!$}; put('!n, 'rmsg!-expand, 'rmsg!-terpri); put('!N, 'rmsg!-expand, 'rmsg!-terpri); expr procedure rmsg!-prin1 x; /* RMSG!-PRIN1(X) - Generates an EXPLODE call */ `(fixstr (explode #x)); put('!w, 'rmsg!-format, 'rmsg!-prin1); put('!W, 'rmsg!-format, 'rmsg!-prin1); expr procedure rmsg!-prin2 x; /* RMSG!-PRIN2(X) - Generates an EXPLODE2 call for x. */ `(explode2 #x); put('!p, 'rmsg!-format, 'rmsg!-prin2); put('!P, 'rmsg!-format, '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; if rmsg "abc" = "abc" then "Test 1 rmsg OK!" else error(0, "Test 1 rmsg fails!"); if rmsg("Test %w test", 12) = "Test 12 test" then "Test 2 rmsg OK!" else error(0, "Test 2 rmsg fails!"); if rmsg("Test %w string", "foo") = "Test ""foo"" string" then "Test 3 rmsg OK!" else error(0, "Test 3 rmsg fails!"); if rmsg("Test %w now %p", "foo", "foo") = "Test ""foo"" now foo" then "Test 4 rmsg OK!" else error(0, "Test 4 rmsg fails!"); %------------------------- Exercise ------------------------- define CFLAG = T; 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 expr procedure pslfoo x; car x; if getd 'pslfoo then "Test 1 ifCFLAG OK!" else error(0, "Test 1 ifCFLAG fails!"); % ##### Interactive Exercises ##### %------------------------- Exercise #2 ------------------------- /* Lists functions that have been embedded with count code. */ global '(EMBEDDED!*); EMBEDDED!* := 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; 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) >>; 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; if embed 'pcnt eq 'pcnt then "Test 1 embed OK!" else error(0, "Test 1 embed Fails!"); if get('pcnt, 'count) = 0 then "Test 2 embed OK!" else error(0, "Test 2 embed Fails!"); if pcnt '(a . (b . c)) = 2 then "Test 3 embed OK!" else error(0, "Test 3 embed Fails!"); if get('pcnt, 'COUNT) = 5 then "Test 4 embed OK!" else error(0, "Test 4 embed Fails!"); if EMBEDDED!* = '(PCNT) then "Test 5 embed OK!" else error(0, "Test 5 embed Fails!"); % Just a visual check. stats(); % ##### 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; % Describe some of the basic data types. % Dotted-pairs. describe '(a . b); % Vectors; global '(xvar); xvar := mkvect 3; describe xvar; % Records. record insprec /* A record for testing. */ with field1 := 'a; xvar := insprec(); describe xvar; describe 'insprec; % A code pointer (usually). describe cdr getd 'car; % Numbers. describe 1; describe 3.14159; % Strings describe "This is a string"; % identifiers of various sourts. describe 'car; describe 'a!-plain!-jane!-identifier; describe 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); DEFINE TheCow = "How now brown cow"; describe 'TheCow; off saveactives; /* I never saw a purple cow, I never hope to see one now. */ global '(PurpleCow); describe 'PurpleCow; on saveactives; /* But I'd rather see one than be one! */ global '(Pcow); describe 'Pcow; % Now we march on to procedures. % Here's one with no comment and we don't save it. off saveactives; remd 'comtest1; expr procedure comtest1 x; print x; describe 'comtest1; % Here's one with no comment and we do save it. on saveactives; remd 'comtest2; expr procedure comtest2(x, y); print x; describe 'comtest2; % Here's one with a comment but we don't save it. off saveactives; remd 'comtest3; expr procedure comtest3(x, y, z); /* You should never see this comment. */ print x; describe 'comtest3; % Here's one with a comment and we should see it. on saveactives; remd 'comtest4; 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; describe 'comtest4; % Now try MACROS. remd 'comtest5; macro procedure comtest5 x; /* COMTEST5(X) - A macro that doesn't really do much of anything. */ {'car, cadr x}; describe 'comtest5; smacro procedure comtest6 x; /* COMTEST6(X) - a SMACRO with an active comment. This smacro expands to take CAR of its argument. */ car x; describe 'comtest6; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Module testing. /* This is a test module which occurs at the top level just to make sure that the module type works. */ module testmodule; endmodule; describe 'testmodule; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 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); describe 'testvariable; LINELENGTH 60; describe 'testvariable; LINELENGTH 50; describe 'testvariable; LINELENGTH 40; describe 'testvariable; LINELENGTH 30; describe 'testvariable; LINELENGTH 20; describe 'testvariable; LINELENGTH 10; describe 'testvariable; % ##### Records Package ##### global '(rec1 rec2); % Simple test. record rtest1; rec1 := rtest1(); if rec1 neq array 'rtest1 then error(0, "Test 1 RECORD fails creation test!"); if null rtest1p rec1 then error(0, "Test 1 RECORD fails predicate test!"); % A record with two fields. record rtest2 with field1 := 0, field2 := 1; % Test default creation. rec2 := rtest2(); if rec2 neq array('rtest2, 0, 1) then error(0, "Test 2 RECORD fails to create a record"); if null rtest2p rec2 then error(0, "Test 2 RECORD fails predicate test"); if rtest2p rec1 then error(0, "Test 2 RECORD fails to test record differences"); % Build a record with a predicate. Remove any old occurrence. remd 'rtest3!?; record rtest3 with field1 := 0, field2 := 1 has predicate = rtest3!?; if not getd 'rtest3!? then error(0, "Test 3 RECORD fails - no predicate built"); if rtest3!? rec2 then error(0, "Test 3 RECORD fails - predicate returns T on non RTEST3 record"); 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}); rec2 := rtest3(); if not rtest3!? rec2 then error(0, "Test 3 RECORD fails - predicate returns NIL on record"); % Check that the no-predicate option works. remd 'rtest4p; % Just to make sure. record rtest4 with a := 34, b := 56 has no predicate; if getd 'rtest4p then error(0, "Test 4 RECORD fails - NO PREDICATE option generates a predicate"); % Verify that the CONSTRUCTOR option works. remd 'rtest5; remd 'make-rtest5; record rtest5 with r5a := 0, r5b := 1 has constructor; if getd 'rtest5 then error(0, "Test 5 RECORD fails - CONSTRUCTOR generates simple constructor"); if not getd 'make-rtest5 then error(0, "Test 5 RECORD fails - CONSTRUCTOR doesn't generate constructor"); if not rtest5p make-rtest5() then error(0, "Test 5 RECORD fails - CONSTRUCTOR doesn't generate record"); % Verify that the named constructor works. remd 'rtest6; remd 'please-make-rtest6; record rtest6 with r6a := 0 has constructor = please!-make!-arecord; if getd 'rtest6 then error(0, "Test 6 RECORD fails - CONSTRUCTOR generates simple constructor"); if getd 'make-rtest6 then error(0, "Test 6 RECORD fails - CONSTRUCTOR generates make- constructor"); if not getd 'please-make-arecord then error(0, "Test 6 RECORD fails - CONSTRUCTOR doesn't generate constructor"); if not rtest6p please-make-arecord() then error(0, "Test 6 RECORD fails - CONSTRUCTOR doesn't generate record"); end;