Here’s the problem we’ll explore today: find four prices in USD whose sum and product are both $7.11.

Let’s just make this as straightforward as possible. Note that if we compute in cents, then the sum is 711 and the product is 711,000,000. The nested loops practically write themselves:

(defun f711 ()
  (let ((product (* 711 100 100 100)))
   (loop for x from 1 to 711 thereis
     (loop for y from x to 711 thereis
        (loop for z from y to 711
              for w = (- 711 x y z)
              thereis (and (= (* w x y z) product)
                           (list x y z w)))))))

We find out quickly enough that a solution is $3.16, $1.20, $1.25, and $1.50. And, I think the code looks good. For comparison, I translated it to scheme, and here’s the first thing I came up with:

(define (f711)
  (let ((product (* 711 100 100 100)))
    (call-with-current-continuation (lambda (return)
      (do ((x 1 (+ 1 x))) ((> x 711) #f)
        (do ((y x (+ 1 y))) ((> y 711))
          (do ((z y (+ 1 z))) ((> z 711))
            (let ((w (- 711 x y z)))
              (if (= (* w x y z) product)
                (return (list w x y z)))))))))))

I think which you like better mostly depends on your opinion of loop in lisp. From a performance standpoint, though, SBCL beat chicken, kawa, and racket hands down. Anyway, let’s continue.

Ok, does this work for other totals? Let’s generalize: This time I was more careful about smart upper limits. I initially tried “for x from 1 to (- tgt x x x)” but LISP didn’t like the self-reference in the upper bound. Fortunately, converting it to a while clause was no trouble.

(defun coins-sum-prod (tgt)
  (let ((product (* tgt 100 100 100)))
    (loop for x from 1 while (<= x (- tgt x x x)) thereis
      (loop for y from x while (<= y (- tgt x y y)) thereis
        (loop for z from y while (<= z (- tgt x y z))
              for w  = (- tgt x y z)
              thereis (and (= (* w x y z) product)
                           (list x y z w)))))))

(loop for tgt from 1 to 711 thereis (and (coins-sum-prod tgt) tgt))
;; 644

The earliest price with an answer is $6.44! (a little thought reveals it couldn’t be lower than $1.00 because otherwise the product of the prices would never be larger than the prices.

Let’s get the first 100 totals with this property:

(loop for tgt = 644 then (1+ tgt)
      when (coins-sum-prod tgt) collect tgt into ans
      when (= 100 (length ans)) return ans)
;; (644 651 660 663 665 672 675 678 680 684 686 689 693 702 705 707 708 711 713
;;  714 720 725 726 728 729 735 737 747 750 752 756 762 765 767 770 774 777 779
;;  780 782 783 786 792 800 801 803 810 812 816 819 822 825 828 833 836 837 840
;;  845 846 852 855 860 864 867 869 873 875 876 878 882 885 888 891 894 896 900
;;  902 903 912 918 920 923 924 927 935 936 938 945 948 954 957 959 960 962 963
;;  966 968 969 972 975)

A series of numbers caught my eye where the adjacent differences were 3,2,1,3,2,1… let’s look at the adjacent differences and see if there’s a pattern:

(mapcar #'- (cdr *) *)
;; (7 9 3 2 7 3 3 2 4 2 3 4 9 3 2 1 3 2 1 6 5 1 2 1 6 2 10 3 2 4 6 3 2 3 4 3 2 1 2
;;  1 3 6 8 1 2 7 2 4 3 3 3 3 5 3 1 3 5 1 6 3 5 4 3 2 4 2 1 2 4 3 3 3 3 2 4 2 1 9
;;  6 2 3 1 3 8 1 2 7 3 6 3 2 1 2 1 3 2 1 3 3)

Nope. Out of curiosity, what’s the mean adjacent difference?

(/ (apply #'+ *) (length *))
;; 331/99

(float *)
;; 3.3434343

Optimization

I recoded the solution in java, for comparison. In JAVA, the equivalent of this loop:

(time (loop for tgt from 1 to 800
            when (coins-sum-prod tgt) collect tgt))

… takes 1.8 seconds. SBCL takes 17.7 seconds. It’s a factor of 10 off. Ok, let’s try to speed this up by adding annotations until SBCL stops complaining about compromises:

(defun coins-sum-prod-opt (tgt)
  (declare (type fixnum tgt)
           (optimize (speed 3) (safety 0) (debug 0)))
  (let ((product (the fixnum (* tgt 100 100 100))))
    (declare (type fixnum product))
    (loop for x fixnum from 1
          while (<= x (the fixnum (- (the fixnum (- tgt x)) x x))) thereis
      (loop for y fixnum from x
            while (<= y (the fixnum (- (the fixnum (- tgt x)) y y))) thereis
        (loop for z fixnum from y
              while (<= z (the fixnum (- (the fixnum (- tgt x)) y z)))
              for w fixnum = (- (the fixnum (- tgt x)) y z)
              thereis (and (= (the fixnum (* (the fixnum (* (the fixnum (* w x)) y)) z))
                              product)
                           (list x y z w)))))))

Now it’s 2.5 seconds. Not bad. But those annotations… that’s really ugly. Let’s define a macro to put in all those (the fixnum …)’s…

(defmacro fixnum-math (op x &rest xs)
  (if (null xs)
      x
      `(fixnum-math ,op (the fixnum (,op ,x ,(car xs))) ,@(cdr xs))))

(defun coins-sum-prod-opt (tgt)
  (declare (type fixnum tgt)
           (optimize (speed 3) (safety 0) (debug 0)))
  (let ((product (the fixnum (* tgt 100 100 100))))
    (declare (type fixnum product))
    (loop for x fixnum from 1
          while (<= x (fixnum-math - tgt x x x)) thereis
      (loop for y fixnum from x
            while (<= y (fixnum-math - tgt x y y)) thereis
        (loop for z fixnum from y
              while (<= z (fixnum-math - tgt x y z))
              for w fixnum = (fixnum-math - tgt x y z)
              thereis (and (= (fixnum-math * w x y z) product)
                           (list x y z w)))))))

1.773 seconds, matching JAVA now. I guess putting (the fixnum...) between every single term really helps SBCL out.

Hmm… I notice there’s a redundant calculation of (- tgt x y z)… swap around the terms for w to only do it once…

(defun coins-sum-prod-opt (tgt)
  (declare (type fixnum tgt)
           (optimize (speed 3) (safety 0) (debug 0)))
  (let ((product (the fixnum (* tgt 100 100 100))))
    (declare (type fixnum product))
    (loop for x fixnum from 1
          while (<= x (fixnum-math - tgt x x x)) thereis
      (loop for y fixnum from x
            while (<= y (fixnum-math - tgt x y y)) thereis
        (loop for z fixnum from y
              for w fixnum = (fixnum-math - tgt x y z)
              while (<= z w)
              thereis (and (= (fixnum-math * w x y z) product)
                           (list x y z w)))))))

1.667 seconds. Better than java. great!