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