[ create a new paste ] login | about

Link: http://codepad.org/fujimea2    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on May 19:
; 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)))


Output:
(1 2 4 5 10 11 20 22 44 55 110)
(1 2 4 71 142)
(1 2 3 4 6 9 12 18)
284
220
55
(1 2 4 5 10 11 20 22 44 55 110)
(1 2 4 71 142)
(1 2 3 4 6 9 12 18)
284
220
55
(1 2 4 5 10 11 20 22 44 55 110)
(1 2 4 71 142)
(1 2 3 4 6 9 12 18)
284
220
55
#t
#t
#t
#t
(6 28 496 8128)
((220 284) (1184 1210) (2620 2924) (5020 5564) (6232 6368))
(6 28 496 8128)
((220 284) (1184 1210) (2620 2924) (5020 5564) (6232 6368) (10744 10856) (12285 14595) (17296 18416) (63020 76084) (66928 66992) (67095 71145) (69615 87633) (79750 88730) (100485 124155) (122265 139815) (122368 123152) (141664 153176) (142310 168730) (171856 176336) (176272 180848) (185368 203432) (196724 202444) (280540 365084) (308620 389924) (319550 430402) (356408 399592) (437456 455344) (469028 486178) (503056 514736) (522405 525915) (600392 669688) (609928 686072) (624184 691256) (635624 712216) (643336 652664) (667964 783556) (726104 796696) (802725 863835) (879712 901424) (898216 980984))
((6) (28) (496) (8128) (220 284) (1184 1210) (2620 2924) (5020 5564) (6232 6368) (10744 10856) (12285 14595) (17296 18416) (63020 76084) (66928 66992) (67095 71145) (69615 87633) (79750 88730) (100485 124155) (122265 139815) (122368 123152) (141664 153176) (142310 168730) (171856 176336) (176272 180848) (185368 203432) (196724 202444) (280540 365084) (308620 389924) (319550 430402) (356408 399592) (437456 455344) (469028 486178) (503056 514736) (522405 525915) (600392 669688) (609928 686072) (624184 691256) (635624 712216) (643336 652664) (667964 783556) (726104 796696) (802725 863835) (879712 901424) (898216 980984) (12496 14288 15472 14536 14264) (14316 19116 31704 47616 83328 177792 295488 629072 589786 294896 358336 418904 366556 274924 275444 243760 376736 381028 285778 152990 122410 97946 48976 45946 22976 22744 19916 17716))


Create a new paste based on this one


Comments: