home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d5xx
/
d524
/
kamin.lha
/
Kamin
/
P-Distr.lzh
/
code.gc.lsp
< prev
next >
Wrap
Text File
|
1988-11-18
|
14KB
|
415 lines
; From chapter 1
(define mod (m n) (- m (* n (/ m n))))
(define +1 (x) (+ x 1))
; Section 2.1.3
(cons 'a '())
'(a)
(cons 'a '(b))
'(a b)
(cons '(a) '(b))
'((a) b)
(cdr '(a (b (c d))))
'((b (c d)))
(null? '())
'T
(null? '(()))
'()
(define length (l) (if (null? l) 0 (+1 (length (cdr l)))))
(define caar (l) (car (car l)))
(define cadr (l) (car (cdr l)))
(define cddr (l) (cdr (cdr l)))
(define caddr (l) (car (cdr (cdr l))))
(define cadar (l) (car (cdr (car l))))
(define cadddr (exp) (car (cdr (cdr (cdr exp)))))
(define list1 (x) (cons x '()))
(define list2 (x y) (cons x (cons y '())))
(define list3 (x y z) (cons x (cons y (cons z '()))))
(list2 (list1 'a) 'b)
'((a) b)
(define or (x y) (if x x y))
(define atom? (x) (or (null? x) (or (number? x) (symbol? x))))
(define equal (l1 l2)
(if (atom? l1) (= l1 l2)
(if (atom? l2) '()
(if (equal (car l1) (car l2))
(equal (cdr l1) (cdr l2))
'()))))
(equal 'a 'b)
'()
(equal '(a (1 3) c) '(a (1 3) c))
'T
(equal '(a (1 3) d) '(a (1 3) c))
'()
(define and (x y) (if x y x)).
(define not (x) (if x '() 'T)).
(define divides (m n) (= (mod n m) 0))
(define interval-list (m n)
(if (> m n) '() (cons m (interval-list (+1 m) n))))
(interval-list 3 7)
'(3 4 5 6 7)
(define remove-multiples (n l)
(if (null? l) '()
(if (divides n (car l))
(remove-multiples n (cdr l))
(cons (car l) (remove-multiples n (cdr l))))))
(remove-multiples 2 '(2 3 4 5 6 7))
'(3 5 7)
(define sieve (l)
(if (null? l) '()
(cons (car l) (sieve (remove-multiples (car l) (cdr l))))))
(define primes<= (n) (sieve (interval-list 2 n)))
(primes<= 10)
'(2 3 5 7)
(define insert (x l)
(if (null? l) (list1 x)
(if (< x (car l)) (cons x l)
(cons (car l)(insert x (cdr l))))))
(define insertion-sort (l)
(if (null? l) '()
(insert (car l) (insertion-sort (cdr l)))))
(insertion-sort '(4 3 2 6 8 5))
'(2 3 4 5 6 8)
(define assoc (x alist)
(if (null? alist) '()
(if (= x (caar alist)) (cadar alist)
(assoc x (cdr alist)))))
(assoc 'U '((E coli)(I Ching)(U Thant)))
'Thant
(define mkassoc (x y alist)
(if (null? alist)
(list1 (list2 x y))
(if (= x (caar alist)) (cons (list2 x y) (cdr alist))
(cons (car alist) (mkassoc x y (cdr alist))))))
(set al (mkassoc 'I 'Ching '()))
'((I Ching))
(set al (mkassoc 'E 'coli al))
'((I Ching)(E Coli))
(set al (mkassoc 'I 'Magnin al))
'((I Magnin)(E coli))
(assoc 'I al)
'Magnin
(set fruits '((apple ((texture crunchy)))(banana ((color yellow)))))
(define getprop (x p plist)
; find property p of individual x in plist
(assoc p (assoc x plist)))
(getprop 'apple 'texture fruits)
'crunchy
(define putprop (x p y plist)
; give individual x value y for property p
(mkassoc x (mkassoc p y (assoc x plist)) plist))
(set fruits (putprop 'apple 'color 'red fruits))
'((apple ((texture crunchy)(color red)))(banana ((color yellow)))))
(getprop 'apple 'color fruits)
'red
(define hasprop? (p y alist) (= (assoc p alist) y))
(define gatherprop (p y plist)
; get all individuals having value y for property p
(if (null? plist) '()
(if (hasprop? p y (cadar plist))
(cons (caar plist) (gatherprop p y (cdr plist)))
(gatherprop p y (cdr plist)))))
(set fruits (putprop 'lemon 'color 'yellow fruits))
'((apple ((texture crunchy) ... (lemon ((color yellow))))))
(gatherprop 'color 'yellow fruits)
'(banana lemon)
(set nullset '())
'()
(define addelt (x s)
(if (member? x s) s (cons x s)))
(define member? (x s)
(if (null? s) '()
(if (equal x (car s)) 'T (member? x (cdr s)))))
(define size (s) (length s))
(define union (s1 s2)
(if (null? s1) s2
(if (member? (car s1) s2)
(union (cdr s1) s2)
(cons (car s1) (union (cdr s1) s2)))))
(set s (addelt 3 (addelt 'a nullset)))
'(3 a)
(member? 'a s)
'T
(union s (addelt 2 (addelt 3 nullset)))
'(a 2 3)
(set t (addelt '(a b) (addelt 1 nullset)))
'((a b) 1)
(member? '(a b) t)
'T
(define sum (l)
(if (null? l) 0
(if (number? l) l
(+ (sum (car l)) (sum (cdr l))))))
(define wrong-sum (l)
(if (null? l) 0
(if (number? l) l
(begin
(set tmp (wrong-sum (car l)))
(+ (wrong-sum (cdr l)) tmp)))))
(sum '(1 2 3 4))
10
(wrong-sum '(1 2 3 4))
16
(define right-sum (l) (right-sum-aux l 0))
(define right-sum-aux (l tmp)
(if (null? l) 0
(if (number? l) l
(begin
(set tmp (right-sum (car l)))
(+ (right-sum (cdr l)) tmp)))))
(right-sum '(1 2 3 4))
10
(define pre-ord (tree)
(if (atom? tree) (print tree)
(begin
(print (car tree))
(pre-ord (cadr tree))
(pre-ord (caddr tree)))))
(pre-ord '(A (B C D) (E (F G H) I)))
'(output is A B C D E F G H I)
; Queue operations
(set empty-queue '())
(define front (q) (car q))
(define rm-front (q) (cdr q))
(define enqueue (t q)
(if (null? q) (list1 t) (cons (car q) (enqueue t (cdr q)))))
(define empty? (q) (null? q))
; Level-order traversal
(define level-ord (tree) (level-ord* (enqueue tree empty-queue)))
(define level-ord* (node-q)
(if (empty? node-q) '()
(begin
(set this-node (front node-q))
(if (atom? this-node)
(begin
(print this-node)
(level-ord* (rm-front node-q)))
(begin
(print (car this-node))
(level-ord*
(enqueue (caddr this-node)
(enqueue (cadr this-node) (rm-front node-q)))))))))
(level-ord '(A (B C D) (E (F G H) I)))
'(output is A B E C D E F I G H)
; Section 2.3
(define inter (s1 s2)
(if (null? s1) s1
(if (member? (car s1) s2)
(cons (car s1) (inter (cdr s1) s2))
(inter (cdr s1) s2))))
(define diff (s1 s2)
(if (null? s1) s1
(if (null? s2) s1
(if (member? (car s1) s2)
(diff (cdr s1) s2)
(cons (car s1) (diff (cdr s1) s2))))))
(define UNION (r s)
(if (not (equal (car r) (car s)))
(print 'error)
(cons (car r) (union (cdr r) (cdr s)))))
(define INTER (r s)
(if (not (equal (car r) (car s)))
(print 'error)
(cons (car r) (inter (cdr r) (cdr s)))))
(define DIFF (r s)
(if (not (equal (car r) (car s)))
(print 'error)
(cons (car r) (diff (cdr r) (cdr s)))))
(define SELECT (A v r)
(cons (car r) (include-rows v (col-num A (car r)) (cdr r))))
(define col-num (A A-list)
(if (= A (car A-list)) 0
(+1 (col-num A (cdr A-list)))))
(define include-rows (v n rows)
(if (null? rows) '()
(if (= v (nth n (car rows)))
(cons (car rows) (include-rows v n (cdr rows)))
(include-rows v n (cdr rows)))))
(define nth (n l)
(if (= n 0) (car l) (nth (- n 1) (cdr l))))
(define PROJECT (X r)
(cons X (include-cols* (col-num* X (car r)) (cdr r))))
(define col-num* (X A-list)
(if (null? X) '()
(cons (col-num (car X) A-list) (col-num* (cdr X) A-list))))
(define include-cols* (col-nums rows)
(if (null? rows) nullset
(addelt (include-cols col-nums (car rows))
(include-cols* col-nums (cdr rows)))))
(define include-cols (col-nums row)
(if (null? col-nums) '()
(cons (nth (car col-nums) row)
(include-cols (cdr col-nums) row))))
(define append (x y)
(if (null? x) y (cons (car x) (append (cdr x) y))))
(define JOIN (r s)
(begin
(set intersection (inter (car r) (car s)))
(set r-intersection (col-num* intersection (car r)))
(set s-intersection (col-num* intersection (car s)))
(set r-diff-s (diff (car r) intersection))
(set r-diff-s-cols (col-num* r-diff-s (car r)))
(set s-diff-r (diff (car s) intersection))
(set s-diff-r-cols (col-num* s-diff-r (car s)))
(cons (append intersection (append r-diff-s s-diff-r))
(join-cols* r-intersection r-diff-s-cols s-intersection
s-diff-r-cols (cdr r) (cdr s)))))
(define join-cols* (X-r r-cols X-s s-cols r-rows s-rows)
(begin
(set new-rows '())
(while (not (null? r-rows))
(begin
(set s-tmp s-rows)
(while (not (null? s-tmp))
(begin
(if (equal (include-cols X-r (car r-rows))
(include-cols X-s (car s-tmp)))
(set new-rows (cons (join-cols X-r r-cols s-cols
(car r-rows) (car s-tmp))
new-rows))
'())
(set s-tmp (cdr s-tmp))))
(set r-rows (cdr r-rows))))
new-rows))
(define join-cols (X-r r-cols s-cols r-row s-row)
(append (include-cols X-r r-row)
(append (include-cols r-cols r-row)
(include-cols s-cols s-row))))
(set CRIMES
'((Victim Crime Criminal Location)
(Phelps robbery Harrison London)
(Drebber murder Hope London)
(Sir-Charles murder Stapleton Devonshire)
(Lady-Eva blackmail Milverton London)
(Brunton murder Howells West-Sussex)))
(set MURDERS
'((Victim Weapon Motive)
(Drebber poison revenge)
(Sir-Charles hound greed)
(Brunton burial-alive passion)))
(JOIN MURDERS
(PROJECT '(Victim Criminal)
(SELECT 'Location 'London
(SELECT 'Crime 'murder CRIMES))))
'((Victim Weapon Motive Criminal) (Drebber poison revenge Hope))
; Section 2.4
(define eval (exp)
(if (number? exp) exp
(apply-op
(car exp)
(eval (cadr exp))
(eval (caddr exp)))))
(define apply-op (f x y)
(if (= f '+) (+ x y)
(if (= f '-) (- x y)
(if (= f '*) (* x y)
(if (= f '/) (/ x y) 'error!)))))
(eval '(+ 3 (* 4 5)))
23
(eval '(+ 3 4))
7
(eval '(+ (* 4 (/ 10 2)) (- 7 3)))
24
(define eval (exp rho)
(if (number? exp) exp
(if (symbol? exp) (assoc exp rho)
(apply-op
(car exp)
(eval (cadr exp) rho)
(eval (caddr exp) rho)))))
(eval '(+ i (/ 9 i)) (mkassoc 'i 3 '()))
6
(define eval (exp rho)
(if (number? exp) exp
(if (symbol? exp) (assoc exp rho)
(if (= (car exp) 'quote) (cadr exp)
(if (= (length exp) 2)
(apply-unary-op (car exp) (eval (cadr exp) rho))
(apply-binary-op (car exp)
(eval (cadr exp) rho)
(eval (caddr exp) rho))
)))))
(define apply-binary-op (f x y)
(if (= f 'cons) (cons x y)
(if (= f '+) (+ x y)
(if (= f '-) (- x y)
(if (= f '*) (* x y)
(if (= f '/) (/ x y)
(if (= f '<) (< x y)
(if (= f '>) (> x y)
(if (= f '=) (= x y) 'error!)))))))))
(define apply-unary-op (f x)
(if (= f 'car) (car x)
(if (= f 'cdr) (cdr x)
(if (= f 'number?) (number? x)
(if (= f 'list?) (list? x)
(if (= f 'symbol?) (symbol? x)
(if (= f 'null?) (null? x) 'error!)))))))
(eval '(car (quote (a b))) '())
'a
(eval '(cons 3 (cons (+ 4 5) (quote ()))) '())
'(3 9)
(define eval (exp rho fundefs)
(if (number? exp) exp
(if (symbol? exp) (assoc exp rho)
(if (= (car exp) 'quote) (cadr exp)
(if (= (car exp) 'if)
(if (null? (eval (cadr exp) rho fundefs))
(eval (cadddr exp) rho fundefs)
(eval (caddr exp) rho fundefs))
(if (userfun? (car exp) fundefs)
(apply-userfun (assoc (car exp) fundefs)
(evallist (cdr exp) rho fundefs)
fundefs)
(if (= (length exp) 2)
(apply-unary-op (car exp)
(eval (cadr exp) rho fundefs))
(apply-binary-op (car exp)
(eval (cadr exp) rho fundefs)
(eval (caddr exp) rho fundefs))))))))))
(define userfun? (f fundefs) (assoc f fundefs))
(define apply-userfun (fundef args fundefs)
(eval (cadr fundef) ; body of function
(mkassoc* (car fundef) args '()) ; local env
fundefs))
(define evallist (el rho fundefs)
(if (null? el) '()
(cons (eval (car el) rho fundefs)
(evallist (cdr el) rho fundefs))))
(define mkassoc* (keys values al)
(if (null? keys) al
(mkassoc* (cdr keys) (cdr values)
(mkassoc (car keys) (car values) al))))
(set E (mkassoc 'double '((a) (+ a a)) '()))
'((double ((a) (+ a a))))
(eval '(double (car (quote (4 5)))) '() E)
8
(set E (mkassoc 'exp
'((m n) (if (= n 0) 1 (* m (exp m (- n 1)))))
'()))
'((exp ((m n) (if (= n 0) 1 (* m (exp m (- n 1)))))))
(eval '(exp 4 3) '() E)
64
(define r-e-p-loop (inputs) (r-e-p-loop* inputs '()))
(define r-e-p-loop* (inputs fundefs)
(if (null? inputs) '() ; session done
(if (atom? (car inputs)) ; input is variable or number
(process-exp (car inputs) (cdr inputs) fundefs)
(if (= (caar inputs) 'define) ; input is function definition
(process-def (car inputs) (cdr inputs) fundefs)
(process-exp (car inputs) (cdr inputs) fundefs)))))
(define process-def (e inputs fundefs)
(cons (cadr e) ; echo function name
(r-e-p-loop* inputs
(mkassoc (cadr e) (cddr e) fundefs))))
(define process-exp (e inputs fundefs)
(cons (eval e '() fundefs) ; print value of expression
(r-e-p-loop* inputs fundefs)))
(r-e-p-loop '(
(define double (a) (+ a a))
(double (car (quote (4 5))))
(define exp (m n) (if (= n 0) 1 (* m (exp m (- n 1)))))
(exp 4 3)
))
'(double 8 exp 64)
quit