fork download
  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
stdin
Standard input is empty
stdout
03107
98719