fork(7) download
copy 
  1. ; prime string
  2.  
  3. (define (make-hash hash eql? oops size)
  4.   (define (delete x xs)
  5.     (let loop ((xs xs) (zs (list)))
  6.       (cond ((null? xs) zs)
  7.             ((eql? (caar xs) x) (loop (cdr xs) zs))
  8.             (else (loop (cdr xs) (cons (car xs) zs))))))
  9.   (define (lookup x xs)
  10.     (cond ((null? xs) oops)
  11.           ((eql? x (caar xs)) (cdar xs))
  12.           (else (lookup x (cdr xs)))))
  13.   (let ((table (make-vector size '())))
  14.     (lambda (message key . val)
  15.       (let* ((index (modulo (hash key) size))
  16.              (alist (vector-ref table index)))
  17.         (case message
  18.           ((show) (do ((i 0 (+ i 1))) ((= i size))
  19.                     (display i) (display " ")
  20.                     (display (vector-ref table i))
  21.                     (newline)))
  22.           ((insert!) (vector-set! table index
  23.             (cons (cons key (car val)) alist)))
  24.           ((delete!) (vector-set! table index
  25.             (delete key alist)))
  26.           ((lookup) (lookup key alist)))))))
  27.  
  28. (define-syntax while
  29.   (syntax-rules ()
  30.     ((while pred? body ...)
  31.       (do () ((not pred?)) body ...))))
  32.  
  33. (define (identity x) x)
  34.  
  35. (define-syntax define-generator
  36.   (lambda (x)
  37.     (syntax-case x (lambda)
  38.       ((stx name (lambda formals e0 e1 ...))
  39.          (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
  40.            (syntax (define name
  41.              (lambda formals
  42.                (let ((resume #f) (return #f))
  43.                  (define yield
  44.                    (lambda args
  45.                      (call-with-current-continuation
  46.                       (lambda (cont)
  47.                         (set! resume cont)
  48.                         (apply return args)))))
  49.                  (lambda ()
  50.                    (call-with-current-continuation
  51.                     (lambda (cont)
  52.                       (set! return cont)
  53.                       (cond (resume (resume))
  54.                       (else (let () e0 e1 ...)
  55.                             (error 'name "unexpected return"))))))))))))
  56.         ((stx (name . formals) e0 e1 ...)
  57.           (syntax (stx name (lambda formals e0 e1 ...)))))))
  58.  
  59. (define-generator (primegen)
  60.   (yield 2) (yield 3)
  61.   (let* ((ps (primegen))
  62.          (p (and (ps) (ps)))
  63.          (q (* p p))
  64.          (d (make-hash identity = #f 997)))
  65.     (define (add x s)
  66.       (while (d 'lookup x)
  67.         (set! x (+ x s)))
  68.       (d 'insert! x s))
  69.     (do ((c (+ p 2) (+ c 2))) (#f)
  70.       (cond ((d 'lookup c)
  71.               (let ((s (d 'lookup c)))
  72.                 (d 'delete! c)
  73.                 (add (+ c s) s)))
  74.             ((< c q) (yield c))
  75.             (else (add (+ c p p) (+ p p))
  76.                   (set! p (ps))
  77.                   (set! q (* p p)))))))
  78.  
  79. (define (prime-substring n)
  80.   (let ((ps (primegen)))
  81.     (let loop ((i 0) (str ""))
  82.       (cond ((< (string-length str) 5)
  83.               (loop i (string-append str (number->string (ps)))))
  84.             ((< i n)
  85.               (loop (+ i 1) (substring str 1 (string-length str))))
  86.             (else (substring str 0 5))))))
  87.  
  88. (display (prime-substring 50)) (newline)
  89. (display (prime-substring 1000)) (newline)
Success #stdin #stdout 0.13s 10088KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
03107
98719
https://ideone.com/DaU4pX
language:
Scheme (guile 2.2.4)
created:
7 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!