fork(1) download
copy 
  1. ; perfect power sequence (https://o...content-available-to-author-only...s.org/A001597)
  2.  
  3. (import (rnrs records syntactic (6)))
  4.  
  5. (define-syntax define-generator
  6.   (lambda (x)
  7.     (syntax-case x (lambda)
  8.       ((stx name (lambda formals e0 e1 ...))
  9.          (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
  10.            (syntax (define name
  11.              (lambda formals
  12.                (let ((resume #f) (return #f))
  13.                  (define yield
  14.                    (lambda args
  15.                      (call-with-current-continuation
  16.                       (lambda (cont)
  17.                         (set! resume cont)
  18.                         (apply return args)))))
  19.                  (lambda ()
  20.                    (call-with-current-continuation
  21.                     (lambda (cont)
  22.                       (set! return cont)
  23.                       (cond (resume (resume))
  24.                       (else (let () e0 e1 ...)
  25.                             (error 'name "unexpected return"))))))))))))
  26.         ((stx (name . formals) e0 e1 ...)
  27.           (syntax (stx name (lambda formals e0 e1 ...)))))))
  28.  
  29. (define (generator-take n gen)
  30.   (let loop ((n n) (xs (list)))
  31.     (if (zero? n) (reverse xs)
  32.       (loop (- n 1) (cons (gen) xs)))))
  33.  
  34. (define pq-empty (list))
  35.  
  36. (define pq-empty? null?)
  37.  
  38. (define (pq-first pq)
  39.   (if (null? pq)
  40.       (error 'pq-first "can't extract minimum from null queue")
  41.       (car pq)))
  42.  
  43. (define (pq-merge lt? p1 p2)
  44.   (cond ((null? p1) p2)
  45.         ((null? p2) p1)
  46.         ((lt? (car p2) (car p1))
  47.           (cons (car p2) (cons p1 (cdr p2))))
  48.         (else (cons (car p1) (cons p2 (cdr p1))))))
  49.  
  50. (define (pq-insert lt? x pq)
  51.   (pq-merge lt? (list x) pq))
  52.  
  53. (define (pq-merge-pairs lt? ps)
  54.   (cond ((null? ps) '())
  55.         ((null? (cdr ps)) (car ps))
  56.         (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
  57.                             (pq-merge-pairs lt? (cddr ps))))))
  58.  
  59. (define (pq-rest lt? pq)
  60.   (if (null? pq)
  61.       (error 'pq-rest "can't delete minimum from null queue")
  62.       (pq-merge-pairs lt? (cdr pq))))
  63.  
  64. (define-generator (powers)
  65.   (define-record-type power (fields val base expo))
  66.   (define (lt? a b) (< (power-val a) (power-val b)))
  67.   (yield 1)
  68.   (let loop ((pq (pq-insert lt? (make-power (expt 2 2) 2 2) pq-empty)) (m 3) (limit (expt 2 3)) (prev 0))
  69.     (if (and (not (pq-empty? pq)) (<= (power-val (pq-first pq)) limit))
  70.         (let* ((p (pq-first pq)) (val (power-val p)) (base (power-base p)) (expo (power-expo p)) (pq (pq-rest lt? pq)))
  71.           (when (and (not (= val prev)) (not (= val limit))) (yield val))
  72.           (loop (pq-insert lt? (make-power (expt (+ base 1) expo) (+ base 1) expo) pq) m limit val))
  73.         (loop (pq-insert lt? (make-power (expt 2 m) 2 m) pq) (+ m 1) (expt 2 (+ m 1)) (power-val (pq-first pq))))))
  74.  
  75. (display (generator-take 54 (powers))) (newline)
Success #stdin #stdout 0.05s 46528KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(1 4 8 9 16 25 27 32 36 49 64 81 100 121 125 128 144 169 196 216 225 243 256 289 324 343 361 400 441 484 512 529 576 625 676 729 784 841 900 961 1000 1024 1089 1156 1225 1296 1331 1369 1444 1521 1600 1681 1728 1764)
https://ideone.com/XvXveK
language:
Scheme (guile 2.2.4)
created:
5 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!