improve random contract generation

notably enable the generator to actually use things from the
environment but currently only when they are directly in the
environment so, eg:

   (-> (-> is-eleven?) is-eleven?)

can't be generated (since the contract system doesn't know
about is-eleven? and also doesn't yet know that it can call
the argument thunk)

pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -2237,10 +2237,14 @@ is expected to be the contract on the value).
            stronger
            (or/c (-> contract? contract? boolean?) #f)
            #f]
-          [#:generator
+          [#:generate
            generator
-           (or/c (-> number? (listof (list any/c contract?)) any/c)
+           (->i ([c contract?])
-                 #f)
+                ([generator 
+                  (c)
+                  (-> (and/c positive? real?) 
+                      (or/c #f
+                            (-> c)))]))
            #f])
          flat-contract-property?]
 @defproc[(build-chaperone-contract-property
@@ -2271,10 +2275,14 @@ is expected to be the contract on the value).
            stronger
            (or/c (-> contract? contract? boolean?) #f)
            #f]
-          [#:generator
+          [#:generate
            generator
-           (or/c (-> number? (listof (list any/c contract?)) any/c) 
+           (->i ([c contract?])
-                 #f)
+                ([generator 
+                  (c)
+                  (-> (and/c positive? real?) 
+                      (or/c #f
+                            (-> c)))]))
            #f])
          chaperone-contract-property?]
 @defproc[(build-contract-property
@@ -2305,10 +2313,14 @@ is expected to be the contract on the value).
            stronger
            (or/c (-> contract? contract? boolean?) #f)
            #f]
-          [#:generator
+          [#:generate
            generator
-           (or/c (-> number? (listof (list any/c contract?)) any/c) 
+           (->i ([c contract?])
-                 #f)
+                ([generator 
+                  (c)
+                  (-> (and/c positive? real?) 
+                      (or/c #f
+                            (-> c)))]))
            #f])
          contract-property?])]{
 
@@ -2316,7 +2328,7 @@ is expected to be the contract on the value).
            @racket[val-first-projection] argument
            are subject to change. (Probably
            also the default values of the @racket[project] 
-           arguments will change.}
+           arguments will change.)}
 
    
 These functions build the arguments for @racket[prop:contract],
@@ -2330,9 +2342,9 @@ which produces a description to @racket[write] as part of a contract violation;
 produces a blame-tracking projection defining the behavior of the contract;
 @racket[stronger], which is a predicate that determines whether this contract
 (passed in the first argument) is stronger than some other contract (passed
-in the second argument); and @racket[generator], which makes a random value
+in the second argument); and @racket[generate], which returns a thunk
-that matches the contract, given a size bound and an environment from which
+that generates random values matching the contract or @racket[#f], indicating
-to draw interesting values.
+that random generation for this contract isn't supported.
 
 These accessors are passed as (optional) keyword arguments to
 @racket[build-contract-property], and are applied to instances of the

pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt

@@ -2,20 +2,23 @@
 
 (require racket/contract
          racket/contract/private/generate-base
-         rackunit
+         rackunit)
-         rackunit/text-ui
-         net/url)
 
 ;; this is expected to never have a generator.
 (define (some-crazy-predicate? x) (and (number? x) (= x 11)))
 
 (define (test-contract-generation ctc #:size [size 10])
-  (define example-vals (contract-random-generate ctc size))
+  (define example-val (contract-random-generate ctc size))
-  (contract ctc example-vals 'pos 'neg))
+  (contract ctc example-val 'pos 'neg))
 
 (for ([(k v) (in-hash predicate-generator-table)])
   (check-not-exn (λ () (test-contract-generation k))))
 
+;; test =, eq?, and equal? contract random generators
+(check-not-exn (λ () (test-contract-generation 0)))
+(check-not-exn (λ () (test-contract-generation 'x)))
+(check-not-exn (λ () (test-contract-generation "x")))
+
 (check-not-exn (λ () (test-contract-generation (listof boolean?))))
 (check-not-exn (λ () (test-contract-generation (listof number?))))
 
@@ -30,16 +33,21 @@
 (check-not-exn (λ () (test-contract-generation (>/c 0.0))))
 (check-not-exn (λ () (test-contract-generation (</c 0))))
 (check-not-exn (λ () (test-contract-generation (</c 0.0))))
+(check-not-exn (λ () (test-contract-generation (=/c 0))))
+(check-not-exn (λ () (test-contract-generation (=/c 0.0))))
 (check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
 
 (check-not-exn (λ () (test-contract-generation (listof boolean?))))
 (check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
+(check-not-exn (λ () (test-contract-generation (non-empty-listof boolean?))))
 (check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
 (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
 
 (check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0)))
 (check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1)))
 (check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +)))
+(check-not-exn 
+ (λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11)))
 
 (define (cannot-generate-exn? x)
   (and (exn:fail? x)

racket/collects/racket/contract/private/arrow-val-first.rkt

@@ -713,25 +713,37 @@
                   (base->-min-arity ctc))
           (not (base->-rest ctc)))
      ;; only handle the case with no optional args and no rest args
-     (define doms-l (length (base->-doms ctc)))
+     (define dom-ctcs (base->-doms ctc))
+     (define doms-l (length dom-ctcs))
      (λ (fuel)
-       (define rngs-gens (map (λ (c) (generate/choose c (/ fuel 2)))
+       (define rngs-gens 
-                              (base->-rngs ctc)))
+         (with-definitely-available-contracts 
+          dom-ctcs
+          (λ ()
+            (for/list ([c (in-list (base->-rngs ctc))])
+              (generate/choose c fuel)))))
        (cond
-         [(for/or ([rng-gen (in-list rngs-gens)])
+         [(for/and ([rng-gen (in-list rngs-gens)])
-            (generate-ctc-fail? rng-gen))
+            rng-gen)
-          (make-generate-ctc-fail)]
+          (λ ()
-         [else
+            (define env (generate-env))
             (procedure-reduce-arity
              (λ args
                ; Make sure that the args match the contract
-             (begin (unless ((contract-struct-exercise ctc) args (/ fuel 2))
+               (unless ((contract-struct-exercise ctc) args (/ fuel 2))
                  (error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc))
                ; Stash the valid value
-                    ;(env-stash (generate-env) ctc args)
+               (parameterize ([generate-env env])
-                    (apply values rngs-gens)))
+                 (for ([ctc (in-list dom-ctcs)]
-           doms-l)]))]
+                       [arg (in-list args)])
-    [else (λ (fuel) (make-generate-ctc-fail))]))
+                   (env-stash ctc arg))
+                 (define results
+                   (for/list ([rng-gen (in-list rngs-gens)])
+                     (rng-gen)))
+                 (apply values results)))
+             doms-l))]
+         [else #f]))]
+    [else (λ (fuel) #f)]))
 
 (define (->-exercise ctc) 
   (λ (args fuel)

racket/collects/racket/contract/private/generate-base.rkt

@@ -125,7 +125,7 @@
 
 ;; given a predicate returns a generate for this predicate or generate-ctc-fail
 (define (find-generate func [name "internal"])
-  (hash-ref predicate-generator-table func make-generate-ctc-fail))
+  (hash-ref predicate-generator-table func #f))
 
 (define (get-arg-names-space space-needed)
   (let ([rv (thread-cell-ref arg-names-count)])

racket/collects/racket/contract/private/generate.rkt

@@ -8,90 +8,77 @@
 
 (provide generate-env
          env-stash
-         
          contract-random-generate
-         
          generate/direct
          generate/choose
-         
          make-generate-ctc-fail
-         generate-ctc-fail?)
+         generate-ctc-fail?
+         with-definitely-available-contracts)
 
-; env parameter
+;; a stash of values and the contracts that they correspond to
+;; that generation has produced earlier in the process 
 (define generate-env (make-parameter #f))
 
+;; (parameter/c (listof contract?))
+;; contracts in this will definitely have values available
+;; by the time generation happens; those values will be 
+;; in the env-stash.
+(define definitely-available-contracts (make-parameter '()))
+
 ; Adds a new contract and value to the environment if
 ; they don't already exist
-(define (env-stash env ctc val)
+(define (env-stash ctc val)
-  (let* ([curvals (hash-ref env ctc (list))])
+  (define env (generate-env))
-    (hash-set! env ctc (cons val curvals))))
+  (define curvals (hash-ref env ctc '()))
+  (hash-set! env ctc (cons val curvals)))
 
-(define (gen-pred/direct pred fuel)
+(define (with-definitely-available-contracts ctcs thunk)
-  (let ([ctc (coerce-contract 'contract-direct-gen pred)])
+  (parameterize ([definitely-available-contracts 
-    (generate/direct ctc fuel)))
+                   (append ctcs (definitely-available-contracts))])
+    (thunk)))
            
 ; generate : contract int -> ctc value or error
 (define (contract-random-generate ctc fuel
                                   [fail (λ () 
                                           (error 'contract-random-generate
-                                                 "unable to construct any generator for contract: ~s"
+                                                 "unable to construct any generator for contract: ~e"
-                                                 (contract-struct-name 
+                                                 (coerce-contract 'contract-random-generate ctc)))])
-                                                  (coerce-contract 'contract-random-generate ctc))))])
+  (define def-ctc (coerce-contract 'contract-random-generate ctc))
-  (let ([def-ctc (coerce-contract 'contract-random-generate ctc)])
   (parameterize ([generate-env (make-hash)])
-      ; choose randomly
+    (let ([proc (generate/choose def-ctc fuel)])
-      (let ([val (generate/choose def-ctc fuel)])
+      (if proc
-        (if (generate-ctc-fail? val)
+          (proc)
-            (fail)
+          (fail)))))
-            val)))))
 
+;; generate/choose : contract? nonnegative-int -> (or/c #f (-> any/c))
 ; Iterates through generation methods until failure. Returns
-; generate-ctc-fail if no value could be generated
+; #f if no value could be generated
 (define (generate/choose ctc fuel)
-  (let ([options (permute (list generate/direct
+  (let loop ([options (permute (list generate/direct generate/env))])
-                                generate/direct-env
+    (cond
-                                ))])
+      [(empty? options)
-    ; choose randomly
+       #f]
-    (let trygen ([options options])
+      [else
-      (if (empty? options)
+       (define option (car options))
-          (make-generate-ctc-fail)
+       (define gen (option ctc fuel))
-          (let* ([option (car options)]
+       (or gen (loop (cdr options)))])))
-                 [val (option ctc fuel)])
-            (if (generate-ctc-fail? val)
-                (trygen (cdr options))
-                val))))))
 
-; generate/direct :: contract int -> value for contract
+; generate/direct :: contract nonnegative-int -> (or/c #f (-> val))
-; Attempts to make a generator that generates values for this contract
+;; generate directly via the contract's built-in generator, if possible
-; directly. Returns generate-ctc-fail if making a generator fails.
+(define (generate/direct ctc fuel) ((contract-struct-generate ctc) fuel))
-(define (generate/direct ctc fuel)
-  (let ([g (contract-struct-generate ctc)])
-    ; Check if the contract has a direct generate attached
-    (if (generate-ctc-fail? g)
-        ; Everything failed -- we can't directly generate this ctc
-        g 
-        (g fuel))))
   
-; generate/direct-env :: contract int -> value
+; generate/direct-env :: contract nonnegative-int -> value
 ; Attemps to find a value with the given contract in the environment.
-; Returns it if found and generate-ctc-fail otherwise.
+;; NB: this doesn't yet try to call things in the environment to generate
-(define (generate/direct-env ctc fuel)
+(define (generate/env ctc fuel)
-  ; TODO: find out how to make negative test cases
+  (for/or ([avail-ctc (in-list (definitely-available-contracts))])
-  (let* ([keys (hash-keys (generate-env))]
+    (and (contract-stronger? avail-ctc ctc)
-         [valid-ctcs (filter (λ (c)
+         (λ ()
-                               (contract-stronger? c ctc))
+           (define available 
-                             keys)])
+             (for/list ([(avail-ctc vs) (in-hash (generate-env))]
-    (if (> (length valid-ctcs) 0)
+                        #:when (contract-stronger? avail-ctc ctc)
-        (oneof (oneof (map (λ (key)
+                        [v (in-list vs)])
-                             (hash-ref (generate-env) key))
+               v))
-                           valid-ctcs)))
+           (when (null? available)
-        (make-generate-ctc-fail))))
+             (error 'generate.rkt "internal error: no values satisfying ~s available" ctc))
-
+           (oneof available)))))
-; generate/indirect-env :: contract int -> (int -> value for contract)
-; Attempts to make a generator that generates values for this contract
-; by calling functions in the environment
-(define (generate/indirect-env ctc fuel)
-  (if (> fuel 0)
-      (make-generate-ctc-fail)
-      (make-generate-ctc-fail)))
-

racket/collects/racket/contract/private/guts.rkt

@@ -173,7 +173,7 @@
   (cond
     [(contract-struct? x) x]
     [(and (procedure? x) (procedure-arity-includes? x 1)) 
-     (make-predicate-contract (or (object-name x) '???) x (make-generate-ctc-fail))]
+     (make-predicate-contract (or (object-name x) '???) x #f)]
     [(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)]
     [(or (bytes? x) (string? x)) (make-equal-contract x)]
     [(number? x) (make-=-contract x)]
@@ -295,7 +295,9 @@
         `',(eq-contract-val ctc)
         (eq-contract-val ctc)))
    #:generate
-   (λ (ctc) (λ (fuel) (eq-contract-val ctc)))
+   (λ (ctc) 
+     (define v (eq-contract-val ctc))
+     (λ (fuel) (λ () v)))
    #:stronger
    (λ (this that)
       (and (eq-contract? that)
@@ -312,7 +314,9 @@
       (and (equal-contract? that)
            (equal? (equal-contract-val this) (equal-contract-val that))))
    #:generate
-   (λ (ctc) (λ (fuel) (equal-contract-val ctc)))))
+   (λ (ctc) 
+     (define v (equal-contract-val ctc))
+     (λ (fuel) (λ () v)))))
 
 (define-struct =-contract (val)
   #:property prop:custom-write custom-write-property-proc
@@ -325,7 +329,9 @@
       (and (=-contract? that)
            (= (=-contract-val this) (=-contract-val that))))
    #:generate
-   (λ (ctc) (λ (fuel) (=-contract-val ctc)))))
+   (λ (ctc) 
+     (define v (=-contract-val ctc))
+     (λ (fuel) (λ () v)))))
 
 (define-struct regexp/c (reg)
   #:property prop:custom-write custom-write-property-proc
@@ -372,17 +378,22 @@
          predicate-contract-proj)))
    #:generate (λ (ctc)
                  (let ([generate (predicate-contract-generate ctc)])
-                   (if (generate-ctc-fail? generate)
+                   (cond
-                     (let ([fn (predicate-contract-pred ctc)])
+                     [generate generate]
-                       (find-generate fn (predicate-contract-name ctc)))
+                     [else
-                     generate)))
+                      (define built-in-generator
+                        (find-generate (predicate-contract-pred ctc)
+                                       (predicate-contract-name ctc)))
+                      (λ (fuel)
+                        (and built-in-generator
+                             (λ () (built-in-generator fuel))))])))
    #:exercise (λ (ctc)
                  (λ (val fuel) 
                     ((predicate-contract-pred ctc) val)))))
 
 (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
 (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
-(define (build-flat-contract name pred [generate (make-generate-ctc-fail)])
+(define (build-flat-contract name pred [generate #f])
   (make-predicate-contract name pred generate))
 
 

racket/collects/racket/contract/private/misc.rkt

@@ -611,16 +611,52 @@
    #:generate
    (λ (ctc)
       (λ (fuel)
-         (let* ([max-n 2147483647]
+        (define n (between/c-low ctc))
-                [min-n -2147483648]
+        (define m (between/c-high ctc))
-                [upper (if (> (between/c-high ctc) max-n)
+          (cond
-                         max-n
+            [(= n m)
-                         (between/c-high ctc))]
+             (λ () 
-                [lower (if (< (between/c-low ctc) min-n)
+               (define choice (rand-choice
-                         min-n
+                               [1/2 n]
-                         (between/c-low ctc))])
+                               [else m]))
-           (+ (* (random) (- upper lower))
+               (rand-choice 
-              lower))))))
+                [1/2 (if (exact? choice)
+                         (if (= (exact->inexact choice) choice)
+                             (exact->inexact choice)
+                             choice)
+                         (if (= (* 1.0 choice) choice)
+                             (* 1.0 choice)
+                             choice))]
+                [else choice]))]
+            [else
+             (λ ()
+               (rand-choice
+                [1/10 (if (<= n 0 m)
+                          (rand-choice [1/3 0] [1/3 0.0] [else -0.0])
+                          (rand-choice [1/2 n] [else m]))]
+                [1/20 (if (<= n 1 m)
+                          1
+                          (rand-choice [1/2 n] [else m]))]
+                [1/20 (if (<= n -1 m)
+                          -1
+                          (rand-choice [1/2 n] [else m]))]
+                [1/10 m]
+                [1/10 n]
+                [1/10 (if (<= n 0 1 m)
+                          (random)
+                          (rand-choice [1/2 n] [else m]))]
+                [else
+                 (cond
+                   [(or (= n -inf.0) (= m +inf.0))
+                    (define c (random 4294967087))
+                    (cond
+                      [(and (= n -inf.0) (= m +inf.0)) c]
+                      [(= m +inf.0) (+ n c)]
+                      [(= n -inf.0) (- m c)])]
+                   [else
+                    (+ n (* (random) (- m n)))])]))])))))
+
+(define (maybe-neg n) (rand-choice [1/2 n] [else (- n)]))
 
 (define (check-unary-between/c sym x)
   (unless (real? x)
@@ -646,26 +682,24 @@
    `(</c ,x)
    (λ (y) (and (real? y) (< y x)))
    (λ (fuel)
-      (let* ([max-n 2147483647]
+     (λ ()
-             [min-n -2147483648]
+       (rand-choice
-             [upper (if (> x max-n)
+        [1/10 -inf.0]
-                      max-n
+        [1/10 (- x 0.01)]
-                      x)])
+        [4/10 (- x (random))]
-        (+ (* (random) (- upper min-n))
+        [else (- x (random 4294967087))])))))
-           min-n)))))
 
 (define (>/c x)
   (flat-named-contract
     `(>/c ,x)
     (λ (y) (and (real? y) (> y x)))
     (λ (fuel) 
-       (let* ([max-n 2147483647]
+      (λ ()
-              [min-n -2147483648]
+        (rand-choice
-              [lower (if (< x min-n)
+         [1/10 +inf.0]
-                       min-n
+         [1/10 (+ x 0.01)]
-                       x)])
+         [4/10 (+ x (random))]
-         (+ (* (random) (- max-n lower))
+         [else (+ x (random 4294967087))])))))
-            lower)))))
 
 (define (check-two-args name arg1 arg2 pred1? pred2?)
   (unless (pred1? arg1)
@@ -699,20 +733,30 @@
 
 (define (listof-generate elem-ctc)
   (λ (fuel)
-    (define (mk-rand-list so-far)
+    (define eg (generate/choose elem-ctc fuel))
+    (if eg
+        (λ ()
+          (let loop ([so-far '()])
             (rand-choice
              [1/5 so-far]
-       [else 
+             [else (loop (cons (eg) so-far))])))
-        (define next-elem (generate/direct elem-ctc fuel))
+        (λ () '()))))
-        (if (generate-ctc-fail? next-elem)
-            (mk-rand-list so-far)
-            (mk-rand-list (cons next-elem so-far)))]))
-    (mk-rand-list (list))))
 
 (define (listof-exercise el-ctc)
   (λ (f n-tests size env)
     #t))
 
+(define (non-empty-listof-generate elem-ctc)
+  (λ (fuel)
+    (define eg (generate/choose elem-ctc fuel))
+    (if eg
+        (λ ()
+          (let loop ([so-far (list (eg))])
+            (rand-choice
+             [1/5 so-far]
+             [else (loop (cons (eg) so-far))])))
+        #f)))
+
 (define (*-listof predicate? name generate)
   (λ (input)
     (let* ([ctc (coerce-contract name input)]
@@ -793,7 +837,7 @@
 
 (define non-empty-listof-func (*-listof non-empty-list? 
                                         'non-empty-listof
-                                        (λ (ctc) (make-generate-ctc-fail))))
+                                        non-empty-listof-generate))
 (define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
 
 (define (blame-add-car-context blame) (blame-add-context blame "the car of"))
@@ -881,15 +925,15 @@
 (define (list/c-generate ctc)
   (define elem-ctcs (generic-list/c-args ctc))
   (λ (fuel)
-    (let loop ([elem-ctcs elem-ctcs]
+    (define gens (for/list ([elem-ctc (in-list elem-ctcs)])
-               [result '()])
+                   (generate/choose elem-ctc fuel)))
     (cond
-        [(null? elem-ctcs) (reverse result)]
+      [(andmap values gens)
+       (λ ()
+         (for/list ([gen (in-list gens)])
+           (gen)))]
       [else
-         (define next-elem (generate/direct (car elem-ctcs) fuel))
+       #f])))
-         (if (generate-ctc-fail? next-elem)
-             next-elem
-             (loop (cdr elem-ctcs) (cons next-elem result)))]))))
 
 (struct generic-list/c (args))
 
@@ -1669,7 +1713,6 @@
 
 (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
 (define (flat-named-contract name predicate [generate #f])
-  (let ([generate (or generate (make-generate-ctc-fail))])
   (cond
     [(and (procedure? predicate)
           (procedure-arity-includes? predicate 1))
@@ -1681,7 +1724,7 @@
                            (format "~s" `(or/c flat-contract?
                                                (and/c procedure?
                                                       (λ (x) (procedure-arity-include? x 1)))))
-                             predicate)])))
+                           predicate)]))
 
 (define printable/c
   (flat-named-contract

racket/collects/racket/contract/private/prop.rkt

@@ -97,12 +97,11 @@
     (stronger a b)))
 
 (define (contract-struct-generate c)
-  (let* ([prop (contract-struct-property c)]
+  (define prop (contract-struct-property c))
-         [generate (contract-property-generate prop)])
+  (define generate (contract-property-generate prop))
   (if (procedure? generate)
-      ; FIXME: Call needs to take multiple arguments
       (generate c)
-        (make-generate-ctc-fail))))
+      #f))
 
 (define (contract-struct-exercise c)
   (let* ([prop (contract-struct-property c)]

racket/collects/racket/contract/private/rand.rkt

@@ -9,9 +9,6 @@
          permute
          oneof)
 
-
-;; random generator
-
 (define my-generator (make-pseudo-random-generator))
 (define (rand [x #f]) 
   (if x
@@ -23,8 +20,6 @@
   (parameterize ([current-pseudo-random-generator my-generator])
     (random-seed x)))
 
-(rand-seed 0)
-
 (define-syntax (rand-choice stx)
   (syntax-case stx ()
     [(_ (a case1 case2 ...) ...)
@@ -81,13 +76,13 @@
 ; oneof :: [a] -> a
 ; Randomly chooses one of the values from a given list
 (define (oneof a-list)
-  (list-ref a-list (random (length a-list))))
+  (list-ref a-list (rand (length a-list))))
 
 ; fisher-yates shuffle
 (define (permute a-list)
   (do ((v (list->vector a-list)) (n (length a-list) (- n 1)))
       ((zero? n) (vector->list v))
-    (let* ((r (random n)) (t (vector-ref v r)))
+    (let* ((r (rand n)) (t (vector-ref v r)))
       (vector-set! v r (vector-ref v (- n 1)))
       (vector-set! v (- n 1) t))))