codepad

Language:

; amicable chains

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (divisors n)
  (let loop ((i 1) (ds (list)))
    (cond ((< n (+ i i)) (reverse ds))
          ((zero? (modulo n i))
            (loop (+ i 1) (cons i ds)))
          (else (loop (+ i 1) ds)))))

(display (divisors 220)) (newline)
(display (divisors 284)) (newline)
(display (divisors 36)) (newline)

(define (sum-div n)
  (let loop ((i 1) (s 0))
    (cond ((< n (+ i i)) s)
          ((zero? (modulo n i))
            (loop (+ i 1) (+ s i)))
          (else (loop (+ i 1) s)))))

(display (sum-div 220)) (newline)
(display (sum-div 284)) (newline)
(display (sum-div 36)) (newline)

(define (divisors n)
  (let loop ((i 2) (ds (list 1)))
    (cond ((<= n (* i i))
            (sort < (if (= n (* i i)) (cons i ds) ds)))
          ((zero? (modulo n i))
            (loop (+ i 1) (cons i (cons (/ n i) ds))))
          (else (loop (+ i 1) ds)))))

(define (sum-div n)
  (let loop ((i 2) (s 1))
    (cond ((<= n (* i i))
            (if (= n (* i i)) (+ i s) s))
          ((zero? (modulo n i))
            (loop (+ i 1) (+ s i (/ n i))))
          (else (loop (+ i 1) s)))))

(display (divisors 220)) (newline)
(display (divisors 284)) (newline)
(display (divisors 36)) (newline)
(display (sum-div 220)) (newline)
(display (sum-div 284)) (newline)
(display (sum-div 36)) (newline)

(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 (but-last xs)
  (if (null? xs) (error 'but-last "empty list")
    (reverse (cdr (reverse xs)))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs)) (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (power-set xs)
  (if (null? xs) (list (list))
    (let ((rest (power-set (cdr xs))))
      (append (map (lambda (x) (cons (car xs) x)) rest) rest))))

(define (divisors n)
  (but-last (unique = (sort <
    (map (lambda (xs) (apply * xs))
      (power-set (factors n)))))))

(display (divisors 220)) (newline)
(display (divisors 284)) (newline)
(display (divisors 36)) (newline)

(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))))))))

(display (sum-div 220)) (newline)
(display (sum-div 284)) (newline)
(display (sum-div 36)) (newline)

(define (perfect? n)
  (= n (sum-div n)))

(define (amicable? n)
  (let ((s (sum-div n)))
    (and (< 1 s) (= (sum-div s) n))))

(display (perfect? 6)) (newline)
(display (perfect? 28)) (newline)
(display (amicable? 220)) (newline)
(display (amicable? 284)) (newline)

(define (perfect limit)
  (let loop ((n 2) (ps (list)))
    (cond ((< limit n) (reverse ps))
          ((= n (sum-div n))
            (loop (+ n 1) (cons n ps)))
          (else (loop (+ n 1) ps)))))

(define (amicable limit)
  (let loop ((n 2) (as (list)))
    (if (< limit n) (reverse as)
      (let ((s (sum-div n)))
        (if (and (< n s) (= n (sum-div s)))
            (loop (+ n 1) (cons (list n s) as))
            (loop (+ n 1) as))))))

(display (perfect 10000)) (newline)
(display (amicable 10000)) (newline)

(define (make-sum-divs n)
  (let ((s (make-vector (+ n 1) 0)))
    (do ((i 1 (+ i 1))) ((< n i) s)
      (do ((j (+ i i) (+ j i))) ((< n j))
        (vector-set! s j (+ i (vector-ref s j)))))))

(define max-sum-div 1000)
(define sum-divs (make-sum-divs max-sum-div))

(define (perfect limit)
  (when (< max-sum-div limit)
    (set! max-sum-div limit)
    (set! sum-divs (make-sum-divs max-sum-div)))
  (let loop ((n 2) (ps (list)))
    (cond ((< limit n) (reverse ps))
          ((= n (vector-ref sum-divs n))
            (loop (+ n 1) (cons n ps)))
          (else (loop (+ n 1) ps)))))

(define (pairs limit)
  (when (< max-sum-div limit)
    (set! max-sum-div limit)
    (set! sum-divs (make-sum-divs max-sum-div)))
  (let loop ((n 2) (as (list)))
    (if (< limit n) (reverse as)
      (let ((s (vector-ref sum-divs n)))
        (if (and (< s max-sum-div) (< n s)
                 (= n (vector-ref sum-divs s)))
            (loop (+ n 1) (cons (list n s) as))
            (loop (+ n 1) as))))))

(display (perfect 1000000)) (newline)
(display (pairs 1000000)) (newline)

(define (chain n limit)
  (when (< max-sum-div limit)
    (set! max-sum-div limit)
    (set! sum-divs (make-sum-divs max-sum-div)))
  (let loop ((s (vector-ref sum-divs n)) (cs (list n)))
    (cond ((= s n) (reverse cs))
          ((not (< n s limit)) (list))
          ((member s cs) (list))
          (else (loop (vector-ref sum-divs s) (cons s cs))))))

(define (chains limit)
  (when (< max-sum-div limit)
    (set! max-sum-div limit)
    (set! sum-divs (make-sum-divs max-sum-div)))
  (let loop ((n 2) (cs (list)))
    (if (< limit n) (reverse cs)
      (let ((c (chain n limit)))
        (if (null? c) (loop (+ n 1) cs)
          (loop (+ n 1) (cons c cs)))))))

(display (sort (lambda (a b) (< (length a) (length b))) (chains 1000000)))

Private [?]

Run code