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:
parent
cdd6bf438a
commit
76c6a1b7b0
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)])
|
||||||
|
|
|
@ -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)))
|
|
||||||
|
|
||||||
|
|
|
@ -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))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)]
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user