; ruth-aaron pairs
(import (rnrs hashtables (6)))
(define (range . args)
(case (length args)
((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
((3) (let ((le? (if (negative? (caddr args)) >= <=)))
(let loop ((x(car args)) (xs '()))
(if (le? (cadr args) x)
(reverse xs)
(loop (+ x (caddr args)) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define (sum xs) (apply + 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 (isqrt n)
(if (not (and (positive? n) (integer? n)))
(error 'isqrt "must be positive integer")
(let loop ((x n))
(let ((y (quotient (+ x (quotient n x)) 2)))
(if (< y x) (loop y) x)))))
(define-syntax while
(syntax-rules ()
((while pred? body ...)
(do () ((not pred?)) body ...))))
(define (identity x) x)
(define-syntax define-generator
(lambda (x)
(syntax-case x (lambda)
((stx name (lambda formals e0 e1 ...))
(with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
(syntax (define name
(lambda formals
(let ((resume #f) (return #f))
(define yield
(lambda args
(call-with-current-continuation
(lambda (cont)
(set! resume cont)
(apply return args)))))
(lambda ()
(call-with-current-continuation
(lambda (cont)
(set! return cont)
(cond (resume (resume))
(else (let () e0 e1 ...)
(error 'name "unexpected return"))))))))))))
((stx (name . formals) e0 e1 ...)
(syntax (stx name (lambda formals e0 e1 ...)))))))
(define-generator (primegen)
(yield 2) (yield 3)
(let* ((ps (primegen))
(p (and (ps) (ps)))
(q (* p p))
(d (make-hashtable identity =)))
(define (add x s)
(while (hashtable-contains? d x)
(set! x (+ x s)))
(hashtable-set! d x s))
(do ((c (+ p 2) (+ c 2))) (#f)
(cond ((hashtable-contains? d c)
(let ((s (hashtable-ref d c #f)))
(hashtable-delete! d c)
(add (+ c s) s)))
((< c q) (yield c))
(else (add (+ c p p) (+ p p))
(set! p (ps))
(set! q (* p p)))))))
(define (factors n)
(let ((wheel '#(1 2 2 4 2 4 2 4 6 2 6)))
(let loop ((n n) (f 2) (fs (list)) (w 0))
(if (< n (* f f)) (reverse (cons n fs))
(if (zero? (modulo n f))
(loop (/ n f) f (cons f fs) w)
(loop n (+ f (vector-ref wheel w)) fs
(if (= w 10) 3 (+ w 1))))))))
(define (ruth-aaron-multiplicative limit)
(let ((ps (primegen)))
(let loop ((primorial 1))
(when (< primorial limit)
(let ((x (isqrt primorial)))
(when (= (* x (+ x 1)) primorial)
(display (list x (+ x 1))) (newline))
(loop (* primorial (ps))))))))
(ruth-aaron-multiplicative 520000)
(define (ruth-aaron-additive-repeating limit)
(let loop ((n 1) (fs (factors 1)) (sum-fs (sum (factors 1))))
(when (< n limit)
(let* ((n+1 (+ n 1)) (fs+1 (factors n+1)) (sum-fs+1 (sum fs+1)))
(when (= sum-fs sum-fs+1) (display (list n (+ n 1))) (newline))
(loop n+1 fs+1 sum-fs+1)))))
(ruth-aaron-additive-repeating 720)
(define (ruth-aaron-additive-distinct limit)
(let loop ((n 1) (fs (factors 1)) (sum-fs (sum (unique = (factors 1)))))
(when (< n limit)
(let* ((n+1 (+ n 1)) (fs+1 (factors n+1)) (sum-fs+1 (sum (unique = fs+1))))
(when (= sum-fs sum-fs+1) (display (list n (+ n 1))) (newline))
(loop n+1 fs+1 sum-fs+1)))))
(ruth-aaron-additive-distinct 720)