fork download
copy 
  1. ; ruth-aaron pairs
  2.  
  3. (import (rnrs hashtables (6)))
  4.  
  5. (define (range . args)
  6.   (case (length args)
  7.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  8.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  9.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  10.            (let loop ((x(car args)) (xs '()))
  11.              (if (le? (cadr args) x)
  12.                  (reverse xs)
  13.                  (loop (+ x (caddr args)) (cons x xs))))))
  14.     (else (error 'range "unrecognized arguments"))))
  15.  
  16. (define (sum xs) (apply + xs))
  17.  
  18. (define (unique eql? xs)
  19.   (cond ((null? xs) '())
  20.         ((null? (cdr xs)) xs)
  21.         ((eql? (car xs) (cadr xs))
  22.           (unique eql? (cdr xs)))
  23.         (else (cons (car xs) (unique eql? (cdr xs))))))
  24.  
  25. (define (isqrt n)
  26.   (if (not (and (positive? n) (integer? n)))
  27.       (error 'isqrt "must be positive integer")
  28.       (let loop ((x n))
  29.         (let ((y (quotient (+ x (quotient n x)) 2)))
  30.           (if (< y x) (loop y) x)))))
  31.  
  32. (define-syntax while
  33.   (syntax-rules ()
  34.     ((while pred? body ...)
  35.       (do () ((not pred?)) body ...))))
  36.  
  37. (define (identity x) x)
  38.  
  39. (define-syntax define-generator
  40.   (lambda (x)
  41.     (syntax-case x (lambda)
  42.       ((stx name (lambda formals e0 e1 ...))
  43.          (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
  44.            (syntax (define name
  45.              (lambda formals
  46.                (let ((resume #f) (return #f))
  47.                  (define yield
  48.                    (lambda args
  49.                      (call-with-current-continuation
  50.                       (lambda (cont)
  51.                         (set! resume cont)
  52.                         (apply return args)))))
  53.                  (lambda ()
  54.                    (call-with-current-continuation
  55.                     (lambda (cont)
  56.                       (set! return cont)
  57.                       (cond (resume (resume))
  58.                       (else (let () e0 e1 ...)
  59.                             (error 'name "unexpected return"))))))))))))
  60.         ((stx (name . formals) e0 e1 ...)
  61.           (syntax (stx name (lambda formals e0 e1 ...)))))))
  62.  
  63. (define-generator (primegen)
  64.   (yield 2) (yield 3)
  65.   (let* ((ps (primegen))
  66.          (p (and (ps) (ps)))
  67.          (q (* p p))
  68.          (d (make-hashtable identity =)))
  69.     (define (add x s)
  70.       (while (hashtable-contains? d x)
  71.         (set! x (+ x s)))
  72.       (hashtable-set! d x s))
  73.     (do ((c (+ p 2) (+ c 2))) (#f)
  74.       (cond ((hashtable-contains? d c)
  75.               (let ((s (hashtable-ref d c #f)))
  76.                 (hashtable-delete! d c)
  77.                 (add (+ c s) s)))
  78.             ((< c q) (yield c))
  79.             (else (add (+ c p p) (+ p p))
  80.                   (set! p (ps))
  81.                   (set! q (* p p)))))))
  82.  
  83. (define (factors n)
  84.   (let ((wheel '#(1 2 2 4 2 4 2 4 6 2 6)))
  85.     (let loop ((n n) (f 2) (fs (list)) (w 0))
  86.       (if (< n (* f f)) (reverse (cons n fs))
  87.         (if (zero? (modulo n f))
  88.             (loop (/ n f) f (cons f fs) w)
  89.             (loop n (+ f (vector-ref wheel w)) fs
  90.                   (if (= w 10) 3 (+ w 1))))))))
  91.  
  92. (define (ruth-aaron-multiplicative limit)
  93.  (let ((ps (primegen)))
  94.     (let loop ((primorial 1))
  95.       (when (< primorial limit)
  96.         (let ((x (isqrt primorial)))
  97.           (when (= (* x (+ x 1)) primorial)
  98.             (display (list x (+ x 1))) (newline))
  99.           (loop (* primorial (ps))))))))
  100.  
  101. (ruth-aaron-multiplicative 520000)
  102.  
  103. (define (ruth-aaron-additive-repeating limit)
  104.   (let loop ((n 1) (fs (factors 1)) (sum-fs (sum (factors 1))))
  105.     (when (< n limit)
  106.       (let* ((n+1 (+ n 1)) (fs+1 (factors n+1)) (sum-fs+1 (sum fs+1)))
  107.         (when (= sum-fs sum-fs+1) (display (list n (+ n 1))) (newline))
  108.           (loop n+1 fs+1 sum-fs+1)))))
  109.  
  110. (ruth-aaron-additive-repeating 720)
  111.  
  112. (define (ruth-aaron-additive-distinct limit)
  113.   (let loop ((n 1) (fs (factors 1)) (sum-fs (sum (unique = (factors 1)))))
  114.     (when (< n limit)
  115.       (let* ((n+1 (+ n 1)) (fs+1 (factors n+1)) (sum-fs+1 (sum (unique = fs+1))))
  116.         (when (= sum-fs sum-fs+1) (display (list n (+ n 1))) (newline))
  117.           (loop n+1 fs+1 sum-fs+1)))))
  118.  
  119. (ruth-aaron-additive-distinct 720)
Success #stdin #stdout 0.15s 45408KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(1 2)
(2 3)
(5 6)
(14 15)
(714 715)
(5 6)
(8 9)
(15 16)
(77 78)
(125 126)
(714 715)
(5 6)
(24 25)
(49 50)
(77 78)
(104 105)
(153 154)
(369 370)
(492 493)
(714 715)
https://ideone.com/1GBZ1C
language:
Scheme (guile 2.2.4)
created:
6 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!