@@ -1,5448 +1,5448 @@ -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 +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