; mr s and mr p

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define (all? pred? xs)
  (cond ((null? xs) #t)
        ((pred? (car xs))
          (all? pred? (cdr xs)))
        (else #f)))

(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 good-nums (range 2 100))

(define good-factors-table
  (let ((gf (lambda (p)
         (list-of (list a b)
           (a in good-nums)
           (b in good-nums)
           (>= a b)
           (= p (* a b))))))
    (map gf (range 0 10000))))

(define (good-factors p)
  (list-ref good-factors-table p))

(define good-summands-table
  (let ((gs (lambda (s)
         (list-of (list a b)
           (a in good-nums)
           (b in good-nums)
           (>= a b)
           (= s (+ a b))))))
    (map gs (range 0 10000))))

(define (good-summands s)
  (list-ref good-summands-table s))

(define (singleton? xs)
  (and (pair? xs) (null? (cdr xs))))

(define (fact1? ab)
  (not (singleton? (good-factors (apply * ab)))))

(define (fact3? ab)
  (all? fact1? (good-summands (apply + ab))))

(define (fact4? ab)
  (singleton? (filter fact3? (good-factors (apply * ab)))))

(define (fact5? ab)
  (singleton? (filter fact4? (good-summands (apply + ab)))))

(define result
  (list-of (list a b)
    (a in good-nums)
    (b in good-nums)
    (>= a b)
    (all? (lambda (pred?) (pred? (list a b)))
          (list fact1? fact3? fact4? fact5?))))

(display result)

Timeout