不動点演算子

Yコンビネータをcommonlispで
http://d.hatena.ne.jp/sumii/20051203/1133575324
にschemeで買いてあったから勉強のついでにcommonlispに書き直す。
難しいなぁ。。。

;;再帰している関数
;; (defun fun(n)
;;   (if (zerop n)
;;       0
;;     (+ n (fun (1- n)))))

;; CL-USER> (fun 5)
;; 15


;;右辺からfunを消したい
;; (defun make-fun(f)
;;   (lambda (n)
;;     (if (zerop n)
;;  0
;;       (+ n (funcall f (1- n))))))

;; CL-USER> (funcall (make-fun #'fun) 5)
;; 15


;;funではなくmake-funを呼び出すようにしてみる
;; (defun make-fun(make-f)
;;   (lambda (n)
;;     (if (zerop n)
;;  0
;;       (+ n (funcall (funcall make-f make-f) (1- n))))))

;; (defun fun(n)
;;   (funcall (make-fun #'make-fun) n))
;; CL-USER> (funcall (make-fun #'make-fun) 5)
;; 15

;; CL-USER> (fun 5)
;; 15


;;(funcall (funcall make-f make-f) (1- n))を定義
;; (defun make-fun(make-f)
;;   (labels ((lf (m) (funcall (funcall make-f make-f) m)))
;;     (lambda (n)
;;       (if (zerop n)
;;    0
;;  (+ n (lf (1- n)))))))

;; (defun fun(n)
;;   (funcall (make-fun #'make-fun) n))

;; CL-USER> (fun 5)
;; 15

;;lfをインライン展開
;; (defun make-fun(make-f)
;;   (lambda (n)
;;     (if (zerop n)
;;  0
;;       (+ n (funcall (lambda (m) (funcall (funcall make-f make-f) m)) (1- n))))))

;; (defun fun(n)
;;   (funcall (make-fun #'make-fun) n))

;; CL-USER> (fun 5)
;; 15


;; (defun fun(n)
;;   (funcall (make-fun #'make-fun) n))
;; のmake-fun #'make-funをインライン展開
;; (defun fun(n)
;;   (funcall
;;    (funcall
;;     (lambda (make-f)
;;       (lambda (n)
;;  (if (zerop n)
;;      0
;;    (+ n (funcall (lambda (m) (funcall (funcall make-f make-f) m)) (1- n))))))
;;     (lambda (make-f)
;;       (lambda (n)
;;  (if (zerop n)
;;      0
;;    (+ n (funcall (lambda (m) (funcall (funcall make-f make-f) m)) (1- n)))))))
;;    n))


;; CL-USER> (fun 5)
;; 15


;;処理自体も引数として受け取るようにする
(defun Y(F)
  (funcall
   (lambda (make-f)
     (funcall F (lambda (m) (funcall (funcall make-f make-f) m))))
   (lambda (make-f)
     (funcall F (lambda (m) (funcall (funcall make-f make-f) m))))))

(defun concrete-fun(f)
  (lambda (n)
    (if (zerop n)
0
      (+ n (funcall f (1- n))))))

(defun fun()
  (Y #'concrete-fun))

CL-USER> (funcall (fun) 5)
15