fork download
copy 
  1. ; Rewrite member for the ycombinator
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 9
  5. ; Exercise 4
  6. ; Common Lisp
  7. ; http://t...content-available-to-author-only...r.com/thelittlelisper
  8. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper-chapter-9-lamdba-ultimate.html
  9. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper.html
  10. ; ------------------------------
  11.  
  12. ;Y-combinator for functions of two arguments
  13. ;rewritten for lisp-2 namespace 
  14. (defun Y2 (M)
  15.       ((lambda (future)
  16.          (funcall M (function (lambda (arg1 arg2)
  17.                                 (funcall (funcall future future) arg1 arg2)))))       
  18.  
  19.        (function (lambda (future)                                      
  20.                    (funcall M (lambda (arg1 arg2)                                
  21.                                 (funcall (funcall future future) arg1 arg2)))))))
  22.  
  23.  
  24.  
  25. ;assuming reference to member refers to chapter 2 (for member function) and not 3 (typo)
  26.  
  27. (setf (symbol-function 'member-Y)
  28.   (Y2 (function (lambda (recurring-function)
  29.                   (function (lambda (a lat)
  30.                               (cond
  31.                                ((null lat) nil)
  32.                                (t (or
  33.                                    (eq (car lat) a)
  34.                                    (funcall recurring-function a (cdr lat)))))))))))
  35.       ;l)))
  36.  
  37. (print (member-Y 'a '(a b c d e f g)))
  38. ;T
  39.  
  40. (print (member-Y 'b '(a b c d e f g)))
  41. ;T
  42.  
  43. (print (member-Y 'c '(a b c d e f g)))
  44. ;T
  45.  
  46. (print (member-Y 'z '(a b c d e f g)))
  47. ;NIL false
  48.  
  49. ;but rember does come from chapter 3 (not a typo)
  50. (setf (symbol-function 'rember-Y)
  51.   (Y2 (function (lambda (recurring-function)
  52.                   (function (lambda (a lat)
  53.                               (cond 
  54.                                ((null lat) '())
  55.                                (t (cond
  56.                                    ((eq (car lat) a) (cdr lat))
  57.                                    (t (cons (car lat)                                            
  58.                                    (funcall recurring-function a (cdr lat)))))))))))))
  59.  
  60. (print (rember-Y 'and '(bacon lettuce and tomato)))
  61. ;(BACON LETTUCE TOMATO)
  62.  
  63. ;insertR
  64. (defun YN (F)
  65.    ((lambda (future)
  66.       (funcall F (function(lambda (&rest args)
  67.                      (apply (funcall future future) args)))))
  68.     #'(lambda (future)
  69.         (funcall F (function(lambda (&rest args)
  70.                        (apply (funcall future future) args))))) ) ) 
  71.  
  72. (setf (symbol-function 'insertR-Y)
  73.   (YN (function (lambda (recurring-function)
  74.                   (function (lambda (new old lat)
  75.                               (cond
  76.                                ((null lat) '())
  77.                                (t (cond
  78.                                    ((eq (car lat) old)
  79.                                     (cons old
  80.                                           (cons new (cdr lat))))
  81.                                    (t (cons (car lat)
  82.                                             (funcall recurring-function
  83.                                              new old (cdr lat)))))))))))))
  84.  
  85. (print (insertR-Y 'toasted 'club '(large club sandwich)))
  86. ;(LARGE CLUB TOASTED SANDWICH)
  87.  
  88.  
  89. ;subst-2
  90.  
  91. (setf (symbol-function 'subst2-Y)
  92.   (YN (function (lambda (recurring-function)
  93.                   (function (lambda (new o1 o2 lat)
  94.                               (cond
  95.                                ((null lat) '())
  96.                                (t (cond
  97.                                    ((eq (car lat) o1)
  98.                                     (cons new (cdr lat)))
  99.                                    ((eq (car lat) o2)
  100.                                     (cons new (cdr lat)))
  101.                                    (t (cons (car lat)
  102.                                             (funcall recurring-function new
  103.                                                      o1 o2 (cdr lat)))))))))))))
  104.  
  105. (print (subst2-Y 'vanilla 'chocolate 'banana '(banana icecream with chocolate topping)))
  106. ;(VANILLA ICECREAM WITH CHOCOLATE TOPPING)
  107.  
  108. (print (subst2-Y 'vanilla 'chocolate 'topping '(banana icecream with chocolate topping)))
  109. ;(BANANA ICECREAM WITH VANILLA TOPPING)
  110.  
Success #stdin #stdout 0.02s 10912KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
T 
T 
T 
NIL 
(BACON LETTUCE TOMATO) 
(LARGE CLUB TOASTED SANDWICH) 
(VANILLA ICECREAM WITH CHOCOLATE TOPPING) 
(BANANA ICECREAM WITH VANILLA TOPPING)
https://ideone.com/YVNh6
language:
Common Lisp (clisp 2.49.92)
created:
14 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!