In QuickCheck, fix bug in lift->generator.

This would result in aggregates where all the generators start from
the same seed.
This commit is contained in:
Mike Sperber 2011-01-16 20:04:32 +01:00
parent 85e02db1ad
commit 1b97013496

View File

@ -6,13 +6,41 @@
;; int(size) random-generator -> val
(proc generator-proc))
(define (lift->generator proc . gens)
; for transliteration from Haskell
(define (return val)
(make-generator
(lambda (size rgen)
(apply proc
(map (lambda (gen)
((generator-proc gen) size rgen))
gens)))))
val)))
(define (>>= m1 k)
(let ((proc1 (generator-proc m1)))
(make-generator
(lambda (size rgen)
(call-with-values
(lambda ()
(random-generator-split rgen))
(lambda (rgen1 rgen2)
(let ((gen (k (proc1 size rgen1))))
((generator-proc gen) size rgen2))))))))
(define (sequence gens)
(if (null? gens)
(return '())
(>>= (car gens)
(lambda (val)
(>>= (sequence (cdr gens))
(lambda (rest)
(return (cons val rest))))))))
; for export
(define generator-unit return)
(define generator-bind >>=)
(define generator-sequence sequence)
(define (lift->generator proc . gens)
(>>= (sequence gens)
(lambda (vals)
(return (apply proc vals)))))
; [lower, upper]
(define (choose-integer lower upper)
@ -132,37 +160,6 @@
(define (choose-vector el-gen n)
(lift->generator list->vector (choose-list el-gen n)))
; for transliteration from Haskell
(define (return val)
(make-generator
(lambda (size rgen)
val)))
(define (>>= m1 k)
(let ((proc1 (generator-proc m1)))
(make-generator
(lambda (size rgen)
(call-with-values
(lambda ()
(random-generator-split rgen))
(lambda (rgen1 rgen2)
(let ((gen (k (proc1 size rgen1))))
((generator-proc gen) size rgen2))))))))
(define (sequence gens)
(if (null? gens)
(return '())
(>>= (car gens)
(lambda (val)
(>>= (sequence (cdr gens))
(lambda (rest)
(return (cons val rest))))))))
; for export
(define generator-unit return)
(define generator-bind >>=)
(define generator-sequence sequence)
; (list (promise (generator a))) -> (generator a)
(define (choose-mixed gens)
(>>= (choose-one-of gens)