From 1b970134969ebf0e70cc75cc72950bc00bf93586 Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Sun, 16 Jan 2011 20:04:32 +0100
Subject: [PATCH] In QuickCheck, fix bug in lift->generator.

This would result in aggregates where all the generators start from
the same seed.
---
 .../deinprogramm/quickcheck/quickcheck.scm    | 69 +++++++++----------
 1 file changed, 33 insertions(+), 36 deletions(-)

diff --git a/collects/deinprogramm/quickcheck/quickcheck.scm b/collects/deinprogramm/quickcheck/quickcheck.scm
index a01852eb4e..8879b12e93 100644
--- a/collects/deinprogramm/quickcheck/quickcheck.scm
+++ b/collects/deinprogramm/quickcheck/quickcheck.scm
@@ -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)