Skip to content

Instantly share code, notes, and snippets.

@curtmack
Last active July 9, 2023 09:48
Show Gist options
  • Save curtmack/6d2fb86bb496365345da7469a9b18695 to your computer and use it in GitHub Desktop.
Save curtmack/6d2fb86bb496365345da7469a9b18695 to your computer and use it in GitHub Desktop.
/r/dailyprogrammer Challenge #331 Easy: The Adding Calculator
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Part One: Basic lambda calculus boilerplate ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define true lambda abstractions.
;;; True lambda abstractions curry.
(defmacro λ ((arg &rest more-args) &body expr)
(labels ((recur (args)
(if (null args)
(cons 'curry expr)
`(lambda (,(car args))
(declare (ignorable ,(car args)))
,(recur (cdr args))))))
(recur (cons arg more-args))))
;;; Call lambda abstractions in a convenient way.
(defmacro curry (func &rest args)
(labels ((subcurry (arg)
(if (and arg
(listp arg)
(not (eq 'λ (car arg)))
(not (eq 'curry (car arg)))
(not (eq 'lambda (car arg)))
(not (eq 'function (car arg))))
(cons 'curry arg)
arg))
(recur (args)
(if (null args)
(subcurry func)
`(funcall ,(recur (cdr args)) ,(subcurry (car args))))))
(recur (reverse args))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Part Two: Basic Church encoding ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Church booleans are lambda abstractions that take two arguments.
;;; True produces the first argument, and false produces the second.
;;; In other words, Church booleans encode the idea of choice.
;;; Church-encoded truth and falsehood.
(defparameter true (λ (x y) x))
(defparameter false (λ (x y) y))
;;; Logical operators on Church booleans.
(defparameter boolnot (λ (p) p false true))
(defparameter booland (λ (p q) p q p))
(defparameter boolor (λ (p q) p p q))
;;; Church numerals are lambda abstractions that take a function and an
;;; argument, and produce the result of that function iteratively applied to
;;; the argument N times.
;;; In other words, Church numerals encode the idea of counted repetition.
;;; The Church numeral zero.
(defparameter zero (λ (f x) x))
;;; Successor on Church numerals
(defparameter succ (λ (n f x) f (n f x)))
;;; Church numerals of all the digits
(defparameter one (curry succ zero))
(defparameter two (curry succ one))
(defparameter three (curry succ two))
(defparameter four (curry succ three))
(defparameter five (curry succ four))
(defparameter six (curry succ five))
(defparameter seven (curry succ six))
(defparameter eight (curry succ seven))
(defparameter nine (curry succ eight))
;;; We'll also need ten later on
(defparameter ten (curry succ nine))
;;; Addition on Church numerals
(defparameter plus (λ (m n f x) m f (n f x)))
;;; Multiplication on Church numerals
(defparameter mult (λ (m n f) m (n f)))
;;; Exponent on Church numerals
(defparameter exponent (λ (m n) n m))
;;; Predecessor on Church numerals
;;; This is probably the hardest to understand. The basic idea is to build a
;;; container around F and X that omits the application of the function the
;;; first time.
(defparameter pred (λ (n f x)
n
(λ (g h) h (g f))
(λ (u) x)
(λ (u) u)))
;;; Subtraction on Church numerals
(defparameter minus (λ (m n) (n pred) m))
;;; Test for Church numeral zero
(defparameter is-zero (λ (n)
n (λ (x) false) true))
;;; Church numeral <= and <
(defparameter lte (λ (m n) is-zero (minus m n)))
(defparameter lt (λ (m n) boolnot (lte n m)))
;;; Convenience encoding of a lazy if statement
;;; The true and false clauses should be shaped like (λ (c))
;;; for laziness purposes
(defparameter curryif (λ (c tr fl)
(c tr fl) c))
;;; Y-combinator for recursion
(defparameter yfix (λ (f)
(λ (x arg) f (x x) arg)
(λ (x arg) f (x x) arg)))
;;; Division on Church numerals
(defparameter divide (curry yfix
(λ (rec q a b)
(curryif (lt a b)
(λ (c) q)
(λ (c) (rec (succ q) (minus a b) b))))
zero))
;;; Modulus on Church numerals
(defparameter modulus (curry yfix
(λ (rec q a b)
(curryif (lt a b)
(λ (c) a)
(λ (c) (rec (succ q) (minus a b) b))))
zero))
;;; Divisibility test
(defparameter divides (λ (a b) is-zero (modulus a b)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Part Three: Advanced Church encoding ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; At this point, we're missing negative integers.
;;; We can get pairs out of the lambda calculus like this:
(defparameter pair (λ (x y z) z x y))
(defparameter fst (λ (p) p true))
(defparameter snd (λ (p) p false))
;;; Signed integers can be defined as a pair where both values are Church
;;; numerals.
;;; The signed value is treated as (first - second)
;;; Convert a natural Church numeral to a signed Church numeral
(defparameter as-signed (λ (x) pair x zero))
;;; Negate a signed Church numeral
(defparameter neg (λ (x) pair (snd x) (fst x)))
;;; Determine whether a signed Church numeral is negative
(defparameter is-neg (λ (x) lt (fst x) (snd x)))
;;; Absolute value of a signed Church numeral, as a natural number
(defparameter magnitude (λ (x)
is-neg x
(minus (snd x) (fst x))
(minus (fst x) (snd x))))
;;; Absolute value of a signed Church numeral
(defparameter signabs (λ (x) as-signed (magnitude x)))
;;; Convert a signed Church numeral of unknown temperament into a normalized
;;; form, where one of the pair is zero.
(defparameter onezero (curry yfix
(λ (rec x)
(curryif
(is-zero (fst x))
(λ (c) x)
(λ (c)
(curryif
(is-zero (snd x))
(λ (d) x)
(λ (d) (rec pair
(pred (fst x))
(pred (snd x))))))))))
;;; Signed plus and minus
(defparameter signplus (λ (x y)
onezero
(pair
(plus (fst x) (fst y))
(plus (snd x) (snd y)))))
(defparameter signminus (λ (x y)
onezero
(pair
(plus (fst x) (snd y))
(plus (snd x) (fst y)))))
;;; Signed multiply and divide
(defparameter signmult (λ (x y)
pair
(plus
(mult (fst x) (fst y))
(mult (snd x) (snd y)))
(plus
(mult (fst x) (snd y))
(mult (snd x) (fst y)))))
(defparameter divz (λ (x y)
(curryif
(is-zero y)
(λ (c) zero)
(λ (c) divide x y))))
(defparameter signdivide (λ (x y)
pair
(plus
(divz (fst x) (fst y))
(divz (snd x) (snd y)))
(plus
(divz (fst x) (snd y))
(divz (snd x) (fst y)))))
;;; Even/odd tests
(defparameter is-even (λ (x) divides (magnitude x) two))
(defparameter is-odd (λ (x) boolnot (is-even x)))
;;; Signed exponent
;;; We'll filter out negative b later
(defparameter signexponent (λ (a b)
(is-zero (magnitude b)) (as-signed one)
(curryif
(booland (is-odd b) (is-neg a))
(λ (c)
neg
(as-signed
(exponent
(magnitude a)
(magnitude b))))
(λ (c)
as-signed
(exponent
(magnitude a)
(magnitude b))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Part Four: Final implementations ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These are the actual implementations for the calculator.
;;; These include some validity checks for division and exponents.
;;; First, we need to convert between Church numerals and single digits.
(defun digit->church (c)
(ecase c
(#\0 zero)
(#\1 one)
(#\2 two)
(#\3 three)
(#\4 four)
(#\5 five)
(#\6 six)
(#\7 seven)
(#\8 eight)
(#\9 nine)))
(defun church->digit (n)
(let* ((zero-ascii (char-code #\0))
;; This is the only direct use of an increment operation in this code.
(digit-ascii (curry n #'1+ zero-ascii)))
(code-char digit-ascii)))
;;; Now, the larger conversions.
;;; These can be done almost entirely in lambda calculus, but it would be a bit
;;; annoying so I don't feel like it.
(defun read-church-numeral (&optional (strm t) (eof-error-p t) (eof-value nil))
;; Read a value. If we get EOF, return as appropriate
(let ((r (read strm eof-error-p eof-value)))
(if (eq eof-value r)
eof-value
;; Otherwise, convert to a string
(let ((str (with-output-to-string (s) (princ r s)))
(negative-p nil))
;; If the string starts with a -, it's a negative number
;; Strip the - and set the negative-p flag
(when (char= #\- (char str 0))
(setf
str (subseq str 1)
negative-p t))
;; For each character in the string, keep adding the digits
(loop with accum = zero
for c across str
as digit = (digit->church c)
do (setf accum (curry plus digit (mult ten accum)))
;; Convert to signed and negate if needed
finally (return (if negative-p
(curry neg (as-signed accum))
(curry as-signed accum))))))))
(defun write-church-numeral (num &optional (strm t))
;; Special case: if num is a string, it's an error, so print it directly
(if (stringp num)
(princ num strm)
(let ((mag (curry magnitude num))
(negative-p (curry is-neg num t nil)))
;; Keep dividing by 10 and consing the latest digit
(loop with chars = nil
for n = mag then (curry divide n ten)
as digit = (curry modulus n ten)
;; Stop when both n and digit are 0
while (curry boolor
(boolnot (is-zero n))
(boolnot (is-zero digit))
t nil)
do (setf chars (cons (church->digit digit) chars))
finally (progn
;; For 0, chars will be nil at this point
(when (null chars)
(setf chars '(#\0)))
;; Add the - if negative
(when negative-p
(setf chars (cons #\- chars)))
;; Coerce to a string and output at the end
(princ (coerce chars 'string) strm))))))
;;; Now, we need to actually implement the operations we'll support.
;;; First, the easy ones:
(defun impl-plus (a b)
(write-church-numeral (curry signplus a b)))
(defun impl-minus (a b)
(write-church-numeral (curry signminus a b)))
(defun impl-mult (a b)
(write-church-numeral (curry signmult a b)))
;;; For division, we have to look out for b being zero, or b not dividing a
(defun impl-divide (a b)
(write-church-numeral (curry
(curryif
(is-zero (magnitude b))
(λ (c) "Not-defined")
(λ (c)
(curryif
(boolnot (divides (magnitude a) (magnitude b)))
(λ (d) "Non-integral answer")
(λ (d) signdivide a b)))))))
;;; For exponent, we have to look out for b being negative
(defun impl-exponent (a b)
(write-church-numeral (curry
(curryif
(is-neg b)
(λ (c) "Non-integral answer")
(λ (c) signexponent a b)))))
;;; Dispatcher
(defun dispatcher (a op b)
(ecase op
(+ (impl-plus a b))
(- (impl-minus a b))
(* (impl-mult a b))
(/ (impl-divide a b))
(^ (impl-exponent a b))))
;;; Read a problem
(defun read-problem (&optional (strm t))
(block problem-reader
(handler-bind
((error (lambda (c)
(declare (ignorable c))
(write-line "Bad problem")
(return-from problem-reader (values nil nil nil)))))
(let ((a (read-church-numeral strm nil))
(op (read strm nil))
(b (read-church-numeral strm nil)))
;; Only return the values if all of them are non-nil
(if (and a op b)
(values a op b)
(values nil nil nil))))))
;;; Interactive solver
(loop for line = (read-line t nil :eof)
while (and line (not (eq line :eof)))
do
(with-input-from-string (s line)
(multiple-value-bind (a op b) (read-problem s)
(when (and a op b)
(dispatcher a op b)
(terpri))))) 
@nikasept
Copy link

nikasept commented Jul 9, 2023

what's this all about?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment