home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 549b.lha / Kamin / src.LZH / source / code.sch < prev    next >
Encoding:
Text File  |  1991-06-28  |  14.0 KB  |  418 lines
  1. ; From Chapter 1 and Lisp
  2. (set +1 (lambda (x) (+ x 1)))
  3. (set list2 (lambda (x y) (cons x (cons y '()))))
  4. (set list3 (lambda (x y z) (cons x (cons y (cons z '())))))
  5. (set nth (lambda (n l)
  6.    (if (= n 0) (car l) (nth (- n 1) (cdr l)))))
  7. (set cadr (lambda (x) (car (cdr x))))
  8. (set caddr (lambda (x) (car (cdr (cdr x)))))
  9. (set atom? (lambda (x) (or (null? x) (or (number? x) (symbol? x)))))
  10. (set equal (lambda (l1 l2)
  11.   (if (atom? l1) (= l1 l2)
  12.     (if (atom? l2) '()
  13.       (if (equal (car l1) (car l2))
  14.          (equal (cdr l1) (cdr l2))
  15.          '())))))
  16. (set or (lambda (x y) (if x x y)))
  17. (set not (lambda (x) (if x '() 'T)))
  18. (set cadar (lambda (l) (car (cdr (car l)))))
  19. (set caar (lambda (l) (car (car l))))
  20. (set assoc (lambda (x alist) 
  21.      (if (null? alist) '()
  22.          (if  (= x (caar alist)) (cadar alist)
  23.              (assoc x (cdr alist))))))
  24. (set mod (lambda (m n) (- m (* n (/ m n)))))
  25. (set gcd (lambda (m n)
  26.   (if (= n 0) m (gcd n (mod m n)))))
  27. (set mkassoc (lambda (x y alist)
  28.      (if (null? alist)
  29.           (cons (list2 x y) '())
  30.          (if  (= x (caar alist)) (cons (list2 x y) (cdr alist))
  31.            (cons (car alist) (mkassoc x y (cdr alist)))))))
  32. (set mkassoc* (lambda (keys values al)
  33.    (if (null? keys) al
  34.       (mkassoc* (cdr keys) (cdr values)
  35.             (mkassoc (car keys) (car values) al)))))
  36. (set length (lambda (l) (if (null? l) 0 (+1 (length (cdr l))))))
  37. ; Section 4.1
  38. (set sort2 (lambda (x y comp)
  39.      (if (comp x y) (list2 x y) (list2 y x))))
  40. (sort2 7 5 <)
  41. '(5 7)
  42. (set compare-pairs (lambda (p1 p2)
  43.      (if (< (car p1) (car p2)) 'T
  44.        (if (< (car p2) (car p1)) '()
  45.          (< (cadr p1) (cadr p2))))))
  46. (sort2 '(4 5) '(2 9) compare-pairs)
  47. '((2 9)(4 5))
  48. (set add (lambda (x) (lambda (y) (+ x y))))
  49. (set add1 (add 1))
  50. (add1 4)
  51. 5
  52. ; Section 4.2.4
  53. (set mapcar (lambda (f l)
  54.      (if (null? l) '()
  55.        (cons (f (car l)) (mapcar f (cdr l))))))
  56. (mapcar number? '(3 a b (5 6)))
  57. '(T () () ())
  58. (mapcar add1 '(3 4 5))
  59. '(4 5 6)
  60. (set add1* (lambda (l) (mapcar add1 l)))
  61. (add1* '(3 4 5))
  62. '(4 5 6)
  63. (set curry (lambda (f) (lambda (x) (lambda (y) (f x y)))))
  64. (((curry +) 3) 4)
  65. 7
  66. (set mapc (curry mapcar))
  67. (set add1* (mapc add1))
  68. (add1* '(3 4 5))
  69. '(4 5 6)
  70. (set add1** (mapc add1*))
  71. (add1** '((2 3)(4 5)))
  72. '((3 4)(5 6))
  73. (set combine (lambda (f sum zero)
  74.      (lambda (l) (if (null? l) zero
  75.        (sum (f (car l)) ((combine f sum zero) (cdr l)))))))
  76. (set sum-squares (combine (lambda (x) (* x x)) + 0))
  77. (sum-squares '(1 2 3 4))
  78. 30
  79. (set id (lambda (x) x))
  80. (set +/ (combine id + 0))
  81. (+/ '(1 2 3 4))
  82. 10
  83. (set */ (combine id * 1))
  84. (*/ '(1 2 3 4))
  85. 24
  86. (set list-id (combine id cons '()))
  87. (list-id '(3 4 5))
  88. '(3 4 5)
  89. (set alternate-mapc (lambda (f) (combine f cons '())))
  90. (set cmp-pairs-of-pairs (lambda (t1 t2)
  91.      (if (compare-pairs (car t1) (car t2)) 'T
  92.        (if (compare-pairs (car t2) (car t1)) '()
  93.          (compare-pairs (cadr t1) (cadr t2))))))
  94. (set lex-order (lambda (<1 <2)
  95.          (lambda (p1 p2)
  96.              (if (<1 (car p1) (car p2)) 'T
  97.                  (if (<1 (car p2) (car p1)) '()
  98.                      (<2 (cadr p1) (cadr p2)))))))
  99. (set compare-pairs (lex-order < <))
  100. (set cmp-pairs-of-pairs
  101.    (lex-order compare-pairs compare-pairs))
  102. (set student-order (lex-order > <))
  103. (sort2 '(85 1005) '(95 2170) student-order)
  104. '((95 2170) (85 1005))
  105. (sort2 '(85 1005) '(85 2170) student-order)
  106. '((85 1005) (85 2170))
  107. (set invert-order (lambda (<) (lambda (x y) (< y x))))
  108. (sort2 '(85 1005) '(95 2170) (invert-order student-order))
  109. '((85 1005) (95 2170))
  110. (set select-cols (lambda (c1 c2)
  111.    (lambda (l) (list2 (nth c1 l) (nth c2 l)))))
  112. (set compose-binary
  113.    (lambda (f g) (lambda (x y) (g (f x) (f y)))))
  114. (set compare-cols (lambda (< c1 c2)
  115.         (compose-binary (select-cols c1 c2) <)))
  116. (set new-student-order (compare-cols student-order 2 1))
  117. (sort2 '(Kaplan 1005 85 87) '(Reddy 2170 95 92)
  118.        new-student-order)
  119. '((Reddy 2170 95 92) (Kaplan 1005 85 87))
  120. (set compose (lambda (f g) (lambda (x) (g (f x)))))
  121. (set apply-binary (lambda (f)
  122.    (lambda (l) (f (car l) (cadr l)))))
  123. (set improvement
  124.    (compose (select-cols 3 2)
  125.             (apply-binary -)))
  126. (set comp-improvement (compose-binary improvement >))
  127. (sort2 '(Kaplan 1005 85 87) '(Reddy 2170 95 92)
  128.        comp-improvement)
  129. '((Kaplan 1005 85 87) (Reddy 2170 95 92))
  130. (set find (lambda (pred lis)
  131.    (if (null? lis) '()
  132.           (if (pred (car lis)) 'T (find pred (cdr lis))))))
  133. (set nullset '())
  134. (set addelt (lambda (x s) (if (member? x s) s (cons x s))))
  135. (set member? (lambda (x s) (find ((curry equal) x) s)))
  136. (set union (lambda (s1 s2) ((combine id addelt s1) s2)))
  137. (set s1 (addelt 'a (addelt 'b nullset)))
  138. '(a b)
  139. (member? 'a s1)
  140. 'T
  141. (member? 'c s1)
  142. '()
  143. (set s2 (addelt 'b (addelt 'c nullset)))
  144. '(b c)
  145. (set s3 (union s1 s2))
  146. '(c a b)
  147. (set sub-alist (lambda (al1 al2)
  148.      (not (find
  149.              (lambda (pair)
  150.                  (not (equal (cadr pair) (assoc (car pair) al2))))
  151.              al1))))
  152. (set =alist (lambda (al1 al2)
  153.      (if (sub-alist al1 al2) (sub-alist al2 al1) '())))
  154. (=alist '((E coli)(I Magnin)(U Thant))
  155.         '((E coli)(I Ching)(U Thant)))
  156. '()
  157. (=alist '((U Thant)(I Ching)(E coli))
  158.         '((E coli)(I Ching)(U Thant)))
  159. 'T
  160. (set member? (lambda (x s eqfun)
  161.      (find ((curry eqfun) x) s)))
  162. (set addelt (lambda (x s eqfun)
  163.    (if (member? x s eqfun) s (cons x s))))
  164. (set nullset (lambda (eqfun) (list2 eqfun '())))
  165. (set member? (lambda (x s)
  166.      (find ((curry (car s)) x) (cadr s))))
  167. (set addelt (lambda (x s)
  168.    (if (member? x s) s (list2 (car s) (cons x (cadr s))))))
  169. (set mk-set-ops (lambda (eqfun)
  170.    (cons '()  ; empty set
  171.    (cons (lambda (x s) (find ((curry eqfun) x) s)) ; member?
  172.    (cons (lambda (x s) ; addelt
  173.              (if (find ((curry eqfun) x) s) s (cons x s)))
  174.           '()
  175.        )))))
  176. (set list-of-al-ops (mk-set-ops =alist))
  177. (set al-nullset (car list-of-al-ops))
  178. (set al-member? (cadr list-of-al-ops))
  179. (set al-addelt (caddr list-of-al-ops))
  180. (set gcd* (lambda (l)
  181.     (if (= (car l) 1) 1
  182.          (if (null? (cdr l)) (car l)
  183.               (gcd (car l) (gcd* (cdr l)))))))
  184. (gcd* '(20 48 32 1))
  185. 1
  186. (set gcd* (lambda (l)
  187.      (if (= (car l) 1) 1
  188.           (gcd*-aux (car l) (cdr l)))))
  189. (set gcd*-aux (lambda (n l)
  190.      (if (null? l) n
  191.           (if (= (car l) 1) 1
  192.                (gcd*-aux (gcd n (car l)) (cdr l))))))
  193. (gcd* '(20 48 32 1))
  194. 1
  195. (set gcd* (lambda (l) (gcd*-aux l id)))
  196. (set gcd*-aux (lambda (l f)
  197.      (if (= (car l) 1) 1
  198.           (if (null? (cdr l)) (f (car l))
  199.                (gcd*-aux (cdr l)
  200.                            (lambda (n) (f (gcd (car l) n))))))))
  201. (gcd* '(20 48 32 1))
  202. 1
  203. (set gcds (lambda (s) (gcds-aux s id)))
  204. (set gcds-aux (lambda (s f)
  205.      (if (number? s) (if (= s 1) 1 (f s))
  206.           (if (null? (cdr s))
  207.                (gcds-aux (car s) f)
  208.                (gcds-aux (car s)
  209.                            (lambda (n) (gcds-aux (cdr s)
  210.                                           (lambda (p) (f (gcd n p))))))))))
  211. (gcds '(20 (48 32) (1)))
  212. 1
  213. (set rand (lambda (seed) ($\cdots$ seed $\cdots$)))
  214. (set init-rand (lambda (seed)
  215.      (lambda () (set seed (mod (+ (* seed 9) 5) 1024)))))
  216. (set rand (init-rand 1))
  217. '<closure>
  218. (rand)
  219. 14
  220. (rand)
  221. 131
  222. ; Section 4.4
  223. ; Restore required defn. of member?
  224. (set find (lambda (pred lis)
  225.      (if (null? lis) '()
  226.           (if (pred (car lis)) 'T
  227.                (find pred (cdr lis))))))
  228. (set member? (lambda (x s) (find ((curry equal) x) s)))
  229. ;
  230. (set fun-mod (lambda (f x y) (lambda (z) (if (= x z) y (f z)))))
  231. (set variable? (lambda (x) (member? x '(X Y))))
  232. (set empty-subst (lambda (x) 'unbound))
  233. (set mk-subst-fn
  234.     (lambda (lhs e sigma)
  235.          (if (variable? lhs)
  236.              (if (= (sigma lhs) 'unbound)
  237.                  (fun-mod sigma lhs e)
  238.                  (if (equal (sigma lhs) e) sigma 'nomatch))
  239.            (if (atom? lhs)
  240.                (if (= lhs e) sigma 'nomatch)
  241.              (if (atom? e) 'nomatch
  242.                  (if (= (car lhs) (car e))
  243.                      (mk-subst-fn* (cdr lhs) (cdr e) sigma)
  244.                      'nomatch))))))
  245. (set mk-subst-fn*   
  246.      (lambda (lhs-lis exp-lis sigma)
  247.          (if (null? lhs-lis) sigma
  248.              (begin
  249.                 (set car-match
  250.                        (mk-subst-fn (car lhs-lis) (car exp-lis) sigma))
  251.                 (if (= car-match 'nomatch) 'nomatch
  252.                    (mk-subst-fn* (cdr lhs-lis) (cdr exp-lis) car-match))))))
  253. (set extend-to-pat  
  254.      (lambda (sigma)
  255.          (lambda (p)
  256.              (if (variable? p) (if (= (sigma p) 'unbound) p (sigma p))
  257.                  (if (atom? p) p
  258.                      (cons (car p)
  259.                            (mapcar (extend-to-pat sigma) (cdr p))))))))
  260. (set mk-toplvl-rw-fn
  261.     (lambda (rule)
  262.         (lambda (e)
  263.              (begin
  264.           (set induced-subst (mk-subst-fn (car rule) e empty-subst))
  265.                       (if (= induced-subst 'nomatch) '()
  266.                           ((extend-to-pat induced-subst) (cadr rule)))))))
  267. (set apply-inside-exp  
  268.      (lambda (f)
  269.          (lambda (e)
  270.                (begin
  271.                      (set newe (f e))
  272.                      (if newe newe
  273.                           (if (atom? e) '()
  274.                                (begin
  275.                           (set newargs ((apply-inside-exp* f) (cdr e)))
  276.                          (if newargs (cons (car e) newargs) '()))))))))
  277. (set apply-inside-exp*  
  278.        (lambda (f)
  279.            (lambda (l)
  280.                (if (null? l) '()
  281.                     (begin
  282.                         (set newfirstarg ((apply-inside-exp f) (car l)))
  283.                         (if newfirstarg
  284.                              (cons newfirstarg (cdr l))
  285.                              (begin
  286.                       (set newrestofargs ((apply-inside-exp* f) (cdr l)))
  287.                   (if newrestofargs
  288.                       (cons (car l) newrestofargs) '()))))))))
  289. (set mk-rw-fn 
  290.       (compose mk-toplvl-rw-fn apply-inside-exp))
  291. (set failure (lambda (e) '()))
  292. (set compose-rewrites (lambda (f g)
  293.       (lambda (x)
  294.            ( (lambda (fx) (if fx fx (g x))) (f x)))))
  295. (set mk-rw-fn*
  296.      (combine mk-rw-fn compose-rewrites failure))
  297. (set repeat-fn
  298.     (lambda (f)
  299.         (lambda (e)
  300.              (begin
  301.                   (set tmp (f e))
  302.                   (if tmp ((repeat-fn f) tmp) e)))))
  303. (set compile-trs
  304.      (compose mk-rw-fn* repeat-fn))
  305. (set diff-rules '(
  306.       ((Dx x) 1)
  307.          ((Dx c) 0)
  308.          ((Dx (+ X Y)) (+ (Dx X) (Dx Y)))
  309.          ((Dx (- X Y)) (- (Dx X) (Dx Y)))
  310.          ((Dx (* X Y)) (+ (* Y (Dx X)) (* X (Dx Y))))
  311.          ((Dx (/ X Y)) (/ (- (* Y (Dx X)) (* X (Dx Y))) (* Y Y)))))
  312. (set differentiate (compile-trs diff-rules))
  313. ;(differentiate '(Dx (+ x c)))
  314. ;'(+ 1 0)
  315. ; Section 4.5
  316. (set formals (lambda (lamexp) (cadr lamexp)))
  317. (set body (lambda (lamexp) (caddr lamexp)))
  318. (set funpart (lambda (clo) (cadr clo)))
  319. (set envpart (lambda (clo) (caddr clo)))
  320. (set eval (lambda (exp env)
  321.           (if (number? exp) exp
  322.           (if (symbol? exp) (assoc exp env)
  323.           (if (= (car exp) 'quote) (cadr exp)
  324.           (if  (= (car exp) 'lambda) (list3 'closure exp env)
  325.           (if  (= (car exp) 'if)
  326.                   (if  (null? (eval (cadr exp) env))
  327.                           (eval (cadddr exp) env)
  328.                           (eval (caddr exp) env))
  329.             (apply (evallist exp env) env))))))))
  330. (set evallist (lambda (el env)
  331.      (if (null? el) '()
  332.           (cons (eval (car el) env)
  333.                   (evallist (cdr el) env)))))
  334. (set apply (lambda (el env)
  335.           (if (closure? (car el))
  336.                (apply-closure (car el) (cdr el))
  337.                (apply-value-op (car el) (cdr el)))))
  338. (set apply-closure (lambda (clo args)
  339.           (eval (body (funpart clo))
  340.                   (mkassoc* (formals (funpart clo)) args (envpart clo)))))
  341. (set apply-value-op (lambda (primop args)
  342.           (if (= (length args) 1)
  343.                (apply-unary-op  (cadr primop) (car args))
  344.                (apply-binary-op (cadr primop) (car args) (cadr args)))))
  345. (set closure? (lambda (f) (= (car f) 'closure)))
  346. (set primop? (lambda (f) (= (car f) 'primop)))
  347. (set valueops '(
  348.       (+ (primop +))
  349.       (- (primop -))
  350.       (cons (primop cons))
  351.       (* (primop *))
  352.       (/ (primop /))
  353.       (< (primop <))
  354.       (> (primop >))
  355.       (= (primop =))
  356.       (cdr (primop cdr))
  357.       (car (primop car))
  358.       (number? (primop number?))
  359.       (list? (primop list?))
  360.       (symbol? (primop symbol?))
  361.       (null? (primop null?))
  362.       (closure? (primop closure?))
  363.       (primop? (primop primop?))))
  364. (set apply-binary-op (lambda (f x y)
  365.       (if (= f 'cons) (cons x y)
  366.       (if (= f '+) (+ x y)
  367.       (if (= f '-) (- x y)
  368.       (if (= f '*) (* x y)
  369.       (if (= f '/) (/ x y)
  370.       (if (= f '<) (< x y)
  371.       (if (= f '>) (> x y)
  372.       (if (= f '=) (= x y) 'error!))))))))))
  373. (set apply-unary-op (lambda (f x)
  374.       (if (= f 'car) (car x)
  375.       (if (= f 'cdr) (cdr x)
  376.       (if (= f 'number?) (number? x)
  377.       (if (= f 'list?) (list? x)
  378.       (if (= f 'symbol?) (symbol? x)
  379.       (if (= f 'closure?) (closure? x)
  380.       (if (= f 'primop?) (primop? x)
  381.       (if (= f 'null?) (null? x) 'error!))))))))))
  382. (set E (mkassoc 'double (eval '(lambda (a) (+ a a)) valueops) valueops))
  383. '((+ (primop +)) (- (primop -)) ...
  384.     (double (closure (lambda (a) (+ a a)) ... )))
  385. (eval '(double 4) E)
  386. 8
  387. ; Section 4.7.6
  388. (set eval (lambda (exp env)
  389.           (if (number? exp) exp
  390.           (if (symbol? exp) (assoc exp env)
  391.           (if (= (car exp) 'quote) (cadr exp)
  392.           (if  (= (car exp) 'lambda) exp ; closure is not formed
  393.           (if  (= (car exp) 'if)
  394.                   (if  (null? (eval (cadr exp) env))
  395.                           (eval (cadddr exp) env)
  396.                           (eval (caddr exp) env))
  397.             (apply (evallist exp env) env))))))))
  398. (set apply (lambda (el env)
  399.           (if (lambda? (car el))
  400.                (apply-lambda (car el) (cdr el) env)
  401.                (apply-value-op (car el) (cdr el)))))
  402. (set apply-lambda (lambda (lam args env)
  403.           (eval (body lam)
  404.                   (mkassoc* (formals lam) args env))))
  405. (set lambda? (lambda (f) (= (car f) 'lambda)))
  406. (set E (mkassoc 's (eval 10 valueops) valueops))
  407. (set E (mkassoc 'f (eval '(lambda (x) (+ x s)) E) E))
  408. (set E (mkassoc 'g (eval '(lambda (s) (f (+ s 11))) E) E))
  409. (eval '(g 5) E)
  410. 21
  411. (set E
  412.   (mkassoc 'add (eval '(lambda (x) (lambda (y) (+ x y))) E) E))
  413. (set E (mkassoc 'add1 (eval '(add 1) E) E))
  414. (set E (mkassoc 'f (eval '(lambda (x) (add1 x)) E) E))
  415. (eval '(f 5) E)
  416. 10
  417. quit
  418.