fork download
copy 
  1. ; a divisor apology
  2.  
  3. (define (unique eql? xs)
  4.   (cond ((null? xs) '())
  5.         ((null? (cdr xs)) xs)
  6.         ((eql? (car xs) (cadr xs))
  7.           (unique eql? (cdr xs)))
  8.         (else (cons (car xs) (unique eql? (cdr xs))))))
  9.  
  10. (define (primes n) ; list of primes not exceeding n
  11.   (let* ((len (quotient (- n 1) 2)) (bits (make-vector len #t)))
  12.     (let loop ((i 0) (p 3) (ps (list 2)))
  13.       (cond ((< n (* p p))
  14.               (do ((i i (+ i 1)) (p p (+ p 2))
  15.                    (ps ps (if (vector-ref bits i) (cons p ps) ps)))
  16.                   ((= i len) (reverse ps))))
  17.             ((vector-ref bits i)
  18.               (do ((j (+ (* 2 i i) (* 6 i) 3) (+ j p)))
  19.                   ((<= len j) (loop (+ i 1) (+ p 2) (cons p ps)))
  20.                 (vector-set! bits j #f)))
  21.             (else (loop (+ i 1) (+ p 2) ps))))))
  22.  
  23. (define (factors n) ; 2,3,5-wheel
  24.   (let ((wheel (vector 1 2 2 4 2 4 2 4 6 2 6)))
  25.     (let loop ((n n) (f 2) (fs (list)) (w 0))
  26.       (if (< n (* f f)) (reverse (cons n fs))
  27.         (if (zero? (modulo n f))
  28.             (loop (/ n f) f (cons f fs) w)
  29.             (loop n (+ f (vector-ref wheel w)) fs
  30.                   (if (= w 10) 3 (+ w 1))))))))
  31.  
  32. (define (divisors1 n) ; divisors of n, including 1 and n
  33.   (let ((divs (list 1)))
  34.     (do ((fs (factors n) (cdr fs))) ((null? fs) (sort divs <))
  35.       (let ((temp (list)))
  36.         (do ((ds divs (cdr ds)))
  37.             ((null? ds) (set! divs (append divs temp)))
  38.           (let ((d (* (car fs) (car ds))))
  39.             (when (not (member d divs))
  40.               (set! temp (cons d temp)))))))))
  41.  
  42. (display (length (divisors1 (apply * (primes 25))))) (newline)
  43.  
  44. (define (divisors2 n)
  45.   (let ((divs (list 1)))
  46.     (do ((fs (factors n) (cdr fs)))
  47.         ((null? fs) (unique = (sort divs <)))
  48.       (set! divs (append (map (lambda (d) (* d (car fs))) divs) divs)))))
  49.  
  50. (display (length (divisors2 (apply * (primes 25))))) (newline)
  51.  
  52. (define (divisors3 n)
  53.   (let ((divs (list 1)))
  54.     (do ((fs (factors n) (cdr fs))) ((null? fs) divs)
  55.       (set! divs (unique = (sort
  56.         (append (map (lambda (d) (* d (car fs))) divs) divs) <))))))
  57.  
  58. (display (length (divisors3 (apply * (primes 25))))) (newline)
  59.  
  60. (define (merge-uniq xs ys)
  61.   (let loop ((xs xs) (ys ys) (zs (list)))
  62.     (cond ((and (null? xs) (null? ys)) (reverse zs))
  63.           ((null? xs) (loop xs (cdr ys) (cons (car ys) zs)))
  64.           ((null? ys) (loop (cdr xs) ys (cons (car xs) zs)))
  65.           ((< (car xs) (car ys)) (loop (cdr xs) ys (cons (car xs) zs)))
  66.           ((< (car ys) (car xs)) (loop xs (cdr ys) (cons (car ys) zs)))
  67.           (else (loop xs (cdr ys) zs)))))
  68.  
  69. (define (divisors4 n)
  70.   (let loop ((fs (factors n)) (divs (list 1)))
  71.     (if (null? fs) divs
  72.       (loop (cdr fs) (merge-uniq (map (lambda (d) (* d (car fs))) divs) divs)))))
  73.  
  74. (display (length (divisors4 (apply * (primes 25))))) (newline)
Success #stdin #stdout 0.06s 8952KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
512
512
512
512
https://ideone.com/8HI7m2
language:
Scheme (guile 2.2.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!