fork(2) download
copy 
  1. ; 357 numbers
  2.  
  3. (define-syntax while
  4.   (syntax-rules ()
  5.     ((while pred? body ...)
  6.       (do () ((not pred?)) body ...))))
  7.  
  8. (define (range . args)
  9.   (case (length args)
  10.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  11.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  12.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  13.            (let loop ((x(car args)) (xs '()))
  14.              (if (le? (cadr args) x)
  15.                  (reverse xs)
  16.                  (loop (+ x (caddr args)) (cons x xs))))))
  17.     (else (error 'range "unrecognized arguments"))))
  18.  
  19. (define (filter pred? xs)
  20.   (let loop ((xs xs) (ys '()))
  21.     (cond ((null? xs) (reverse ys))
  22.           ((pred? (car xs))
  23.             (loop (cdr xs) (cons (car xs) ys)))
  24.           (else (loop (cdr xs) ys)))))
  25.  
  26. (define (357? n)
  27.   (while (zero? (modulo n 3)) (set! n (/ n 3)))
  28.   (while (zero? (modulo n 5)) (set! n (/ n 5)))
  29.   (while (zero? (modulo n 7)) (set! n (/ n 7)))
  30.   (= n 1))
  31.  
  32. (define (list357 n) (filter 357? (range 1 n 2)))
  33.  
  34. (time (display (length (list357 1000000))))
  35. (newline)
  36.  
  37. (define pq-empty '())
  38. (define pq-empty? null?)
  39.  
  40. (define (pq-first pq)
  41.   (if (null? pq)
  42.       (error 'pq-first "can't extract minimum from null queue")
  43.       (car pq)))
  44.  
  45. (define (pq-merge lt? p1 p2)
  46.   (cond ((null? p1) p2)
  47.         ((null? p2) p1)
  48.         ((lt? (car p2) (car p1))
  49.           (cons (car p2) (cons p1 (cdr p2))))
  50.         (else (cons (car p1) (cons p2 (cdr p1))))))
  51.  
  52. (define (pq-insert lt? x pq)
  53.   (pq-merge lt? (list x) pq))
  54.  
  55. (define (pq-merge-pairs lt? ps)
  56.   (cond ((null? ps) '())
  57.         ((null? (cdr ps)) (car ps))
  58.         (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
  59.                             (pq-merge-pairs lt? (cddr ps))))))
  60.  
  61. (define (pq-rest lt? pq)
  62.   (if (null? pq)
  63.       (error 'pq-rest "can't delete minimum from null queue")
  64.       (pq-merge-pairs lt? (cdr pq))))
  65.  
  66. (define (list357 n)
  67.   (let ((pq (pq-insert < 1 pq-empty)))
  68.     (let loop ((357s (list)))
  69.       (if (pq-empty? pq) (reverse 357s)
  70.         (let ((x (pq-first pq)))
  71.           (while (and (not (pq-empty? pq))
  72.                       (= (pq-first pq) x))
  73.             (set! pq (pq-rest < pq)))
  74.           (when (< (* 3 x) n)
  75.             (set! pq (pq-insert < (* 3 x) pq)))
  76.           (when (< (* 5 x) n)
  77.             (set! pq (pq-insert < (* 5 x) pq)))
  78.           (when (< (* 7 x) n)
  79.             (set! pq (pq-insert < (* 7 x) pq)))
  80.           (loop (cons x 357s)))))))
  81.  
  82. (time (display (length (list357 1000000))))
Success #stdin #stdout #stderr 10.11s 12656KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
203
203
stderr
copy 
10.059s CPU time, 2.668s GC time (major), 9000022 mutations, 108/70373 GCs (major/minor)
0.01s CPU time, 2133 mutations, 0/104 GCs (major/minor)
https://ideone.com/YwnAQ8
language:
()
created:
9 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!