fork download
copy 
  1. ; three-way minimum sum partitions
  2.  
  3. (define (take-while pred? xs)
  4.   (let loop ((xs xs) (ys '()))
  5.     (if (or (null? xs) (not (pred? (car xs))))
  6.         (reverse ys)
  7.         (loop (cdr xs) (cons (car xs) ys)))))
  8.  
  9. (define (sum xs) (apply + xs))
  10.  
  11. (define (factors n)
  12.   (let ((wheel (vector 1 2 2 4 2 4 2 4 6 2 6)))
  13.     (let loop ((n n) (f 2) (w 0) (fs (list)))
  14.       (if (< n (* f f)) (reverse (cons n fs))
  15.         (if (zero? (modulo n f))
  16.           (loop (/ n f) f w (cons f fs))
  17.           (loop n (+ f (vector-ref wheel w))
  18.                   (if (= w 10) 3 (+ w 1)) fs))))))
  19.  
  20. (define (divisors n) ; divisors of n, including 1 and n
  21.   (let ((divs (list 1)))
  22.     (do ((fs (factors n) (cdr fs))) ((null? fs) (sort divs <))
  23.       (let ((temp (list)))
  24.         (do ((ds divs (cdr ds)))
  25.             ((null? ds) (set! divs (append divs temp)))
  26.           (let ((d (* (car fs) (car ds))))
  27.             (when (not (member d divs))
  28.             (set! temp (cons d temp)))))))))
  29.  
  30. (define (iroot k n)
  31.   (let ((k-1 (- k 1)))
  32.     (let loop ((u n) (s (+ n 1)))
  33.       (if (<= s u) s
  34.         (loop (quotient (+ (* k-1 u) (quotient n (expt u k-1))) k) u)))))
  35.  
  36. (define (maxle n xs) ; assume xs in non-decreasing order
  37.   (let ((xs (take-while (lambda (x) (<= x n)) xs)))
  38.     (if (null? xs) #f (apply max xs))))
  39.  
  40. (define (f1 n)
  41.   (let ((xyz (list n n n)))
  42.     (do ((xs (divisors n) (cdr xs))) ((null? xs) (sort xyz <))
  43.       (do ((ys (divisors (/ n (car xs))) (cdr ys))) ((null? ys))
  44.         (let ((z (/ n (car xs) (car ys))))
  45.           (when (< (+ (car xs) (car ys) z) (sum xyz))
  46.             (set! xyz (list (car xs) (car ys) z))))))))
  47.  
  48. (define (f2 n)
  49.   (let* ((x (maxle (iroot 3 n) (divisors n)))
  50.          (y (maxle (iroot 2 (/ n x)) (divisors (/ n x))))
  51.          (z (/ n x y)))
  52.     (sort (list x y z) <)))
  53.  
  54. (define (f3 n)
  55.   (let* ((x1 (maxle (iroot 3 n) (divisors n)))
  56.          (y1 (maxle (iroot 2 (/ n x1)) (divisors (/ n x1))))
  57.          (z1 (/ n x1 y1))
  58.          (x2 (apply max (factors n)))
  59.          (y2 (maxle (iroot 2 (/ n x2)) (divisors (/ n x2))))
  60.          (z2 (/ n x2 y2)))
  61.     (if (< (+ x1 y1 z1) (+ x2 y2 z2))
  62.         (sort (list x1 y1 z1) <)
  63.         (sort (list x2 y2 z2) <))))
  64.  
  65. (display (f1 1890)) (newline)
  66. (display (f2 1890)) (newline)
  67. (display (f3 1890)) (newline)
Success #stdin #stdout 0s 8236KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(9 14 15)
(9 10 21)
(7 15 18)
https://ideone.com/wV0vHJ
language:
Scheme (chicken 4.13)
created:
4 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!