fork download
copy 
  1. ; Can you rewrite your function for the ycombinator?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 9
  5. ; Exercise 3
  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 - and removed first lambda
  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. ; Note that we have to use symbol-fucntion to get around the lisp-2 namespace                                
  25.  
  26. (setf (symbol-function '_=)
  27.   (Y2 (function (lambda (recurring-function)
  28.                  (function (lambda (m n)
  29.                                    (cond
  30.                                     ((> n m) nil)                                    
  31.                                     ((< n m) nil)                                    
  32.                                     (t t))))))))
  33.  
  34. (_= 1 2)
  35. ;NIL false
  36.  
  37. (_= 2 2)
  38. ;T
  39.  
  40. (setf zero 0)
  41.  
  42. (defun zero (n)
  43.   (cond
  44.    ((null n) '())
  45.    ((= zero n) t)
  46.    (t '())))
  47.  
  48. (defun sub1 (n)
  49.   (cond
  50.    ((null n) '())
  51.    ((- n 1))))
  52.  
  53. (setf (symbol-function 'pick)
  54.   (Y2 (function (lambda (recurring-function)
  55.                  (function (lambda (n lat)
  56.                              (cond
  57.                               ((null lat) nil)
  58.                               ((zero (sub1 n)) (car lat))
  59.                               (t (funcall recurring-function (sub1 n) (cdr lat))))))))))
  60.  
  61. (print (pick 3 '(a b c d e f g h i j))                           )
  62.  
  63. (setf (symbol-function 'rempick)
  64.   (Y2 (function (lambda (recurring-function)
  65.                  (function (lambda (n lat)
  66.                              (cond
  67.                               ((null lat) '())
  68.                               ((zero (sub1 n)) (cdr lat))
  69.                               (t (cons (car lat)
  70.                                        (funcall recurring-function (sub1 n)(cdr lat)))))))))))
  71.  
  72. (print (rempick 3 '(a b c d e f g h i j)))
  73.  
  74.  
  75.  
  76. #This is the definition from Rosetta - but we're not using it here in order to match the
  77. #idomatic style of the book
  78. #http://r...content-available-to-author-only...e.org/wiki/Y_combinator#Common_Lisp
  79.  
  80. (defun Y (f) 
  81.   ((lambda (x) (funcall x x)) 
  82.    (lambda (y) 
  83.      (funcall f (lambda (&rest args) 
  84. 		  (apply (funcall y y) args))))))
  85.  
  86. (defun fac (f) 
  87.   (lambda (n) 
  88.     (if (zerop n) 
  89. 	1 
  90. 	(* n (funcall f (1- n))))))
  91.  
  92. (defun fib (f) 
  93.   (lambda (n) 
  94.     (case n
  95.       (0 0) 
  96.       (1 1) 
  97.       (otherwise (+ (funcall f (- n 1)) 
  98. 		    (funcall f (- n 2)))))))
  99.  
  100. ;; CL-USER> (loop for i from 1 to 10 collect (list i (funcall (Y #'fac) i) (funcall (Y #'fib) i)))
  101. ;; ((1 1 1) (2 2 1) (3 6 2) (4 24 3) (5 120 5) (6 720 8) (7 5040 13)
  102. ;;  (8 40320 21) (9 362880 34) (10 3628800 55))
  103.  
Success #stdin #stdout 0.02s 10848KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
C 
(A B D E F G H I J)
https://ideone.com/CM9jK
language:
Common Lisp (clisp 2.49.92)
created:
13 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!