home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 500-599 / ff524.lzh / Kamin / src.lzh / code.lsp < prev    next >
Text File  |  1991-06-28  |  18KB  |  503 lines
  1. ; From chapter 1
  2. (define mod (m n) (- m (* n (/ m n))))
  3. (define +1 (x) (+ x 1))
  4. ; Section 2.1.3
  5. (cons 'a '())
  6. '(a)
  7. (cons 'a '(b))
  8. '(a b)
  9. (cons '(a) '(b))
  10. '((a) b)
  11. (cdr '(a (b (c d))))
  12. '((b (c d)))
  13. (null? '())
  14. 'T
  15. (null? '(()))
  16. '()
  17. (define length (l) (if (null? l) 0 (+1 (length (cdr l)))))
  18. (define caar (l) (car (car l)))
  19. (define cadr (l) (car (cdr l)))
  20. (define cddr (l) (cdr (cdr l)))
  21. (define caddr (l) (car (cdr (cdr l))))
  22. (define cadar (l) (car (cdr (car l))))
  23. (define cadddr (exp) (car (cdr (cdr (cdr exp)))))
  24. (define list1 (x) (cons x '()))
  25. (define list2 (x y) (cons x (cons y '())))
  26. (define list3 (x y z) (cons x (cons y (cons z '()))))
  27. (list2 (list1 'a) 'b)
  28. '((a) b)
  29. (define or (x y) (if x x y))
  30. (define atom? (x) (or (null? x) (or (number? x) (symbol? x))))
  31. (define equal (l1 l2)
  32.       (if (atom? l1) (= l1 l2)
  33.           (if (atom? l2) '()
  34.               (if (equal (car l1) (car l2))
  35.                    (equal (cdr l1) (cdr l2))
  36.                    '()))))
  37. (equal 'a 'b)
  38. '()
  39. (equal '(a (1 3) c) '(a (1 3) c))
  40. 'T
  41. (equal '(a (1 3) d) '(a (1 3) c))
  42. '()
  43. (define and (x y) (if x y x)).
  44. (define not (x) (if x '() 'T)).
  45. (define divides (m n) (= (mod n m) 0))
  46. (define  interval-list (m n)
  47.      (if (> m n) '() (cons m (interval-list (+1 m) n))))
  48. (interval-list 3 7)
  49. '(3 4 5 6 7)
  50. (define remove-multiples (n l)
  51.        (if (null? l) '()
  52.        (if  (divides n (car l))
  53.                           (remove-multiples n (cdr l))
  54.              (cons (car l) (remove-multiples n (cdr l))))))
  55. (remove-multiples 2 '(2 3 4 5 6 7))
  56. '(3 5 7)
  57. (define sieve (l)
  58.      (if (null? l) '()
  59.           (cons (car l) (sieve (remove-multiples (car l) (cdr l))))))
  60. (define primes<= (n) (sieve (interval-list 2 n)))
  61. (primes<= 10)
  62. '(2 3 5 7)
  63. (define insert (x l)
  64.      (if (null? l) (list1 x)
  65.       (if (< x (car l))  (cons x l)
  66.          (cons (car l)(insert x (cdr l))))))
  67. (define insertion-sort (l)
  68.    (if (null? l) '()
  69.     (insert (car l) (insertion-sort (cdr l)))))
  70. (insertion-sort '(4 3 2 6 8 5))
  71. '(2 3 4 5 6 8)
  72.  (define assoc (x alist) 
  73.      (if (null? alist) '()
  74.          (if  (= x (caar alist)) (cadar alist)
  75.              (assoc x (cdr alist)))))
  76. (assoc 'U '((E coli)(I Ching)(U Thant)))
  77. 'Thant
  78. (define mkassoc (x y alist)
  79.      (if (null? alist)
  80.           (list1 (list2 x y))
  81.          (if  (= x (caar alist)) (cons (list2 x y) (cdr alist))
  82.            (cons (car alist) (mkassoc x y (cdr alist))))))
  83. (set al (mkassoc 'I 'Ching '()))
  84. '((I Ching))
  85. (set al (mkassoc 'E 'coli al))
  86. '((I Ching)(E Coli))
  87. (set al (mkassoc 'I 'Magnin al))
  88. '((I Magnin)(E coli))
  89. (assoc 'I al)
  90. 'Magnin
  91. (set fruits '((apple ((texture crunchy)))(banana ((color yellow)))))
  92. (define getprop (x p plist)
  93.      ; find property p of individual x in plist
  94.      (assoc p (assoc x plist)))
  95. (getprop 'apple 'texture fruits)
  96. 'crunchy
  97. (define putprop (x p y plist)
  98.      ; give individual x value y for property p
  99.         (mkassoc x (mkassoc p y (assoc x plist)) plist))
  100. (set fruits (putprop 'apple 'color 'red fruits))
  101. '((apple ((texture crunchy)(color red)))(banana ((color yellow)))))
  102. (getprop 'apple 'color fruits)
  103. 'red
  104. (define hasprop? (p y alist) (= (assoc p alist) y))
  105.  (define  gatherprop (p y plist)
  106.      ; get all individuals having value y for property p
  107.         (if  (null? plist) '()
  108.               (if  (hasprop? p y (cadar plist))
  109.                     (cons (caar plist) (gatherprop p y (cdr plist)))
  110.                     (gatherprop p y (cdr plist)))))
  111. (set fruits (putprop 'lemon 'color 'yellow fruits))
  112. '((apple ((texture crunchy) ... (lemon ((color yellow))))))
  113. (gatherprop 'color 'yellow fruits)
  114. '(banana lemon)
  115. (set nullset '())
  116. '()
  117. (define addelt (x s)
  118.    (if (member? x s) s (cons x s)))
  119. (define member? (x s)
  120.      (if (null? s) '()
  121.          (if (equal x (car s)) 'T (member? x (cdr s)))))
  122. (define size (s) (length s))
  123. (define union (s1 s2)
  124.      (if (null? s1) s2
  125.          (if (member? (car s1) s2)
  126.                 (union (cdr s1) s2)
  127.              (cons (car s1) (union (cdr s1) s2)))))
  128. (set s (addelt 3 (addelt 'a nullset)))
  129. '(3 a)
  130. (member? 'a s)
  131. 'T
  132. (union s (addelt 2 (addelt 3 nullset)))
  133. '(a 2 3)
  134. (set t (addelt '(a b) (addelt 1 nullset)))
  135. '((a b) 1)
  136. (member? '(a b) t)
  137. 'T
  138. (define sum (l)
  139.    (if (null? l) 0
  140.      (if (number? l) l
  141.        (+ (sum (car l)) (sum (cdr l))))))
  142. (define wrong-sum (l)
  143.    (if (null? l) 0
  144.      (if (number? l) l
  145.        (begin
  146.          (set tmp (wrong-sum (car l)))
  147.          (+ (wrong-sum (cdr l)) tmp)))))
  148. (sum '(1 2 3 4))
  149. 10
  150. (wrong-sum '(1 2 3 4))
  151. 16
  152. (define right-sum (l) (right-sum-aux l 0))
  153. (define right-sum-aux (l tmp)
  154.     (if (null? l) 0
  155.        (if (number? l) l
  156.           (begin
  157.              (set tmp (right-sum (car l)))
  158.              (+ (right-sum (cdr l)) tmp)))))
  159. (right-sum '(1 2 3 4))
  160. 10
  161. (define pre-ord (tree)
  162.      (if (atom? tree) (print tree)
  163.          (begin
  164.              (print (car tree))
  165.              (pre-ord (cadr tree))
  166.              (pre-ord (caddr tree)))))
  167. (pre-ord '(A (B C D) (E (F G H) I)))
  168. '(output is A B C D E F G H I)
  169. ; Queue operations
  170. (set empty-queue '())
  171. (define front (q) (car q))
  172. (define rm-front (q) (cdr q))
  173. (define enqueue (t q)
  174.    (if (null? q) (list1 t) (cons (car q) (enqueue t (cdr q)))))
  175. (define empty? (q) (null? q))
  176. ; Level-order traversal
  177. (define level-ord (tree) (level-ord* (enqueue tree empty-queue)))
  178. (define level-ord* (node-q)
  179.    (if (empty? node-q) '()
  180.      (begin
  181.        (set this-node (front node-q))
  182.        (if (atom? this-node)
  183.                  (begin
  184.                       (print this-node)
  185.                       (level-ord* (rm-front node-q)))
  186.          (begin
  187.            (print (car this-node))
  188.            (level-ord*
  189.              (enqueue (caddr this-node)
  190.                (enqueue (cadr this-node) (rm-front node-q)))))))))
  191. (level-ord '(A (B C D) (E (F G H) I)))
  192. '(output is A B E C D E F I G H)
  193. ; Section 2.3
  194. (define inter (s1 s2)
  195.      (if (null? s1) s1
  196.           (if (member? (car s1) s2)
  197.                (cons (car s1) (inter (cdr s1) s2))
  198.                (inter (cdr s1) s2))))
  199. (define diff (s1 s2)
  200.      (if (null? s1) s1
  201.          (if (null? s2) s1
  202.               (if (member? (car s1) s2)
  203.                    (diff (cdr s1) s2)
  204.                    (cons (car s1) (diff (cdr s1) s2))))))
  205. (define UNION (r s)
  206.      (if (not (equal (car r) (car s)))
  207.           (print 'error)
  208.           (cons (car r) (union (cdr r) (cdr s)))))
  209. (define INTER (r s)
  210.      (if (not (equal (car r) (car s)))
  211.           (print 'error)
  212.           (cons (car r) (inter (cdr r) (cdr s)))))
  213. (define DIFF (r s)
  214.      (if (not (equal (car r) (car s)))
  215.           (print 'error)
  216.           (cons (car r) (diff (cdr r) (cdr s)))))
  217. (define SELECT (A v r)
  218.      (cons (car r) (include-rows v (col-num A (car r)) (cdr r))))
  219. (define col-num (A A-list)
  220.      (if (= A (car A-list)) 0
  221.           (+1 (col-num A (cdr A-list)))))
  222. (define include-rows (v n rows)
  223.      (if (null? rows) '()
  224.          (if (= v (nth n (car rows)))
  225.               (cons (car rows) (include-rows v n (cdr rows)))
  226.               (include-rows v n (cdr rows)))))
  227. (define nth (n l)
  228.      (if (= n 0) (car l) (nth (- n 1) (cdr l))))
  229. (define PROJECT (X r)
  230.      (cons X (include-cols* (col-num* X (car r)) (cdr r))))
  231. (define col-num* (X A-list)
  232.      (if (null? X) '()
  233.           (cons (col-num (car X) A-list) (col-num* (cdr X) A-list))))
  234. (define include-cols* (col-nums rows)
  235.      (if (null? rows) nullset
  236.           (addelt (include-cols col-nums (car rows))
  237.                     (include-cols* col-nums (cdr rows)))))
  238. (define include-cols (col-nums row)
  239.      (if (null? col-nums) '()
  240.           (cons (nth (car col-nums) row)
  241.                   (include-cols (cdr col-nums) row))))
  242. (define append (x y)
  243.     (if (null? x) y (cons (car x) (append (cdr x) y))))
  244. (define JOIN (r s)
  245.      (begin
  246.            (set intersection (inter (car r) (car s)))
  247.            (set r-intersection (col-num* intersection (car r)))
  248.            (set s-intersection (col-num* intersection (car s)))
  249.            (set r-diff-s (diff (car r) intersection))
  250.            (set r-diff-s-cols (col-num* r-diff-s (car r)))
  251.            (set s-diff-r (diff (car s) intersection))
  252.            (set s-diff-r-cols (col-num* s-diff-r (car s)))
  253.        (cons (append intersection (append r-diff-s s-diff-r))
  254.                (join-cols* r-intersection r-diff-s-cols s-intersection
  255.                        s-diff-r-cols (cdr r) (cdr s)))))
  256. (define join-cols* (X-r r-cols X-s s-cols r-rows s-rows)
  257.     (begin
  258.         (set new-rows '())
  259.         (while (not (null? r-rows))
  260.             (begin
  261.                 (set s-tmp s-rows)
  262.                 (while (not (null? s-tmp))
  263.                     (begin
  264.                         (if (equal (include-cols X-r (car r-rows))
  265.                                  (include-cols X-s (car s-tmp)))
  266.                              (set new-rows (cons (join-cols X-r r-cols s-cols
  267.                              (car r-rows) (car s-tmp))
  268.                                   new-rows))
  269.                              '())
  270.                         (set s-tmp (cdr s-tmp))))
  271.                  (set r-rows (cdr r-rows))))
  272.          new-rows))
  273. (define join-cols (X-r r-cols s-cols r-row s-row)
  274.     (append (include-cols X-r r-row)
  275.          (append (include-cols r-cols r-row)
  276.                 (include-cols s-cols s-row))))
  277. (set CRIMES
  278.        '((Victim Crime Criminal Location)
  279.            (Phelps robbery Harrison London)
  280.            (Drebber murder Hope London)
  281.            (Sir-Charles murder Stapleton Devonshire)
  282.            (Lady-Eva blackmail Milverton London)
  283.            (Brunton murder Howells West-Sussex)))
  284. (set MURDERS
  285.        '((Victim Weapon Motive)
  286.            (Drebber  poison  revenge)
  287.            (Sir-Charles  hound  greed)
  288.            (Brunton  burial-alive  passion)))
  289. (JOIN MURDERS
  290.           (PROJECT '(Victim Criminal)
  291.                 (SELECT 'Location 'London
  292.                      (SELECT 'Crime 'murder CRIMES))))
  293. '((Victim Weapon Motive Criminal) (Drebber poison revenge Hope))
  294. ; Section 2.4
  295. (define eval (exp)
  296.         (if  (number? exp) exp
  297.                 (apply-op
  298.                   (car exp)
  299.                         (eval (cadr exp))
  300.                         (eval (caddr exp)))))
  301. (define apply-op (f x y)
  302.         (if (= f '+) (+ x y)
  303.         (if (= f '-) (- x y)
  304.         (if (= f '*) (* x y)
  305.         (if (= f '/) (/ x y) 'error!)))))
  306. (eval '(+ 3 (* 4 5)))
  307. 23
  308. (eval '(+ 3 4))
  309. 7
  310. (eval '(+ (* 4 (/ 10 2)) (- 7 3)))
  311. 24
  312.  (define eval (exp rho)
  313.         (if  (number? exp) exp
  314.           (if  (symbol? exp) (assoc exp rho)
  315.                 (apply-op  
  316.                       (car exp)
  317.                       (eval (cadr exp) rho)
  318.                       (eval (caddr exp) rho)))))
  319. (eval '(+ i (/ 9 i)) (mkassoc 'i 3 '()))
  320. 6
  321. (define eval (exp rho)
  322.         (if (number? exp) exp
  323.         (if (symbol? exp) (assoc exp rho)
  324.         (if (= (car exp) 'quote) (cadr exp)
  325.         (if  (= (length exp) 2)
  326.           (apply-unary-op (car exp) (eval (cadr exp) rho))
  327.           (apply-binary-op  (car exp)
  328.               (eval (cadr exp) rho)
  329.               (eval (caddr exp) rho))
  330.         )))))
  331. (define apply-binary-op (f x y)
  332.       (if (= f 'cons) (cons x y)
  333.       (if (= f '+) (+ x y)
  334.       (if (= f '-) (- x y)
  335.       (if (= f '*) (* x y)
  336.       (if (= f '/) (/ x y)
  337.       (if (= f '<) (< x y)
  338.       (if (= f '>) (> x y)
  339.       (if (= f '=) (= x y) 'error!)))))))))
  340. (define apply-unary-op (f x)
  341.       (if (= f 'car) (car x)
  342.       (if (= f 'cdr) (cdr x)
  343.       (if (= f 'number?) (number? x)
  344.       (if (= f 'list?) (list? x)
  345.       (if (= f 'symbol?) (symbol? x)
  346.       (if (= f 'null?) (null? x) 'error!)))))))
  347. (eval '(car (quote (a b))) '())
  348. 'a 
  349. (eval '(cons 3 (cons (+ 4 5) (quote ()))) '())
  350. '(3 9) 
  351. (define eval (exp rho fundefs)
  352.           (if (number? exp) exp
  353.           (if (symbol? exp) (assoc exp rho)
  354.           (if (= (car exp) 'quote) (cadr exp)
  355.           (if  (= (car exp) 'if)
  356.                   (if  (null? (eval (cadr exp) rho fundefs))
  357.                           (eval (cadddr exp) rho fundefs)
  358.                           (eval (caddr exp) rho fundefs))
  359.           (if (userfun? (car exp) fundefs)
  360.                (apply-userfun (assoc (car exp) fundefs)
  361.                                 (evallist (cdr exp) rho fundefs)
  362.                                 fundefs)
  363.              (if (= (length exp) 2)
  364.                      (apply-unary-op  (car exp)
  365.                              (eval (cadr exp) rho fundefs))
  366.                      (apply-binary-op (car exp)
  367.                                (eval (cadr exp) rho fundefs)
  368.                                     (eval (caddr exp) rho fundefs))))))))))
  369. (define userfun? (f fundefs) (assoc f fundefs))
  370. (define apply-userfun (fundef args fundefs)
  371.           (eval (cadr fundef) ; body of function
  372.                   (mkassoc* (car fundef) args '()) ; local env
  373.                   fundefs))
  374. (define evallist (el rho fundefs)
  375.      (if (null? el) '()
  376.           (cons (eval (car el) rho fundefs)
  377.                   (evallist (cdr el) rho fundefs))))
  378. (define mkassoc* (keys values al)
  379.      (if (null? keys) al
  380.           (mkassoc* (cdr keys) (cdr values)
  381.                   (mkassoc (car keys) (car values) al))))
  382. (set E (mkassoc 'double '((a) (+ a a)) '()))
  383. '((double ((a) (+ a a))))
  384. (eval '(double (car (quote (4 5)))) '() E)
  385. 8
  386. (set E (mkassoc  'exp
  387.                '((m n) (if (= n 0) 1 (* m (exp m (- n 1)))))
  388.                '()))
  389. '((exp ((m n) (if (= n 0) 1 (* m (exp m (- n 1)))))))
  390. (eval '(exp 4 3) '() E)
  391. 64
  392. (define r-e-p-loop (inputs) (r-e-p-loop* inputs '()))
  393. (define r-e-p-loop* (inputs fundefs)
  394.     (if (null? inputs) '() ; session done
  395.          (if (atom? (car inputs)) ; input is variable or number
  396.               (process-exp (car inputs) (cdr inputs) fundefs)
  397.               (if (= (caar inputs) 'define) ; input is function definition
  398.                    (process-def (car inputs) (cdr inputs) fundefs)
  399.                    (process-exp (car inputs) (cdr inputs) fundefs)))))
  400. (define process-def (e inputs fundefs)
  401.        (cons (cadr e) ; echo function name
  402.                (r-e-p-loop* inputs
  403.                     (mkassoc (cadr e) (cddr e) fundefs))))
  404. (define process-exp (e inputs fundefs)
  405.        (cons (eval e '() fundefs) ; print value of expression
  406.                (r-e-p-loop* inputs fundefs)))
  407. (r-e-p-loop '(
  408.       (define double (a) (+ a a))
  409.       (double (car (quote (4 5))))
  410.       (define exp (m n) (if (= n 0) 1 (* m (exp m (- n 1)))))
  411.       (exp 4 3)
  412.       ))
  413. '(double 8 exp 64)
  414. quit
  415. (r-e-p-loop '(
  416.   (define cadr (exp) (car (cdr exp)))
  417.   (define cddr (exp) (cdr (cdr exp)))
  418.   (define caar (exp) (car (car exp)))
  419.   (define caddr (exp) (car (cdr (cdr exp))))
  420.   (define cadddr (exp) (car (cdr (cdr (cdr exp)))))
  421.   (define cadar (exp) (car (cdr (car exp))))
  422.   (define list2 (x y) (cons x (cons y (quote ()))))
  423.   (define +1 (x) (+ x 1))
  424.   (define length (l) (if (null? l) 0 (+1 (length (cdr l)))))
  425.   (define  assoc (x alist) 
  426.        (if (null? alist) (quote ())
  427.            (if  (= x (caar alist)) (cadar alist)
  428.                (assoc x (cdr alist)))))
  429.   (define mkassoc (x y alist)
  430.        (if (null? alist)
  431.             (cons (list2 x y) (quote ()))
  432.            (if  (= x (caar alist)) (cons (list2 x y) (cdr alist))
  433.              (cons (car alist) (mkassoc x y (cdr alist))))))
  434.   (define mkassoc* (keys values al)
  435.      (if (null? keys) al
  436.         (mkassoc* (cdr keys) (cdr values)
  437.             (mkassoc (car keys) (car values) al))))
  438.   (define  eval (exp rho fundefs)
  439.           (if (number? exp) exp
  440.           (if (symbol? exp) (assoc exp rho)
  441.           (if (= (car exp) (quote quote)) (cadr exp)
  442.           (if  (= (car exp) (quote if))
  443.                 (if  (null? (eval (cadr exp) rho fundefs))
  444.                       (eval (cadddr exp) rho fundefs)
  445.                       (eval (caddr exp) rho fundefs))
  446.           (if (userfun? (car exp) fundefs)
  447.              (apply-userfun (assoc (car exp) fundefs)
  448.                             (evallist (cdr exp) rho fundefs)
  449.                             fundefs)
  450.              (if (= (length exp) 2)
  451.                    (apply-unary-op  (car exp)
  452.                          (eval (cadr exp) rho fundefs) fundefs)
  453.                    (apply-binary-op (car exp)
  454.                            (eval (cadr exp) rho fundefs)
  455.                                    (eval (caddr exp) rho fundefs)))))))))
  456.   (define apply-unary-op (f x fundefs)
  457.         (if (= f (quote car)) (car x)
  458.         (if (= f (quote cdr)) (cdr x)
  459.         (if (= f (quote number?)) (number? x)
  460.         (if (= f (quote list?)) (list? x)
  461.         (if (= f (quote symbol?)) (symbol? x)
  462.         (if (= f (quote null?)) (null? x) (quote error!))))))))
  463.   (define apply-binary-op (f x y)
  464.         (if (= f (quote cons)) (cons x y)
  465.         (if (= f (quote +)) (+ x y)
  466.         (if (= f (quote -)) (- x y)
  467.         (if (= f (quote *)) (* x y)
  468.         (if (= f (quote /)) (/ x y)
  469.         (if (= f (quote <)) (< x y)
  470.         (if (= f (quote >)) (> x y)
  471.         (if (= f (quote =)) (= x y) (quote error!))))))))))
  472.   (define userfun? (f fundefs) (assoc f fundefs))
  473.   (define apply-userfun (fundef args fundefs)
  474.           (eval (cadr fundef) ; body of function
  475.                 (mkassoc* (car fundef) args (quote ())) ; local env
  476.                 fundefs))
  477.   (define evallist (el rho fundefs)
  478.      (if (null? el) (quote ())
  479.         (cons (eval (car el) rho fundefs)
  480.               (evallist (cdr el) rho fundefs))))
  481.   (define r-e-p-loop (inputs) (r-e-p-loop* inputs (quote ())))
  482.   (define r-e-p-loop* (inputs fundefs)
  483.     (if (null? inputs) (quote ())
  484.        (if (list? (car inputs))
  485.           (if (= (caar inputs) (quote define))
  486.              (process-def (car inputs) (cdr inputs) fundefs)
  487.              (process-exp (car inputs) (cdr inputs) fundefs))
  488.           (process-exp (car inputs) (cdr inputs) fundefs))))
  489.   (define process-def (e inputs fundefs)
  490.        (cons (cadr e)
  491.              (r-e-p-loop* inputs
  492.                 (mkassoc (cadr e) (cddr e) fundefs))))
  493.   (define process-exp (e inputs fundefs)
  494.        (cons (eval e (quote ()) fundefs)
  495.              (r-e-p-loop* inputs fundefs)))
  496.   (r-e-p-loop (quote (
  497.     (define double (a) (+ a a))
  498.     (double (car (quote (4 5))))
  499.     )))
  500. ))
  501. '(cadr cddr caar caddr cadddr cadar list2 +1 length assoc mkassoc mkassoc* eval apply-unary-op apply-binary-op userfun? apply-userfun evallist r-e-p-loop r-e-p-loop* process-def process-exp (double 8))
  502. quit
  503.