[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/TLMWMAkg    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Feb 15:
(define (divisors n)
  (let ((divs (make-vector (+ n 1) (list)))
        (cnts (make-vector (+ n 1) 0))
        (sums (make-vector (+ n 1) 0)))
    (do ((i 1 (+ i 1))) ((<= n i) (values divs cnts sums))
      (do ((j i (+ j i))) ((<= n j))
        (vector-set! divs j (cons i (vector-ref divs j)))
        (vector-set! cnts j (+ 1 (vector-ref cnts j)))
        (vector-set! sums j (+ i (vector-ref sums j)))))))

(define divs #f)
(define cnts #f)
(define sums #f)
(define max-d 0)

(define (update n)
  (call-with-values
    (lambda () (divisors n))
    (lambda (d c s)
      (set! divs d)
      (set! cnts c)
      (set! sums s)))
  (set! max-d n))

(define (perfect n)
  (define (s n) (- (vector-ref sums n) n))
  (let ((ps (list)))
    (do ((p 1 (+ p 1)))
        ((< n p) (reverse ps))
      (when (= p (s p))
        (set! ps (cons p ps))))))

(time (update 50000) (display "updated") (newline))

(time (display (perfect 10000)) (newline))

(define (amicable n)
  (define (s n) (- (vector-ref sums n) n))
  (let loop ((a 1) (as (list)))
    (cond ((< n a) (reverse as))
          ((and (= a (s (s a))) (< a (s a)))
            (loop (+ a 1) (cons a as)))
          (else (loop (+ a 1) as)))))

(time (display (amicable 10000)) (newline))


Output:
1
2
3
4
5
6
updated
cpu time: 80 real time: 1529 gc time: 20
(6 28 496 8128)
cpu time: 0 real time: 2 gc time: 0
(220 1184 2620 5020 6232)
cpu time: 0 real time: 3 gc time: 0


Create a new paste based on this one


Comments: