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)
This commit is contained in:
Robby Findler 2014-04-26 08:12:54 -05:00
parent cdd6bf438a
commit 76c6a1b7b0
9 changed files with 249 additions and 182 deletions

View File

@ -2237,10 +2237,14 @@ is expected to be the contract on the value).
stronger stronger
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:generator [#:generate
generator 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]) #f])
flat-contract-property?] flat-contract-property?]
@defproc[(build-chaperone-contract-property @defproc[(build-chaperone-contract-property
@ -2271,10 +2275,14 @@ is expected to be the contract on the value).
stronger stronger
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:generator [#:generate
generator 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]) #f])
chaperone-contract-property?] chaperone-contract-property?]
@defproc[(build-contract-property @defproc[(build-contract-property
@ -2305,10 +2313,14 @@ is expected to be the contract on the value).
stronger stronger
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:generator [#:generate
generator 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]) #f])
contract-property?])]{ contract-property?])]{
@ -2316,7 +2328,7 @@ is expected to be the contract on the value).
@racket[val-first-projection] argument @racket[val-first-projection] argument
are subject to change. (Probably are subject to change. (Probably
also the default values of the @racket[project] also the default values of the @racket[project]
arguments will change.} arguments will change.)}
These functions build the arguments for @racket[prop:contract], 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; produces a blame-tracking projection defining the behavior of the contract;
@racket[stronger], which is a predicate that determines whether this contract @racket[stronger], which is a predicate that determines whether this contract
(passed in the first argument) is stronger than some other contract (passed (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 These accessors are passed as (optional) keyword arguments to
@racket[build-contract-property], and are applied to instances of the @racket[build-contract-property], and are applied to instances of the

View File

@ -2,20 +2,23 @@
(require racket/contract (require racket/contract
racket/contract/private/generate-base racket/contract/private/generate-base
rackunit rackunit)
rackunit/text-ui
net/url)
;; this is expected to never have a generator. ;; this is expected to never have a generator.
(define (some-crazy-predicate? x) (and (number? x) (= x 11))) (define (some-crazy-predicate? x) (and (number? x) (= x 11)))
(define (test-contract-generation ctc #:size [size 10]) (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)]) (for ([(k v) (in-hash predicate-generator-table)])
(check-not-exn (λ () (test-contract-generation k)))) (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 boolean?))))
(check-not-exn (λ () (test-contract-generation (listof number?)))) (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.0))))
(check-not-exn (λ () (test-contract-generation (</c 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.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 (or/c boolean? boolean?))))
(check-not-exn (λ () (test-contract-generation (listof 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 (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 (λ () (test-contract-generation (list/c boolean? number?))))
(check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0))) (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
(check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 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?)) 1)))
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +))) (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) (define (cannot-generate-exn? x)
(and (exn:fail? x) (and (exn:fail? x)

View File

@ -713,25 +713,37 @@
(base->-min-arity ctc)) (base->-min-arity ctc))
(not (base->-rest ctc))) (not (base->-rest ctc)))
;; only handle the case with no optional args and no rest args ;; 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) (λ (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 (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 (procedure-reduce-arity
(λ args (λ args
; Make sure that the args match the contract ; 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)) (error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc))
; Stash the valid value ; 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) (define (->-exercise ctc)
(λ (args fuel) (λ (args fuel)

View File

@ -125,7 +125,7 @@
;; given a predicate returns a generate for this predicate or generate-ctc-fail ;; given a predicate returns a generate for this predicate or generate-ctc-fail
(define (find-generate func [name "internal"]) (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) (define (get-arg-names-space space-needed)
(let ([rv (thread-cell-ref arg-names-count)]) (let ([rv (thread-cell-ref arg-names-count)])

View File

@ -8,90 +8,77 @@
(provide generate-env (provide generate-env
env-stash env-stash
contract-random-generate contract-random-generate
generate/direct generate/direct
generate/choose generate/choose
make-generate-ctc-fail 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)) (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 ; Adds a new contract and value to the environment if
; they don't already exist ; 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 ; generate : contract int -> ctc value or error
(define (contract-random-generate ctc fuel (define (contract-random-generate ctc fuel
[fail (λ () [fail (λ ()
(error 'contract-random-generate (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)]) (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 ; 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) (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. ; 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)))

View File

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

View File

@ -611,16 +611,52 @@
#:generate #:generate
(λ (ctc) (λ (ctc)
(λ (fuel) (λ (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) (define (check-unary-between/c sym x)
(unless (real? x) (unless (real? x)
@ -646,26 +682,24 @@
`(</c ,x) `(</c ,x)
(λ (y) (and (real? y) (< y x))) (λ (y) (and (real? y) (< y x)))
(λ (fuel) (λ (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) (define (>/c x)
(flat-named-contract (flat-named-contract
`(>/c ,x) `(>/c ,x)
(λ (y) (and (real? y) (> y x))) (λ (y) (and (real? y) (> y x)))
(λ (fuel) (λ (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?) (define (check-two-args name arg1 arg2 pred1? pred2?)
(unless (pred1? arg1) (unless (pred1? arg1)
@ -699,20 +733,30 @@
(define (listof-generate elem-ctc) (define (listof-generate elem-ctc)
(λ (fuel) (λ (fuel)
(define (mk-rand-list so-far) (define eg (generate/choose elem-ctc fuel))
(if eg
(λ ()
(let loop ([so-far '()])
(rand-choice (rand-choice
[1/5 so-far] [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) (define (listof-exercise el-ctc)
(λ (f n-tests size env) (λ (f n-tests size env)
#t)) #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) (define (*-listof predicate? name generate)
(λ (input) (λ (input)
(let* ([ctc (coerce-contract name input)] (let* ([ctc (coerce-contract name input)]
@ -793,7 +837,7 @@
(define non-empty-listof-func (*-listof non-empty-list? (define non-empty-listof-func (*-listof non-empty-list?
'non-empty-listof '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/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")) (define (blame-add-car-context blame) (blame-add-context blame "the car of"))
@ -881,15 +925,15 @@
(define (list/c-generate ctc) (define (list/c-generate ctc)
(define elem-ctcs (generic-list/c-args ctc)) (define elem-ctcs (generic-list/c-args ctc))
(λ (fuel) (λ (fuel)
(let loop ([elem-ctcs elem-ctcs] (define gens (for/list ([elem-ctc (in-list elem-ctcs)])
[result '()]) (generate/choose elem-ctc fuel)))
(cond (cond
[(null? elem-ctcs) (reverse result)] [(andmap values gens)
(λ ()
(for/list ([gen (in-list gens)])
(gen)))]
[else [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)) (struct generic-list/c (args))
@ -1669,7 +1713,6 @@
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-named-contract name predicate [generate #f]) (define (flat-named-contract name predicate [generate #f])
(let ([generate (or generate (make-generate-ctc-fail))])
(cond (cond
[(and (procedure? predicate) [(and (procedure? predicate)
(procedure-arity-includes? predicate 1)) (procedure-arity-includes? predicate 1))
@ -1681,7 +1724,7 @@
(format "~s" `(or/c flat-contract? (format "~s" `(or/c flat-contract?
(and/c procedure? (and/c procedure?
(λ (x) (procedure-arity-include? x 1))))) (λ (x) (procedure-arity-include? x 1)))))
predicate)]))) predicate)]))
(define printable/c (define printable/c
(flat-named-contract (flat-named-contract

View File

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

View File

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