; three-way minimum sum partitions
(define (take-while pred? xs)
(let loop ((xs xs) (ys '()))
(if (or (null? xs) (not (pred? (car xs))))
(reverse ys)
(loop (cdr xs) (cons (car xs) ys)))))
(define (sum xs) (apply + xs))
(define (factors n)
(let ((wheel (vector 1 2 2 4 2 4 2 4 6 2 6)))
(let loop ((n n) (f 2) (w 0) (fs (list)))
(if (< n (* f f)) (reverse (cons n fs))
(if (zero? (modulo n f))
(loop (/ n f) f w (cons f fs))
(loop n (+ f (vector-ref wheel w))
(if (= w 10) 3 (+ w 1)) fs))))))
(define (divisors n) ; divisors of n, including 1 and n
(let ((divs (list 1)))
(do ((fs (factors n) (cdr fs))) ((null? fs) (sort divs <))
(let ((temp (list)))
(do ((ds divs (cdr ds)))
((null? ds) (set! divs (append divs temp)))
(let ((d (* (car fs) (car ds))))
(when (not (member d divs))
(set! temp (cons d temp)))))))))
(define (iroot k n)
(let ((k-1 (- k 1)))
(let loop ((u n) (s (+ n 1)))
(if (<= s u) s
(loop (quotient (+ (* k-1 u) (quotient n (expt u k-1))) k) u)))))
(define (maxle n xs) ; assume xs in non-decreasing order
(let ((xs (take-while (lambda (x) (<= x n)) xs)))
(if (null? xs) #f (apply max xs))))
(define (f1 n)
(let ((xyz (list n n n)))
(do ((xs (divisors n) (cdr xs))) ((null? xs) (sort xyz <))
(do ((ys (divisors (/ n (car xs))) (cdr ys))) ((null? ys))
(let ((z (/ n (car xs) (car ys))))
(when (< (+ (car xs) (car ys) z) (sum xyz))
(set! xyz (list (car xs) (car ys) z))))))))
(define (f2 n)
(let* ((x (maxle (iroot 3 n) (divisors n)))
(y (maxle (iroot 2 (/ n x)) (divisors (/ n x))))
(z (/ n x y)))
(sort (list x y z) <)))
(define (f3 n)
(let* ((x1 (maxle (iroot 3 n) (divisors n)))
(y1 (maxle (iroot 2 (/ n x1)) (divisors (/ n x1))))
(z1 (/ n x1 y1))
(x2 (apply max (factors n)))
(y2 (maxle (iroot 2 (/ n x2)) (divisors (/ n x2))))
(z2 (/ n x2 y2)))
(if (< (+ x1 y1 z1) (+ x2 y2 z2))
(sort (list x1 y1 z1) <)
(sort (list x2 y2 z2) <))))
(display (f1 1890)) (newline)
(display (f2 1890)) (newline)
(display (f3 1890)) (newline)