codepad

Language:

; aliquot sequences

(define (factors n)
  (define (last-pair xs) (if (null? (cdr xs)) xs (last-pair (cdr xs))))
  (define (cycle . xs) (set-cdr! (last-pair xs) xs) xs)
  (let ((wheel (cons 1 (cons 2 (cons 2 (cycle 4 2 4 2 4 6 2 6))))))
    (let loop ((n (abs n)) (f 2) (wheel wheel) (fs (list)))
      (cond ((< n (* f f)) (if (= n 1) fs (reverse (cons n fs))))
            ((zero? (modulo n f)) (loop (/ n f) f wheel (cons f fs)))
            (else (loop n (+ f (car wheel)) (cdr wheel) fs))))))

(define (sum-div n)
  (define (div f x) (/ (- (expt f (+ x 1)) 1) (- f 1)))
  (let ((fs (factors n)))
    (let loop ((f (car fs)) (fs (cdr fs)) (x 1) (s 1))
      (cond ((null? fs) (- (* s (div f x)) n))
            ((= (car fs) f) (loop f (cdr fs) (+ x 1) s))
            (else (loop (car fs) (cdr fs) 1 (* s (div f x))))))))

(define (aliquot n)
  (define (rotate xs)
    (if (= (car xs) (apply min xs)) xs
      (rotate (append (cdr xs) (list (car xs))))))
  (when verbose? (display n) (display ",0: ")
    (display n) (newline))
  (let loop ((s (sum-div n)) (ss (list n)) (k 1))
    (when verbose? (display n) (display ",")
      (display k) (display ": ") (display s) (newline))
    (cond ((= s 1) (car ss))
          ((member s ss) (rotate (member s (reverse ss))))
          (else (loop (sum-div s) (cons s ss) (+ k 1))))))

(define verbose? #t)

(display (aliquot 168)) (newline)
(display (aliquot 2856)) (newline)

Private [?]

Run code