49 lines
1.4 KiB
Scheme
49 lines
1.4 KiB
Scheme
(import (scheme base)
|
|
(scheme inexact)
|
|
(scheme write)
|
|
(only (srfi 1) fold))
|
|
|
|
;; return a list of the proper-divisors of n
|
|
(define (proper-divisors n)
|
|
(let ((root (sqrt n)))
|
|
(let loop ((divisors (list 1))
|
|
(i 2))
|
|
(if (> i root)
|
|
divisors
|
|
(loop (if (zero? (modulo n i))
|
|
(if (= (square i) n)
|
|
(cons i divisors)
|
|
(append (list i (quotient n i)) divisors))
|
|
divisors)
|
|
(+ 1 i))))))
|
|
|
|
(define (sum-proper-divisors n)
|
|
(if (< n 2)
|
|
0
|
|
(fold + 0 (proper-divisors n))))
|
|
|
|
(define *max-n* 20000)
|
|
|
|
;; hold sums of proper divisors in a cache, to avoid recalculating
|
|
(define *cache* (make-vector (+ 1 *max-n*)))
|
|
(for-each (lambda (i) (vector-set! *cache* i (sum-proper-divisors i)))
|
|
(iota *max-n* 1))
|
|
|
|
(define (amicable-pair? i j)
|
|
(and (not (= i j))
|
|
(= i (vector-ref *cache* j))
|
|
(= j (vector-ref *cache* i))))
|
|
|
|
;; double loop to *max-n*, displaying all amicable pairs
|
|
(let loop-i ((i 1))
|
|
(when (<= i *max-n*)
|
|
(let loop-j ((j i))
|
|
(when (<= j *max-n*)
|
|
(when (amicable-pair? i j)
|
|
(display (string-append "Amicable pair: "
|
|
(number->string i)
|
|
" "
|
|
(number->string j)))
|
|
(newline))
|
|
(loop-j (+ 1 j))))
|
|
(loop-i (+ 1 i))))
|