1. ; morris counting
2.
3. (define-syntax fold-of
4. (syntax-rules (range in is)
5. ((_ "z" f b e) (set! b (f b e)))
6. ((_ "z" f b e (v range fst pst stp) c ...)
7. (let* ((x fst) (p pst) (s stp)
8. (le? (if (positive? s) <= >=)))
9. (do ((v x (+ v s))) ((le? p v) b)
10. (fold-of "z" f b e c ...))))
11. ((_ "z" f b e (v range fst pst) c ...)
12. (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
13. (fold-of "z" f b e (v range x p s) c ...)))
14. ((_ "z" f b e (v range pst) c ...)
15. (fold-of "z" f b e (v range 0 pst) c ...))
16. ((_ "z" f b e (x in xs) c ...)
17. (do ((t xs (cdr t))) ((null? t) b)
18. (let ((x (car t)))
19. (fold-of "z" f b e c ...))))
20. ((_ "z" f b e (x is y) c ...)
21. (let ((x y)) (fold-of "z" f b e c ...)))
22. ((_ "z" f b e p? c ...)
23. (if p? (fold-of "z" f b e c ...)))
24. ((_ f i e c ...)
25. (let ((b i)) (fold-of "z" f b e c ...)))))
26.
27. (define-syntax list-of (syntax-rules ()
28. ((_ arg ...) (reverse (fold-of
29. (lambda (d a) (cons a d)) '() arg ...)))))
30.
31. (define rand #f)
32. (define randint #f)
33. (let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
34. (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
35. ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
36. (define (flip-cycle)
37. (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
38. (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
39. (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
40. (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
41. (set! fptr 54) (vector-ref a 55))
42. (define (init-rand seed)
43. (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
44. (vector-set! a 55 prev)
45. (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
46. (vector-set! a i next) (set! next (mod-diff prev next))
47. (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
48. (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
49. (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
50. (define (next-rand)
51. (if (negative? (vector-ref a fptr)) (flip-cycle)
52. (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
53. (define (unif-rand m)
54. (let ((t (- two31 (modulo two31 m))))
55. (let loop ((r (next-rand)))
56. (if (<= t r) (loop (next-rand)) (modulo r m)))))
57. (init-rand 19380110) ; happy birthday donald e knuth
58. (set! rand (lambda seed
59. (cond ((null? seed) (/ (next-rand) two31))
60. ((eq? (car seed) 'get) (cons fptr (vector->list a)))
61. ((eq? (car seed) 'set) (set! fptr (caadr seed))
62. (set! a (list->vector (cdadr seed))))
63. (else (/ (init-rand (modulo (numerator
64. (inexact->exact (car seed))) two31)) two31)))))
65. (set! randint (lambda args
66. (cond ((null? (cdr args))
67. (if (< (car args) two31) (unif-rand (car args))
68. (floor (* (next-rand) (car args)))))
69. ((< (car args) (cadr args))
70. (let ((span (- (cadr args) (car args))))
71. (+ (car args)
72. (if (< span two31) (unif-rand span)
73. (floor (* (next-rand) span))))))
74. (else (let ((span (- (car args) (cadr args))))
75. (- (car args)
76. (if (< span two31) (unif-rand span)
77. (floor (* (next-rand) span))))))))))
78.
79. (define (make-counter)
80. (let ((c 0))
81. (lambda ()
82. (when (zero? (randint (expt 2 c)))
83. (set! c (+ c 1)))
84. (- (expt 2 c) 1))))
85.
86. (define (count n)
87. (let ((x (make-counter)))
88. (do ((n n (- n 1))) ((zero? n) (x)) (x))))
89.
90. (display (list-of (count 25000) (x range 10)))
Success #stdin #stdout 3.08s 8036KB
stdin
Standard input is empty
stdout
(16383 16383 8191 16383 32767 4095 65535 32767 16383 16383)