Data update

Task/Church-numerals/Acornsoft-Lisp/church-numerals.lisp

@@ -0,0 +1,38 @@
+(setq zero '(lambda (f x) x))
+
+(defun succ (n)
+  (freeze '(n) '(lambda (f x) (f (n f x)))))
+
+(defun add (m n)
+  (freeze '(m n) '(lambda (f x) (m f (n f x)))))
+
+(defun mul (m n)
+  (n (freeze '(m) '(lambda (sum) (add m sum))) zero))
+
+(defun pow (m n)
+  (n (freeze '(m) '(lambda (product) (mul m product))) one))
+
+(defun church (i)
+  (cond ((zerop i) zero)
+        (t (succ (church (sub1 i))))))
+
+(defun unchurch (n)
+  (n add1 0))
+
+(setq one (succ zero))
+(setq two (succ one))
+(setq three (succ two))
+(setq four (succ three))
+
+(defun show (example)
+  (prin example)
+  (princ '! =>! )
+  (print (unchurch (eval example))))
+
+(defun examples ()
+  (show '(church 3))
+  (show '(add three four))
+  (show '(mul three four))
+  (show '(pow three four))
+  (show '(pow four three))
+  (show '(pow (pow two two) (add two one))))

Task/Church-numerals/Common-Lisp/church-numerals-1.lisp

@@ -0,0 +1,34 @@
+(defvar zero (lambda (f x) x))
+
+(defun succ (n) (lambda (f x) (funcall f (funcall n f x))))
+
+(defun plus (m n)
+  (lambda (f x) (funcall m f (funcall n f x))))
+
+(defun times (m n)
+  (funcall n (lambda (sum) (plus m sum)) zero))
+
+(defun power (m n)
+  (funcall n (lambda (product) (times m product)) one))
+
+(defun church (i)    ; int -> Church
+  (if (zerop i) zero (succ (church (1- i)))))
+
+(defun unchurch (n)  ; Church -> int
+  (funcall n #'1+ 0))
+
+(defun show (example)
+  (format t "~(~S => ~S~)~%"
+          example (unchurch (eval example))))
+
+(defvar one (succ zero))
+(defvar two (succ one))
+(defvar three (succ two))
+(defvar four (succ three))
+
+(show '(church 3))
+(show '(plus three four))
+(show '(times three four))
+(show '(power three four))
+(show '(power four three))
+(show '(power (power two two) (plus two one)))

Task/Church-numerals/Common-Lisp/church-numerals-2.lisp

@@ -0,0 +1,21 @@
+(defvar zero (lambda (f) (lambda (x) x)))
+
+(defun succ (n) (lambda (f) (compose f (funcall n f))))
+
+(defun plus (m n)
+  (lambda (f) (compose (funcall m f) (funcall n f))))
+
+(defun times (m n)
+  (compose m n))
+
+(defun power (m n)
+  (funcall n m))
+
+(defun compose (f g)
+  (lambda (x) (funcall f (funcall g x))))
+
+(defun church (i)    ; int -> Church
+  (if (zerop i) zero (succ (church (1- i)))))
+
+(defun unchurch (n)  ; Church -> int
+  (funcall (funcall n #'1+) 0))

Task/Church-numerals/Common-Lisp/church-numerals-3.lisp

@@ -0,0 +1,10 @@
+(defun pred (n)
+  (flet ((value (v) (lambda (h) (funcall h v)))
+         (extract (k) (funcall k (lambda (u) u))))
+    (lambda (f x)
+      (let ((inc (lambda (g) (value (funcall g f))))
+            (const (lambda (u) x)))
+        (extract (funcall n inc const))))))
+
+(defun minus (m n)
+  (funcall n #'pred m))

Task/Church-numerals/Common-Lisp/church-numerals-4.lisp

@@ -0,0 +1,5 @@
+(defmacro church-if (test then else)
+  `(funcall ,test (lambda () ,then) (lambda () ,else)))
+
+(defvar true (lambda (f g) (funcall f)))
+(defvar false (lambda (f g) (funcall g)))

Task/Church-numerals/Common-Lisp/church-numerals-5.lisp

@@ -0,0 +1,11 @@
+(defun is-zero (n)
+  (funcall n (lambda (x) false) true))
+
+(defun divide (m n)
+  (divide1 (succ m) n))
+
+(defun divide1 (m n)
+  (let ((d (minus m n)))
+    (church-if (is-zero d)
+        zero
+      (succ (divide1 d n)))))

Task/Church-numerals/Common-Lisp/church-numerals-6.lisp

@@ -0,0 +1,4 @@
+(show '(pred four))
+(show '(minus (church 11) three))
+(show '(divide (church 11) three))
+(show '(divide (church 12) three))

Task/Church-numerals/Common-Lisp/church-numerals-7.lisp

@@ -0,0 +1,18 @@
+(defun pred (n)
+  (flet ((value (v) (lambda (h) (funcall h v)))
+         (extract (k) (funcall k (lambda (u) u))))
+    (lambda (f)
+      (lambda (x)
+        (let ((inc (lambda (g) (value (funcall g f))))
+              (const (lambda (u) x)))
+          (extract (funcall (funcall n inc) const)))))))
+
+(defun minus (m n)
+  (funcall (funcall n #'pred) m))
+
+...
+
+(defun is-zero (n)
+  (funcall (funcall n (lambda (x) false)) true))
+
+...