;;
;; The four digit problem
;;
;; Given the integers 1 2 3 4, the binary operations plus, minus, divide,
;; times, power, and "digits," construct expressions for various
;; integers. "digits" takes two of the integers and combines them
;; to make a two digit number: digits(4,3) = 43. With these rules
;; one can construct expressions for all the integers up to 52
;;
;; Also, although I don't like it, one can add decimal points to any of
;; the numbers: 43. 4.3 or .43 are all allowed. With this rule,
;; one can construct all the integers upt to 88.
;; compose two numbers. It simply concatonates the decimal
;; expansion of the two numbers, when one is an integer
(defun digits (x y)
(cond ((and (numberp y) (<= y 0)) nil) ;no result if second number not > 0
((and (integerp x) (numberp y))
(+ (* 10 (expt 10 (floor (log y 10))) x) y))
((and (numberp x) (integerp y))
(+ x (/ y (do ((z x (* z 10))
(zz (expt 10 (floor (log y 10))) (* zz 10)))
((integerp z) (* zz 10))))))
(t nil)))
;; There are expressions which are numerically so large it
;; takes too long to calculate them.
(defun ^ (x y)
(if (or (= x 0) (< (abs (* (log (abs x)) y)) 1000))
(expt x y)
(error "power too big for ~A^~A" x y)))
;; The operator digits can only act on numbers or other digit operators.
;; Test validity of any digit operator in an expression.
(defun test-digits (x)
(cond ((atom x) t)
((eq (car x) 'digits) (and (digits-or-numberp x) (eval x)))
(t (and (test-digits (car x)) (test-digits (cdr x))))))
(defun digits-or-numberp (x)
"Test that an expression is composed of numbers and digit operators"
(if (atom x) (numberp x) (and (eq (car x) 'digits)
(digits-or-numberp (second x))
(digits-or-numberp (third x)))))
;; list of allowd binary operators
(setq ops '(digits * + - / ^))
(defun permutations (list)
"General utility to construct the permutations of a list"
(cond ((null list)
nil)
((null (cdr list))
(list list))
(t
(loop with head = (car list)
for l in (permutations (cdr list))
for list = (copy-list (cons head l))
append (loop for i on list
collect (copy-list list)
until (null (cdr i))
do (rotatef (car i) (cadr i)))))))
;; Construct a list of all possible expressions that yield a positive
;; integer that is not too large.
;; There is no check for algebraic equivalence.
(setq all (let ((result))
(dolist (n (permutations '(1 2 3 4)))
;; This loop adds decimal points to some selection of the integers.
;; There are 16 ways to do this.
(dotimes (bt 16)
(let ((a (if (= (logand bt 1) 0) (nth 0 n) (/ (nth 0 n) 10)))
(b (if (= (logand bt 2) 0) (nth 1 n) (/ (nth 1 n) 10)))
(c (if (= (logand bt 4) 0) (nth 2 n) (/ (nth 2 n) 10)))
(d (if (= (logand bt 8) 0) (nth 3 n) (/ (nth 3 n) 10))))
;; Iterate over all possible binary operations
(dolist (x ops)
(dolist (y ops)
(dolist (z ops)
;; compose the four integers using the 3 binary operators
;; there are five ways to do this
(dolist (expr (list
(list x (list y a b) (list z c d))
(list x (list y (list z a b) c) d)
(list x (list y a (list z b c)) d)
(list x a (list y (list z b c) d))
(list x a (list y b (list z c d)))))
;; The error handler allows one to drop numbers that are too large
;; and divide-by-zero errors.
(handler-case
;; Test that we have a valid expression that produces a positive integer
(if (and (test-digits expr) (integerp (eval expr))
(>= (eval expr) 0))
(push (list (eval expr) expr) result))
(error (ccc) (format t "Blech! ~A~%" ccc)))
)))))))
;; Sort the result
(sort result #'(lambda (a b) (< (abs a) (abs b))) :key #'car)))
;; find out what integers can be constructed
;; cases where there is no expression:
;; with decimal points: 89 98 99 ...
;; without decimal points: 53 56 57 74 77 89 90 94 95 97 98 99 ...
(dotimes (n 100) (or (member n all :key #'car) (format t "~A~%" n)))