相互再帰なY-Combinator

何となくY-Combinatorで相互再帰を書いてみた。思ったより綺麗に書けたので公開しておく。

まずは普通のY-Combinator

(define p
  (lambda (f)
    (lambda (n)
      (if (zero? n)
          1
          (+ n (f (- n 1)))))))
(define Y-a
  (lambda (meta)
    ((lambda (proc)
       (meta (lambda (n)
               ((proc proc) n))))
     (lambda (proc)
       (meta (lambda (n)
               ((proc proc) n)))))))
(display ((Y-a p) 123))
(newline)

可変長引数化

(define Y
  (lambda (meta)
    ((lambda (proc)
       (meta (lambda args
               (apply (proc proc) args))))
     (lambda (proc)
       (meta (lambda args
               (apply (proc proc) args)))))))
(display ((Y p) 123))
(newline)

相互再帰

(define p0
  (lambda (f0 f1)
    (lambda (n)
      (if (zero? n)
          1
          (+ n (f1 (- n 1)))))))
(define p1
  (lambda (f0 f1)
    (lambda (n)
      (if (zero? n)
          1
          (+ n (f0 (- n 1)))))))
(define YY-a
  (lambda (meta0 meta1)
    ((lambda (proc0 proc1)
       (meta0 (lambda args
                (apply (proc0 proc0 proc1) args))
              (lambda args
                (apply (proc1 proc0 proc1) args))))
     (lambda (proc0 proc1)
       (meta0 (lambda args
                (apply (proc0 proc0 proc1) args))
              (lambda args
                (apply (proc1 proc0 proc1) args))))
     (lambda (proc0 proc1)
       (meta1 (lambda args
                (apply (proc0 proc0 proc1) args))
              (lambda args
                (apply (proc1 proc0 proc1) args)))))))
(display ((YY-a p0 p1) 123))
(newline)

procを括り出す

(define YY-b
  (lambda (meta0 meta1)
    ((lambda (proc0 proc1)
       (let ((pp (lambda (proc)
                   (lambda args
                     (apply (proc proc0 proc1) args)))))
         (meta0 (pp proc0)
                (pp proc1))))
     (lambda (proc0 proc1)
       (let ((pp (lambda (proc)
                   (lambda args
                     (apply (proc proc0 proc1) args)))))
         (meta0 (pp proc0)
                (pp proc1))))
     (lambda (proc0 proc1)
       (let ((pp (lambda (proc)
                   (lambda args
                     (apply (proc proc0 proc1) args)))))
         (meta1 (pp proc0)
                (pp proc1)))))))
(display ((YY-b p0 p1) 123))
(newline)

procsを任意長引数化

(define YY-c
  (lambda (meta0 meta1)
    ((lambda procs
       (let ((pp (lambda (proc)
                   (lambda args
                     (apply (apply proc procs) args)))))
         (apply meta0 (map pp procs))))
     (lambda procs
       (let ((pp (lambda (proc)
                   (lambda args
                     (apply (apply proc procs) args)))))
         (apply meta0 (map pp procs))))
     (lambda procs
       (let ((pp (lambda (proc)
                   (lambda args
                     (apply (apply proc procs) args)))))
         (apply meta1 (map pp procs)))))))
(display ((YY-c p0 p1) 123))
(newline)

metaを括り出す

(define YY-d
  (lambda (meta0 meta1)
    (let ((mm (lambda (meta)
                (lambda procs
                  (let ((pp (lambda (proc)
                              (lambda args
                                (apply (apply proc procs) args)))))
                    (apply meta (map pp procs)))))))
      ((mm meta0)
       (mm meta0)
       (mm meta1)))))
(display ((YY-d p0 p1) 123))
(newline)

metaを任意長引数化

(define YY-e
  (lambda metas
    (let ((mm (lambda (meta)
                (lambda procs
                  (let ((pp (lambda (proc)
                              (lambda args
                                (apply (apply proc procs) args)))))
                    (apply meta (map pp procs)))))))
      (apply (mm (car metas)) (map mm metas)))))
(display ((YY-e p0 p1) 123))
(newline)

ついでにletを消去

(define YY
  (lambda metas
    ((lambda (mm)
       (apply (mm (car metas)) (map mm metas)))
     (lambda (meta)
       (lambda procs
         ((lambda (pp)
            (apply meta (map pp procs)))
          (lambda (proc)
            (lambda args
              (apply (apply proc procs) args)))))))))
(display ((YY p0 p1) 123))
(newline)

(追記)インターフェースはこっちの方が良い？

(define YY
  (lambda (index . metas)
    ((lambda (mm)
       (apply (mm (list-ref metas index)) (map mm metas)))
     (lambda (meta)
       (lambda procs
         ((lambda (pp)
            (apply meta (map pp procs)))
          (lambda (proc)
            (lambda args
              (apply (apply proc procs) args)))))))))
(display ((YY p0 p1) 123))
(newline)

ちなみに速度が極めて遅いので注意。