fork download
copy 
  1. ; nearly square divisor, meet in the middle
  2.  
  3. (define (take n xs)
  4.   (let loop ((n n) (xs xs) (ys '()))
  5.     (if (or (zero? n) (null? xs))
  6.         (reverse ys)
  7.         (loop (- n 1) (cdr xs)
  8.               (cons (car xs) ys)))))
  9.  
  10. (define (drop n xs)
  11.   (let loop ((n n) (xs xs))
  12.     (if (or (zero? n) (null? xs)) xs
  13.       (loop (- n 1) (cdr xs)))))
  14.  
  15. (define (isqrt n)
  16.   (if (not (and (positive? n) (integer? n)))
  17.       (error 'isqrt "must be positive integer")
  18.       (let loop ((x n))
  19.         (let ((y (quotient (+ x (quotient n x)) 2)))
  20.           (if (< y x) (loop y) x)))))
  21.  
  22. (define (primes n) ; list of primes not exceeding n
  23.   (let* ((len (quotient (- n 1) 2)) (bits (make-vector len #t)))
  24.     (let loop ((i 0) (p 3) (ps (list 2)))
  25.       (cond ((< n (* p p))
  26.               (do ((i i (+ i 1)) (p p (+ p 2))
  27.                    (ps ps (if (vector-ref bits i) (cons p ps) ps)))
  28.                   ((= i len) (reverse ps))))
  29.             ((vector-ref bits i)
  30.               (do ((j (+ (* 2 i i) (* 6 i) 3) (+ j p)))
  31.                   ((<= len j) (loop (+ i 1) (+ p 2) (cons p ps)))
  32.                 (vector-set! bits j #f)))
  33.             (else (loop (+ i 1) (+ p 2) ps))))))
  34.  
  35. (define (factors n) ; 2,3,5-wheel
  36.   (let ((wheel (vector 1 2 2 4 2 4 2 4 6 2 6)))
  37.     (let loop ((n n) (f 2) (fs (list)) (w 0))
  38.       (if (< n (* f f)) (reverse (cons n fs))
  39.         (if (zero? (modulo n f))
  40.             (loop (/ n f) f (cons f fs) w)
  41.             (loop n (+ f (vector-ref wheel w)) fs
  42.                   (if (= w 10) 3 (+ w 1))))))))
  43.  
  44. (define (merge-uniq xs ys)
  45.   (let loop ((xs xs) (ys ys) (zs (list)))
  46.     (cond ((and (null? xs) (null? ys)) (reverse zs))
  47.           ((null? xs) (loop xs (cdr ys) (cons (car ys) zs)))
  48.           ((null? ys) (loop (cdr xs) ys (cons (car xs) zs)))
  49.           ((< (car xs) (car ys)) (loop (cdr xs) ys (cons (car xs) zs)))
  50.           ((< (car ys) (car xs)) (loop xs (cdr ys) (cons (car ys) zs)))
  51.           (else (loop xs (cdr ys) zs)))))
  52.  
  53. (define (divisors n)
  54.   (let loop ((fs (factors n)) (divs (list 1)))
  55.     (if (null? fs) divs
  56.       (loop (cdr fs) (merge-uniq (map (lambda (d) (* d (car fs))) divs) divs)))))
  57.  
  58. (define (nsd n)
  59.   (let* ((limit (isqrt n))
  60.          (fs (factors n))
  61.          (mid (quotient (length fs) 2))
  62.          (los (divisors (apply * (take mid fs))))
  63.          (his (reverse (divisors (apply * (drop mid fs))))))
  64.     (let loop ((i 0) (best 0) (los los) (his his))
  65.       (if (or (null? los) (null? his)) best
  66.         (let ((t (* (car los) (car his))))
  67.           (cond ((< limit t) (loop (+ i 1) best los (cdr his)))
  68.                 ((< best t) (loop (+ i 1) t (cdr los) his))
  69.                 (else (loop (+ i 1) best (cdr los) his))))))))
  70.  
  71. (define (primorial-nsd n)
  72.   (let ((p 1))
  73.     (do ((ps (primes n) (cdr ps))
  74.          (i 1 (+ i 1)))
  75.         ((null? ps))
  76.       (set! p (* p (car ps)))
  77.       (display i) (display ": ")
  78.       (display (nsd p)) (newline))))
  79.  
  80. (primorial-nsd 100)
Success #stdin #stdout 1.54s 10272KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
1: 1
2: 2
3: 5
4: 14
5: 42
6: 165
7: 714
8: 3094
9: 14858
10: 79534
11: 447051
12: 2714690
13: 17395070
14: 114371070
15: 783152070
16: 5708587335
17: 43848093003
18: 342444658094
19: 2803119896185
20: 23619540863730
21: 201813981102615
22: 1793779293633437
23: 16342050964565645
24: 154170926013430326
25: 1518409177581024365
https://ideone.com/V0KZDB
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!