Artifact daab9e14d7cf52fbc8ca0b397cdae12a83bd65fb138103360d2c4bc4a425f4bf:
- File
r36/xlog/RLISP88.LOG
— part of check-in
[152fb3bdbb]
at
2011-10-17 17:58:33
on branch master
— svn:eol-style, svn:executable and line endings for files
in historical/r36 treegit-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1480 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: schoepf@users.sourceforge.net, size: 97811) [annotate] [blame] [check-ins using] [more...]
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