From ce3f891209a0ce00fd4c696583e0bd8df4d610fe Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 7 May 2014 21:28:44 -0500
Subject: [PATCH] improve any/c's random generation

by using the environment sometimes and making up (simple) functions
sometimes
---
 .../collects/racket/contract/private/misc.rkt | 35 +++++++++++++++----
 .../collects/racket/contract/private/rand.rkt |  8 +++++
 2 files changed, 36 insertions(+), 7 deletions(-)

diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
index 8179d3b9ef..31af6ab0e5 100644
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@@ -923,13 +923,34 @@
 (define (any? x) #t)
 (define any/c-neg-party-fn (λ (val) (λ (neg-party) val)))
 
-(define (random-any/c fuel)
-  (rand-choice
-   [1/2 (oneof '(0 #f "" () #() -1 1 #t elephant))]
-   [else 
-    ((hash-ref predicate-generator-table
-               (oneof (hash-keys predicate-generator-table)))
-     fuel)]))
+(define (random-any/c env fuel)
+  (cond
+    [(zero? (hash-count env))
+     (rand-choice
+      [1/3 (any/c-simple-value)]
+      [1/3 (any/c-procedure env fuel)]
+      [else (any/c-from-predicate-generator env fuel)])]
+    [else
+     (rand-choice
+      [1/4 (oneof (hash-ref env (oneof (hash-keys env))))]
+      [1/4 (any/c-simple-value)]
+      [1/4 (any/c-procedure env fuel)]
+      [else (any/c-from-predicate-generator env fuel)])]))
+
+(define (any/c-simple-value)
+  (oneof '(0 #f "" () #() -1 1 #t elephant)))
+(define (any/c-from-predicate-generator env fuel)
+  ((hash-ref predicate-generator-table
+             (oneof (hash-keys predicate-generator-table)))
+   fuel))
+(define (any/c-procedure env fuel)
+  (procedure-reduce-arity
+   (λ args
+     (apply
+      values
+      (for/list ([i (in-range (rand-nat))])
+        (random-any/c env fuel))))
+   (rand-nat)))
 
 (define-struct any/c ()
   #:property prop:custom-write custom-write-property-proc
diff --git a/racket/collects/racket/contract/private/rand.rkt b/racket/collects/racket/contract/private/rand.rkt
index beb46df1b3..404744c1f5 100644
--- a/racket/collects/racket/contract/private/rand.rkt
+++ b/racket/collects/racket/contract/private/rand.rkt
@@ -6,6 +6,7 @@
          rand-seed
          rand-choice
          rand-range
+         rand-nat
          permute
          oneof)
 
@@ -88,3 +89,10 @@
 
 (define (rand-range lower upper)
   (+ lower (rand (- upper lower))))
+
+;; returns a random natural from the geometric distribution
+(define (rand-nat [p 1/2])
+  (let loop ([n 0])
+    (cond
+      [(<= (rand) p) n]
+      [else (loop (+ n 1))])))