codepad

Language:

; 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 (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(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 (fact2? ab)
  (not (singleton? (good-summands (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? fact2? fact3? fact4? fact5?))))

(display result)

Private [?]

Run code