; perfect power sequence (https://o...content-available-to-author-only...s.org/A001597)
(import (rnrs records syntactic (6)))
(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-take n gen)
(let loop ((n n) (xs (list)))
(if (zero? n) (reverse xs)
(loop (- n 1) (cons (gen) xs)))))
(define pq-empty (list))
(define pq-empty? null?)
(define (pq-first pq)
(if (null? pq)
(error 'pq-first "can't extract minimum from null queue")
(car pq)))
(define (pq-merge lt? p1 p2)
(cond ((null? p1) p2)
((null? p2) p1)
((lt? (car p2) (car p1))
(cons (car p2) (cons p1 (cdr p2))))
(else (cons (car p1) (cons p2 (cdr p1))))))
(define (pq-insert lt? x pq)
(pq-merge lt? (list x) pq))
(define (pq-merge-pairs lt? ps)
(cond ((null? ps) '())
((null? (cdr ps)) (car ps))
(else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
(pq-merge-pairs lt? (cddr ps))))))
(define (pq-rest lt? pq)
(if (null? pq)
(error 'pq-rest "can't delete minimum from null queue")
(pq-merge-pairs lt? (cdr pq))))
(define-generator (powers)
(define-record-type power (fields val base expo))
(define (lt? a b) (< (power-val a) (power-val b)))
(yield 1)
(let loop ((pq (pq-insert lt? (make-power (expt 2 2) 2 2) pq-empty)) (m 3) (limit (expt 2 3)) (prev 0))
(if (and (not (pq-empty? pq)) (<= (power-val (pq-first pq)) limit))
(let* ((p (pq-first pq)) (val (power-val p)) (base (power-base p)) (expo (power-expo p)) (pq (pq-rest lt? pq)))
(when (and (not (= val prev)) (not (= val limit))) (yield val))
(loop (pq-insert lt? (make-power (expt (+ base 1) expo) (+ base 1) expo) pq) m limit val))
(loop (pq-insert lt? (make-power (expt 2 m) 2 m) pq) (+ m 1) (expt 2 (+ m 1)) (power-val (pq-first pq))))))
(display (generator-take 54 (powers))) (newline)