<![CDATA[
(define (reduce-once E)
(cond ((not (pair? E)) #f)
((lambda-expression? E) #f)
((lambda-expression? (operator E))
(subst (operand E)
(argument (operator E))
(body (operator E))))
(else
(let ((reduced-operator
(reduce-once (operator E))))
(if reduced-operator
`(,reduced-operator ,(operand E))
(let ((reduced-operand
(reduce-once (operand E))))
(if reduced-operand
`(,(operator E) ,reduced-operand)
#f)))))))
(define (reduce E)
(let ((reduced-expression (reduce-once E)))
(if reduced-expression
(reduce reduced-expression)
E)))
(define (lambda-expression? E)
(and (pair? E)
(eq? (type E) 'lambda)))
(define (free? x E)
(cond ((null? E) #t)
((pair? E)
(if (eq? (type E) 'lambda)
(if (eq? (argument E) x)
#f
(free? x (body E)))
(or (free? x (operator E))
(free? x (operand E)))))
(else
(eq? E x))))
(define (subst M x E)
(cond ((eq? E x) M)
((not (pair? E)) E)
((lambda-expression? E)
(let ((y (argument E))
(E* (body E)))
(if (or (eq? x y) (not (free? x E*)))
E
(if (not (free? y M))
`(lambda (,y) ,(subst M x E*))
(let ((z (gensym)))
`(lambda (,z)
,(subst M x (subst z y E*))))))))
(else
(list (subst M x (operator E))
(subst M x (operand E))))))
(define operator car)
(define operand cadr)
(define type car)
(define argument caadr)
(define body caddr)
(define true
`(lambda (x)
(lambda (y)
x)))
(define false
`(lambda (x)
(lambda (y)
y)))
(define kons
`(lambda (x)
(lambda (y)
(lambda (f)
((f x) y)))))
(define kar
`(lambda (f)
(f ,true)))
(define kdr
`(lambda (f)
(f ,false)))
(define nil
`(lambda (x) ,true))
(define nil?
`(lambda (f)
(f (lambda (x)
(lambda (y)
,false)))))
(define (lambda->sexpr E)
(cond ((symbol? E) E)
((zero? (reduce `(((,nil? ,E) 0) 1))) ())
(else
(cons (lambda->sexpr (reduce `(,kar ,E)))
(lambda->sexpr (reduce `(,kdr ,E)))))))
(define succ
`(lambda (x)
((,kons x) ,nil)))
(define pred kar)
(define (number->lambda n)
(if (= n 0)
nil
`(,succ ,(number->lambda (- n 1)))))
(define (lambda->number E)
(if (zero? (reduce `(((,nil? ,E) 0) 1)))
0
(+ 1 (lambda->number (reduce `(,pred ,E))))))
;; (u)
(define foo
`((,kons u) ,nil))
;; (u v w)
(define bar
`((,kons u) ((,kons v) ((,kons w) ,nil))))
(define f
`(lambda (f)
(lambda (x)
(((,nil? x) ,nil) ((,kons (,kar x)) (f (,kdr x)))))))
;; An expression which can copy nil...
;; (lambda->sexpr (reduce `((,f ,what!?) ,nil))) => ()
;; `((,f ,what!?) ,nil) =>
;; `((lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) (,what!? (,kdr x))))) ,nil) =>
;; `(((,nil? ,nil) ,nil) ((,kons (,kar ,nil)) (,what!? (,kdr ,nil)))) =>
;; `((,true ,nil) ((,kons (,kar ,nil)) (,what!? (,kdr ,nil)))) =>
;; ,nil
;; but fails on lists of length 1 or greater.
;; (lambda->sexpr (reduce `(,(,f ,what!?) ,foo))) => What!? No PeZ!
;; `((,f ,what!?) ,foo) =>
;; `((lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) (,what!? (,kdr x))))) ,foo) =>
;; `(((,nil? ,foo) ,nil) ((,kons (,kar ,foo)) (,what!? (,kdr ,foo)))) =>
;; `((,false ,nil) ((,kons (,kar ,foo)) (,what!? (,kdr ,foo)))) =>
;; `((,kons (,kar ,foo)) (,what!? (,kdr ,foo))) => What!? No PeZ!
]]>
<![CDATA[
;; An expression which can copy lists of length 1...
;; (lambda->sexpr (reduce `(,f (,f ,what!?)) ,foo)) => (u)
;; `((,f (,f ,what!?)) ,foo) =>
;; `((lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) ((,f ,what!?) (,kdr x))))) ,foo) =>
;; `(((,nil? ,foo) ,nil) ((,kons (,kar ,foo)) ((,f ,what!?) (,kdr ,foo)))) =>
;; `((,false ,nil) ((,kons (,kar ,foo)) ((,f ,what!?) (,kdr ,foo)))) =>
;; `((,kons (,kar ,foo)) ((,f ,what!?) (,kdr ,foo))) =>
;; `((,kons u) ((,f ,what!?) (,kdr ,foo))) =>
;; `((,kons u) ((lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) (,what!? (,kdr x))))) (,kdr foo)) =>
;; `((,kons u) (((,nil? (,kdr foo)) ,nil) ((,kons (,kar (,kdr foo))) (,what!? (,kdr (,kdr foo))))) =>
;; `((,kons u) ((,true ,nil) ((,kons (,kar (,kdr foo))) (,what!? (,kdr (,kdr foo))))) =>
;; ((,kons u) ,nil)
;; but fails on lists of length 2 or greater.
;; (lambda->sexpr (reduce `(,f (,f ,what!?)) ,bar)) => What!? No PeZ!
;; An expression which can copy lists of length 3 or less.
;; (lambda->sexpr (reduce `(,f (,f (,f (,f what!?)))) ,nil))) => ()
;; (lambda->sexpr (reduce `(,f (,f (,f (,f what!?)))) ,foo))) => (u)
;; (lambda->sexpr (reduce `(,f (,f (,f (,f what!?)))) ,bar))) => (u v w)
]]>
<![CDATA[
;; An expression of infinite length which can copy any list.
;; `(,f ...(,f (,f (,f ,what!?)))...)
;; Let there be Y...
(define Y
'(lambda (f)
((lambda (g) (f (g g)))
(lambda (g) (f (g g))))))
;; Reducing (,Y ,f) once...
;; `(,Y ,f) => `((lambda (g) (,f (g g))) (lambda (g) (,f (g g))))
;; Let's give this expression a name...
(define pez `((lambda (g) (,f (g g))) (lambda (g) (,f (g g)))))
]]>
<![CDATA[
;; Reducing pez yields...
;; pez =
;; `((lambda (g) (,f (g g))) (lambda (g) (,f (g g)))) =>
;; `(,f ((lambda (g) (,f (g g))) (lambda (g) (,f (g g))))) =
;; `(,f ,pez) =>
;; `(lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) (,pez (,kdr x)))))
;; Note: Because pez => `(,f ,pez) it is called a "fixed-point" of f.
;; Let's see how (,Y ,f) copies a list of length 1...
;; `((,Y ,f) ,foo) =>
;; `(,pez ,foo) =>
;; Pez! Give me an f!
;; `((,f ,pez) ,foo) =>
;; `((lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) (,pez (,kdr x))))) ,foo) =>
;; `(((,nil? ,foo) ,nil) ((,kons (,kar ,foo)) (,pez (,kdr ,foo)))) =>
;; `((,false ,nil) ((,kons (,kar ,foo)) (,pez (,kdr ,foo)))) =>
;; `((,kons (,kar ,foo)) (,pez (,kdr ,foo))) =>
;; `((,kons u) (,pez (,kdr ,foo))) =>
;; Pez! Give me an f!
;; `((,kons u) ((,f ,pez) (,kdr ,foo))) =>
;; `((,kons u) ((lambda (x) (((,nil? x) ,nil) ((,kons (,kar x)) (,pez (,kdr x))))) (,kdr ,foo)) =>
;; `((,kons u) (((,nil? (,kdr foo)) ,nil) ((,kons (,kar (,kdr ,foo))) (,pez (,kdr (,kdr ,foo)))))) =>
;; `((,kons u) ((,true ,nil) ((,kons (,kar (,kdr ,foo))) (,pez (,kdr (,kdr ,foo)))))) =>
;; `((,kons u) ,nil)
;; It follows that (,Y ,f) is an expression of finite length which can copy any list!!
;; (lambda->sexpr (reduce `((,Y ,f) ,bar))) => (u v w)
(define plus
`(lambda (x)
(,Y (lambda (f)
(lambda (y)
(((,nil? y) x) (,succ (f (,pred y)))))))))
(define times
`(lambda (x)
(,Y (lambda (f)
(lambda (y)
(((,nil? (,pred y)) x) ((,plus x) (f (,pred y)))))))))
]]>