suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add #:satisfying to redex-check.

Browse Source 
This adds the ability to generate terms satisfying
judgment-forms and metafunctions to redex-check.
This commit is contained in:
Burke Fetscher 2013-09-06 14:47:49 -05:00
parent 88116aaceb
commit b5f6842ab0
3 changed files with 400 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
pkgs/redex-pkgs/redex-doc/redex/scribblings/ref.scrbl
View File

@ -1837,8 +1837,13 @@ repeating as necessary. The optional keyword argument @racket[retries-expr]
@racket[exn:fail:redex:generation-failure?]. @racket[exn:fail:redex:generation-failure?].
} }
@defform/subs[(redex-check language @#,ttpattern property-expr kw-arg ...) @defform/subs[(redex-check template property-expr kw-arg ...)
([kw-arg (code:line #:attempts attempts-expr) ([template (code:line language @#,ttpattern)
(code:line language #:satisfying
(judgment-form-id @#,ttpattern ...))
(code:line language #:satisfying
(metafunction-id @#,ttpattern ...) = @#,ttpattern)]
[kw-arg (code:line #:attempts attempts-expr)
(code:line #:source metafunction) (code:line #:source metafunction)
(code:line #:source relation-expr) (code:line #:source relation-expr)
(code:line #:retries retries-expr) (code:line #:retries retries-expr)
@ -1854,11 +1859,24 @@ repeating as necessary. The optional keyword argument @racket[retries-expr]
[prepare-expr (-> any/c any/c)])]{ [prepare-expr (-> any/c any/c)])]{
Searches for a counterexample to @racket[property-expr], interpreted Searches for a counterexample to @racket[property-expr], interpreted
as a predicate universally quantified over the pattern variables as a predicate universally quantified over the pattern variables
bound by @racket[pattern]. @racket[redex-check] constructs and tests bound by the @racket[pattern](s) in @racket[template].
a candidate counterexample by choosing a random term @math{t} that @racket[redex-check] constructs and tests
matches @racket[pattern] then evaluating @racket[property-expr] a candidate counterexample by choosing a random term @math{t} based
on @racket[template] and then evaluating @racket[property-expr]
using the @racket[match-bindings] produced by @racket[match]ing using the @racket[match-bindings] produced by @racket[match]ing
@math{t} against @racket[pattern]. @math{t} against @racket[pattern]. The form of @racket[template] controls
how @math{t} is generated:
@itemlist[
@item{@racket[language @#,ttpattern]:
In this case, redex-check generates terms that match
@racket[pattern].}
@item{@racket[language #:satisfying (judgment-form-id @#,ttpattern ...)]:
Generates terms that match @racket[pattern] and satisfy
the judgment form.}
@item{@racket[language #:satisfying (metafunction-id @#,ttpattern ...) = @#,ttpattern]:
Generates terms matching the two @racket[pattern]s, such that
if the first is the argument to the metafunction, the
second will be the result.}]
@racket[redex-check] generates at most @racket[attempts-expr] (default @racket[(default-check-attempts)]) @racket[redex-check] generates at most @racket[attempts-expr] (default @racket[(default-check-attempts)])
random terms in its search. The size and complexity of these terms tend to increase random terms in its search. The size and complexity of these terms tend to increase
@ -1882,14 +1900,19 @@ generated example before @racket[redex-check] checks @racket[property-expr].
This keyword may be useful when @racket[property-expr] takes the form This keyword may be useful when @racket[property-expr] takes the form
of a conditional, and a term chosen freely from the grammar is unlikely to of a conditional, and a term chosen freely from the grammar is unlikely to
satisfy the conditional's hypothesis. In some such cases, the @racket[prepare] satisfy the conditional's hypothesis. In some such cases, the @racket[prepare]
keyword can be used to increase the probability that an example satifies the keyword can be used to increase the probability that an example satisfies the
hypothesis. hypothesis.
The @racket[#:retries] keyword behaves identically as in @racket[generate-term],
controlling the number of times the generation of any pattern will be
reattempted. It can't be used together with @racket[#:satisfying].
When passed a metafunction or reduction relation via the optional @racket[#:source] When passed a metafunction or reduction relation via the optional @racket[#:source]
argument, @racket[redex-check] distributes its attempts across the left-hand sides argument, @racket[redex-check] distributes its attempts across the left-hand sides
of that metafunction/relation by using those patterns, rather than @racket[pattern], of that metafunction/relation by using those patterns, rather than @racket[pattern],
as the basis of its generation. It is an error if any left-hand side generates a as the basis of its generation. It is an error if any left-hand side generates a
term that does not match @racket[pattern].} term that does not match @racket[pattern]. @racket[#:source] cannot be used
with @racket[#:satisfying].}
@examples[ @examples[
#:eval redex-eval #:eval redex-eval
@ -1939,7 +1962,28 @@ term that does not match @racket[pattern].}
#:prepare (λ (n) #:prepare (λ (n)
(printf "preparing ~s; " n) (printf "preparing ~s; " n)
(add1 (abs n))) (add1 (abs n)))
#:attempts 3)] #:attempts 3)
(define-language L
(nat ::= Z (S nat)))
(define-judgment-form L
#:mode (sum I I O)
[---------------
(sum Z nat nat)]
[(sum nat_1 nat_2 nat_3)
-------------------------------
(sum (S nat_1) nat_2 (S nat_3))])
(redex-check L
#:satisfying
(sum nat_1 nat_2 nat_3)
(equal? (judgment-holds
(sum nat_1 nat_2 nat_4) nat_4)
(term (nat_3)))
#:attempts 100)
(redex-check L
#:satisfying
(sum nat_1 nat_2 nat_3)
(equal? (term nat_1) (term nat_2)))]
@defform/subs[(redex-generator language-id satisfying size-expr) @defform/subs[(redex-generator language-id satisfying size-expr)
([satisfying (judgment-form-id @#,ttpattern ...) ([satisfying (judgment-form-id @#,ttpattern ...)

342
pkgs/redex-pkgs/redex-lib/redex/private/generate-term.rkt
View File

@ -15,6 +15,7 @@
racket/match racket/match
racket/pretty racket/pretty
(for-syntax racket/base (for-syntax racket/base
racket/set
syntax/stx syntax/stx
setup/path-to-relative setup/path-to-relative
"rewrite-side-conditions.rkt" "rewrite-side-conditions.rkt"
@ -82,75 +83,187 @@
(list (if lists? #'(-> list? list?) #'(-> any/c any/c)) (list (if lists? #'(-> list? list?) #'(-> any/c any/c))
"#:prepare argument"))) "#:prepare argument")))
(define-for-syntax satisfying-disallowed-kws
(set '#:source '#:retries))
(define-syntax (redex-check stx) (define-syntax (redex-check stx)
(syntax-case stx () (define valid-kws
(cons '#:satisfying (map car (list attempts-keyword
source-keyword
retries-keyword
print?-keyword
attempt-size-keyword
(prepare-keyword #f)))))
(define used-kws
(for/fold ([kws (set)])
([maybe-kw-stx (in-list (syntax->list stx))])
(define maybe-kw (syntax-e maybe-kw-stx))
(cond
[(keyword? maybe-kw)
(unless (member maybe-kw valid-kws)
(raise-syntax-error 'redex-check "unknown keyword" stx maybe-kw-stx))
(set-add kws maybe-kw)]
[else kws])))
(define bad-kws (set-intersect used-kws satisfying-disallowed-kws))
(syntax-case stx (=)
[(form lang #:satisfying (mf-id . args) = res property . kw-args)
(unless (set-empty? bad-kws)
(raise-syntax-error 'redex-check (format "~s cannot be used with #:satisfying" (car (set->list bad-kws))) stx))
(redex-check/mf stx #'form #'lang #'mf-id #'args #'res #'property #'kw-args)]
[(form lang #:satisfying (jform-id . pats) property . kw-args)
(unless (set-empty? bad-kws)
(raise-syntax-error 'redex-check (format "~s cannot be used with #:satisfying" (car (set->list bad-kws))) stx))
(redex-check/jf stx #'form #'lang #'jform-id #'pats #'property #'kw-args)]
[(form lang #:satisfying . rest)
(raise-syntax-error 'redex-check "#:satisfying expected judgment form or metafunction syntax followed by a property" stx #'rest)]
[(form lang pat property . kw-args) [(form lang pat property . kw-args)
(with-syntax ([(syncheck-exp pattern (name ...) (name/ellipses ...)) (redex-check/pat stx #'form #'lang #'pat #'property #'kw-args)]))
(rewrite-side-conditions/check-errs
#'lang (define-struct gen-fail ())
'redex-check #t #'pat)]
[show (show-message stx)]) (define-for-syntax (redex-check/jf orig-stx form lang jf-id pats property kw-args)
(let-values ([(attempts-stx source-stx retries-stx print?-stx size-stx fix-stx) (define-values (attempts-stx source-stx retries-stx print?-stx size-stx fix-stx)
(apply values (parse-redex-check-kw-args kw-args orig-stx form))
(parse-kw-args (list attempts-keyword (define nts (definition-nts lang orig-stx 'redex-check))
source-keyword (unless (judgment-form-id? jf-id)
retries-keyword (raise-syntax-error 'redex-check "expected a judgment-form" jf-id))
print?-keyword (define j-f (lookup-judgment-form-id jf-id))
attempt-size-keyword (define clauses (judgment-form-gen-clauses j-f))
(prepare-keyword #f)) (define relation? (judgment-form-relation? j-f))
(syntax kw-args) (define args-stx (if relation?
stx (syntax/loc #'args #`(#,pats))
(syntax-e #'form)))]) pats))
(with-syntax ([property (syntax (with-syntax* ([(syncheck-exp pattern (names ...) (names/ellipses ...))
(bind-prop (rewrite-side-conditions/check-errs lang 'redex-check #t args-stx)]
(λ (bindings) [show (show-message orig-stx)]
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...) [res-term-stx #`(#,jf-id #,@args-stx)]
property))))]) [property #`(bind-prop
(quasisyntax/loc stx (λ (bindings)
(let ([att #,attempts-stx] (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
[ret #,retries-stx] #,property)))])
[print? #,print?-stx] (quasisyntax/loc orig-stx
[fix #,fix-stx] (let ([term-match (λ (generated)
[term-match (λ (generated) (cond [(test-match #,lang res-term-stx generated) => values]
(cond [(test-match lang pat generated) => values] [else (redex-error 'redex-check "~s does not match ~s" generated 'res-term-stx)]))])
[else (redex-error 'redex-check "~s does not match ~s" generated 'pat)]))]) syncheck-exp
syncheck-exp (let ([default-attempt-size (λ (s) (add1 (default-attempt-size s)))])
(parameterize ([attempt->size #,size-stx]) (parameterize ([attempt->size #,size-stx])
#,(if source-stx (check-one
#`(let-values ([(metafunc/red-rel num-cases) (λ (size _1 _2)
#,(cond [(metafunc source-stx) (values
=> (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))] (match ((make-jf-gen/proc '#,jf-id #,clauses #,lang 'pattern size))
[else [(and res (? values)) res]
#`(let ([r #,(apply-contract #'reduction-relation? source-stx [else (gen-fail)])
"#:source argument" (syntax-e #'form))]) #f))
(values r (length (reduction-relation-make-procs r))))])]) property #,attempts-stx 0 (and #,print?-stx show) #,fix-stx term-match)))))))
(check-lhs-pats
lang (define-for-syntax (redex-check/mf orig-stx form lang mf-id args-stx res-stx property kw-args)
metafunc/red-rel (define-values (attempts-stx source-stx retries-stx print?-stx size-stx fix-stx)
property (parse-redex-check-kw-args kw-args orig-stx form))
(max 1 (floor (/ att num-cases))) (define nts (definition-nts lang orig-stx 'redex-check))
ret (define m (metafunc mf-id))
'redex-check (unless m (raise-syntax-error 'generate-term "expected a metafuction" mf-id))
(and print? show) (define mf (syntax-local-value mf-id (λ () #f)))
fix (with-syntax* ([(lhs-syncheck-exp lhs-pat (lhs-names ...) (lhs-names/ellipses ...))
#:term-match term-match)) (rewrite-side-conditions/check-errs lang 'redex-check #t args-stx)]
#`(check-one [(rhs-syncheck-exp rhs-pat (rhs-names ...) (rhs-names/ellipses ...))
#,(term-generator #'lang #'pattern 'redex-check) (rewrite-side-conditions/check-errs lang 'redex-check #t res-stx)]
property att ret (and print? show) fix (and fix term-match)))))))))])) [res-term-stx #`((#,mf-id #,@args-stx) = #,res-stx)]
[mf-id (term-fn-get-id mf)]
[show (show-message orig-stx)]
[property #`(bind-prop
(λ (bindings)
(term-let ([lhs-names/ellipses (lookup-binding bindings 'lhs-names)] ...
[rhs-names/ellipses (lookup-binding bindings 'rhs-names)] ...)
#,property)))])
(quasisyntax/loc orig-stx
(let ([term-match (λ (generated)
(cond [(test-match #,lang res-term-stx generated) => values]
[else (redex-error 'redex-check "~s does not match ~s" generated 'res-term-stx)]))])
lhs-syncheck-exp
rhs-syncheck-exp
(let ([default-attempt-size (λ (s) (add1 (default-attempt-size s)))])
(parameterize ([attempt->size #,size-stx])
(check-one
(λ (size _1 _2)
(values
(match ((make-mf-gen/proc 'mf-id mf-id #,lang 'lhs-pat 'rhs-pat size))
[(and res (? values)) res]
[else (gen-fail)])
#f))
property #,attempts-stx 0 (and #,print?-stx show) #,fix-stx term-match)))))))
(define-for-syntax (redex-check/pat orig-stx form lang pat property kw-args)
(with-syntax ([(syncheck-exp pattern (name ...) (name/ellipses ...))
(rewrite-side-conditions/check-errs
lang
'redex-check #t pat)]
[show (show-message orig-stx)])
(define-values (attempts-stx source-stx retries-stx print?-stx size-stx fix-stx)
(parse-redex-check-kw-args kw-args orig-stx form))
(with-syntax ([property #`(bind-prop
(λ (bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
#,property)))])
(quasisyntax/loc orig-stx
(let ([att #,attempts-stx]
[ret #,retries-stx]
[print? #,print?-stx]
[fix #,fix-stx]
[term-match (λ (generated)
(cond [(test-match #,lang #,pat generated) => values]
[else (redex-error 'redex-check "~s does not match ~s" generated '#,pat)]))])
syncheck-exp
(parameterize ([attempt->size #,size-stx])
#,(if source-stx
#`(let-values ([(metafunc/red-rel num-cases)
#,(cond [(metafunc source-stx)
=> (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))]
[else
#`(let ([r #,(apply-contract #'reduction-relation? source-stx
"#:source argument" (syntax-e form))])
(values r (length (reduction-relation-make-procs r))))])])
(check-lhs-pats
#,lang
metafunc/red-rel
property
(max 1 (floor (/ att num-cases)))
ret
'redex-check
(and print? show)
fix
#:term-match term-match))
#`(check-one
#,(term-generator lang #'pattern 'redex-check)
property att ret (and print? show) fix (and fix term-match)))))))))
(define-for-syntax (parse-redex-check-kw-args kw-args orig-stx form-name)
(apply values
(parse-kw-args (list attempts-keyword
source-keyword
retries-keyword
print?-keyword
attempt-size-keyword
(prepare-keyword #f))
kw-args
orig-stx
(syntax-e form-name))))
(define (format-attempts a) (define (format-attempts a)
(format "~a attempt~a" a (if (= 1 a) "" "s"))) (format "~a attempt~a" a (if (= 1 a) "" "s")))
(define (check-one generator property attempts retries show term-fix term-match) (define (check-one generator property attempts retries show term-fix term-match)
(let ([c (check generator property attempts retries show (define c (check generator property attempts retries show
#:term-fix term-fix #:term-fix term-fix
#:term-match term-match)]) #:term-match term-match))
(if (counterexample? c) (cond
(unless show c) ; check printed it [(counterexample? c)
(if show (unless show c)] ; check printed it
(show (format "no counterexamples in ~a\n" [show
(format-attempts attempts))) (show (format "no counterexamples in ~a\n"
#t)))) (format-attempts attempts)))]
[else
#t]))
(define-struct (exn:fail:redex:test exn:fail:redex) (source term)) (define-struct (exn:fail:redex:test exn:fail:redex) (source term))
(define-struct counterexample (term) #:transparent) (define-struct counterexample (term) #:transparent)
@ -164,49 +277,54 @@
#:term-match [term-match #f] #:term-match [term-match #f]
#:skip-term? [skip-term? (λ (x) #f)]) #:skip-term? [skip-term? (λ (x) #f)])
(let loop ([remaining attempts]) (let loop ([remaining attempts])
(if (zero? remaining) (cond
#t [(zero? remaining)
(let ([attempt (add1 (- attempts remaining))]) #t]
(let-values ([(term bindings) (generator ((attempt->size) attempt) attempt retries)] [else
[(handler) (define attempt (add1 (- attempts remaining)))
(λ (action term) (define-values (raw-term bindings) (generator ((attempt->size) attempt) attempt retries))
(λ (exn) (cond
(let ([msg (format "~a ~s raises an exception" action term)]) [(gen-fail? raw-term)
(when show (show (format "~a\n" msg))) (loop (sub1 remaining))]
(raise [else
(if show (define handler
exn (λ (action term)
(make-exn:fail:redex:test (λ (exn)
(format "~a:\n~a" msg (exn-message exn)) (define msg (format "~a ~s raises an exception" action term))
(current-continuation-marks) (when show (show (format "~a\n" msg)))
exn (raise
term))))))]) (if show
(let ([term (with-handlers ([exn:fail? (handler "fixing" term)]) exn
(if term-fix (term-fix term) term))]) (make-exn:fail:redex:test
(cond (format "~a:\n~a" msg (exn-message exn))
[(skip-term? term) (loop (- remaining 1))] (current-continuation-marks)
[else exn
(if (if term-match term))))))
(let ([bindings (make-bindings (define term (with-handlers ([exn:fail? (handler "fixing" raw-term)])
(match-bindings (if term-fix (term-fix raw-term) raw-term)))
(pick-from-list (term-match term))))]) (cond
(with-handlers ([exn:fail? (handler "checking" term)]) [(skip-term? term) (loop (- remaining 1))]
(match property [(if term-match
[(term-prop pred) (pred term)] (let ([bindings (make-bindings
[(bind-prop pred) (pred bindings)]))) (match-bindings
(with-handlers ([exn:fail? (handler "checking" term)]) (pick-from-list (term-match term))))])
(match (cons property term-fix) (with-handlers ([exn:fail? (handler "checking" term)])
[(cons (term-prop pred) _) (pred term)] (match property
[(cons (bind-prop pred) #f) (pred bindings)]))) [(term-prop pred) (pred term)]
(loop (sub1 remaining)) [(bind-prop pred) (pred bindings)])))
(begin (with-handlers ([exn:fail? (handler "checking" term)])
(when show (match (cons property term-fix)
(show [(cons (term-prop pred) _) (pred term)]
(format "counterexample found after ~a~a:\n" [(cons (bind-prop pred) #f) (pred bindings)])))
(format-attempts attempt) (loop (sub1 remaining))]
(if source (format " with ~a" source) ""))) [else
(pretty-write term (current-output-port))) (when show
(make-counterexample term)))]))))))) (show
(format "counterexample found after ~a~a:\n"
(format-attempts attempt)
(if source (format " with ~a" source) "")))
(pretty-write term (current-output-port)))
(make-counterexample term)])])])))
(define (check-lhs-pats lang mf/rr prop attempts retries what show term-fix (define (check-lhs-pats lang mf/rr prop attempts retries what show term-fix
#:term-match [term-match #f]) #:term-match [term-match #f])
@ -443,9 +561,9 @@
(language-id-nts #'language 'generate-term) ;; for the error side-effect (language-id-nts #'language 'generate-term) ;; for the error side-effect
(unless (judgment-form-id? #'jf-id) (unless (judgment-form-id? #'jf-id)
(raise-syntax-error 'generate-term "expected a judgment-form" #'jf-id)) (raise-syntax-error 'generate-term "expected a judgment-form" #'jf-id))
(syntax-case #'size-maybe () (syntax-case #'size-maybe ()
[() #`(λ (size) (generate-jf-pat language (jf-id . args) size))] [() #`(λ (size) (generate-jf-pat language (jf-id . args) size))]
[(size) #'(generate-jf-pat language (jf-id . args) size)]))])) [(size) #'(generate-jf-pat language (jf-id . args) size)]))]))
(define-syntax (generate-term/source stx) (define-syntax (generate-term/source stx)
(syntax-case stx () (syntax-case stx ()
@ -512,7 +630,7 @@
(syntax-case stx () (syntax-case stx ()
[(g-m-p lang-id (mf-name . lhs-pats) rhs-pat size) [(g-m-p lang-id (mf-name . lhs-pats) rhs-pat size)
#`(parameterize ([unsupported-pat-err-name 'generate-term]) #`(parameterize ([unsupported-pat-err-name 'generate-term])
((make-redex-generator lang-id (mf-name . lhs-pats) = rhs-pat size)))])) ((make-redex-generator lang-id (mf-name . lhs-pats) = rhs-pat size)))]))
(define-syntax (generate-jf-pat stx) (define-syntax (generate-jf-pat stx)
(syntax-case stx () (syntax-case stx ()
@ -583,9 +701,9 @@
[(_ not-lang-id . rest) [(_ not-lang-id . rest)
(not (identifier? #'not-lang-id)) (not (identifier? #'not-lang-id))
(raise-syntax-error 'redex-generator (raise-syntax-error 'redex-generator
"expected an identifier in the language position" "expected an identifier in the language position"
stx stx
#'not-lang-id)])) #'not-lang-id)]))
(define (make-jf-gen/proc jf-id mk-clauses lang pat size) (define (make-jf-gen/proc jf-id mk-clauses lang pat size)
(define gen (search/next (mk-clauses) pat size lang)) (define gen (search/next (mk-clauses) pat size lang))

128
pkgs/redex-pkgs/redex-test/redex/tests/gen-test.rkt
View File

@ -15,6 +15,11 @@
(define-syntax-rule (is-false e) (define-syntax-rule (is-false e)
(test e #f)) (test e #f))
(define-syntax-rule (no-counterexample e)
(test
(counterexample? e)
#f))
(define-language L0) (define-language L0)
(let () (let ()
@ -87,7 +92,7 @@
(test (generate-term nats #:satisfying (sum z z (s z)) 5) (test (generate-term nats #:satisfying (sum z z (s z)) 5)
#f) #f)
(for ([_ 100]) (for ([_ 50])
(match (generate-term nats #:satisfying (sum n_1 n_2 n_3) 5) (match (generate-term nats #:satisfying (sum n_1 n_2 n_3) 5)
[`(sum ,l ,r ,res) [`(sum ,l ,r ,res)
(test (judgment-holds (sum ,l ,r n) n) (test (judgment-holds (sum ,l ,r n) n)
@ -95,7 +100,26 @@
(match (generate-term nats #:satisfying (r-sum n_1 n_2 n_3) 5) (match (generate-term nats #:satisfying (r-sum n_1 n_2 n_3) 5)
[`(r-sum ,l ,r ,res) [`(r-sum ,l ,r ,res)
(test (term (r-sum ,l ,r ,res)) (test (term (r-sum ,l ,r ,res))
#t)]))) #t)]))
(no-counterexample
(redex-check nats
#:satisfying
(sum n_1 n_2 n_3)
(equal? (car (judgment-holds
(sum n_1 n_2 n_4) n_4))
(term n_3))
#:attempts 50
#:print? #f))
(no-counterexample
(redex-check nats
#:satisfying
(r-sum n_1 n_2 n_3)
(judgment-holds
(sum n_1 n_2 n_3))
#:attempts 50
#:print? #f))
)
(let () (let ()
@ -131,14 +155,24 @@
(not (generate-term lists #:satisfying (not-in a (b (c (d (e (f ())))))) +inf.0)) (not (generate-term lists #:satisfying (not-in a (b (c (d (e (f ())))))) +inf.0))
#f) #f)
(for/and ([_ 100]) (for/and ([_ 50])
(match (generate-term lists #:satisfying (not-in a l) 5) (match (generate-term lists #:satisfying (not-in a l) 5)
[`(not-in a ,l) [`(not-in a ,l)
(unless (judgment-holds (not-in a ,l)) (printf "l: ~s\n" l)) (unless (judgment-holds (not-in a ,l)) (printf "l: ~s\n" l))
(test (judgment-holds (not-in a ,l)) (test (judgment-holds (not-in a ,l))
#t)] #t)]
[#f [#f
(void)]))) (void)]))
(no-counterexample
(redex-check lists
#:satisfying
(not-in x l)
(judgment-holds (not-in x l))
#:attempts 50
#:print? #f))
)
(let () (let ()
@ -174,7 +208,7 @@
[(double (+ e_1 e_2) e_3) [(double (+ e_1 e_2) e_3)
(where e_3 (+ (+ e_1 e_1) (+ e_2 e_2)))]) (where e_3 (+ (+ e_1 e_1) (+ e_2 e_2)))])
(for ([_ 100]) (for ([_ 50])
(define t (generate-term simple #:satisfying (double e_1 e_2) +inf.0)) (define t (generate-term simple #:satisfying (double e_1 e_2) +inf.0))
(match t (match t
[`(double ,e1 ,e2) [`(double ,e1 ,e2)
@ -183,6 +217,15 @@
[#f [#f
(void)])) (void)]))
(no-counterexample
(redex-check simple
#:satisfying
(double e_1 e_2)
(judgment-holds
(double e_1 e_2))
#:attempts 50
#:print? #f))
(define-metafunction simple (define-metafunction simple
[(duplicate e_1 e_1) [(duplicate e_1 e_1)
(+ e_1 e_1 e_1)] (+ e_1 e_1 e_1)]
@ -220,14 +263,25 @@
(test (judgment-holds (double2 (+ 2 2) (+ 2 2 2))) (test (judgment-holds (double2 (+ 2 2) (+ 2 2 2)))
#t) #t)
(for ([_ 100]) (for ([_ 50])
(define t (generate-term simple #:satisfying (double2 e_1 e_2) +inf.0)) (define t (generate-term simple #:satisfying (double2 e_1 e_2) +inf.0))
(match t (match t
[`(double2 ,e1 ,e2) [`(double2 ,e1 ,e2)
(test (judgment-holds (double2 ,e1 ,e2)) (test (judgment-holds (double2 ,e1 ,e2))
#t)] #t)]
[#f [#f
(void)]))) (void)]))
(no-counterexample
(redex-check simple
#:satisfying
(double2 e_1 e_2)
(judgment-holds
(double2 e_1 e_2))
#:attempts 50
#:print? #f))
)
(let () (let ()
(define-language STLC (define-language STLC
@ -283,7 +337,7 @@
(test (judgment-holds (typeof ([x_2 int] ([x_1 (int → int)] •)) (x_1 5) int)) (test (judgment-holds (typeof ([x_2 int] ([x_1 (int → int)] •)) (x_1 5) int))
#t) #t)
(for ([_ 100]) (for ([_ 50])
(define term (generate-term STLC #:satisfying (typeof Γ e τ) 6)) (define term (generate-term STLC #:satisfying (typeof Γ e τ) 6))
(match term (match term
[`(typeof ,g ,e ,t) [`(typeof ,g ,e ,t)
@ -292,7 +346,17 @@
[#f [#f
(void)])) (void)]))
(for ([_ 100]) (no-counterexample
(redex-check STLC
#:satisfying
(typeof Γ e τ)
(equal? (car (judgment-holds
(typeof Γ e τ_2) τ_2))
(term τ))
#:attempts 50
#:print? #f))
(for ([_ 50])
(define term (generate-term if-l #:satisfying (typ-if Γ e τ) 5)) (define term (generate-term if-l #:satisfying (typ-if Γ e τ) 5))
(match term (match term
[`(typ-if ,g ,e ,t) [`(typ-if ,g ,e ,t)
@ -301,8 +365,18 @@
[#f [#f
(void)])) (void)]))
(no-counterexample
(redex-check STLC
#:satisfying
(typ-if Γ e τ)
(equal? (car (judgment-holds
(typ-if Γ e τ_2) τ_2))
(term τ))
#:attempts 50
#:print? #f))
(define g (redex-generator STLC (typeof • e τ) 5)) (define g (redex-generator STLC (typeof • e τ) 5))
(define terms (filter values (for/list ([_ 400]) (g)))) (define terms (filter values (for/list ([_ 100]) (g))))
(test (length terms) (test (length terms)
(length (remove-duplicates terms))) (length (remove-duplicates terms)))
(map (match-lambda (map (match-lambda
@ -337,7 +411,7 @@
(test (generate-term l #:satisfying (filtered (1 (2 (3 (4 •)))) 5 (1 (2 (4 •)))) +inf.0) (test (generate-term l #:satisfying (filtered (1 (2 (3 (4 •)))) 5 (1 (2 (4 •)))) +inf.0)
#f) #f)
(for ([_ 50]) (for ([_ 25])
(define term (generate-term l #:satisfying (filtered e_1 n e_2) 5)) (define term (generate-term l #:satisfying (filtered e_1 n e_2) 5))
(match term (match term
[`(filtered ,e1 ,n ,e2) [`(filtered ,e1 ,n ,e2)
@ -346,7 +420,17 @@
[#f [#f
(void)])) (void)]))
(for ([_ 50]) (no-counterexample
(redex-check l
#:satisfying
(filtered e_1 n e_2)
(equal? (car (judgment-holds
(filtered e_1 n e_3) e_3))
(term e_2))
#:attempts 25
#:print? #f))
(for ([_ 25])
(define t (generate-term l #:satisfying (fltr n e) = e_1 5)) (define t (generate-term l #:satisfying (fltr n e) = e_1 5))
(match t (match t
[`((fltr ,n ,e) = ,e1) [`((fltr ,n ,e) = ,e1)
@ -354,6 +438,14 @@
[#f [#f
(void)])) (void)]))
(no-counterexample
(redex-check l
#:satisfying
(fltr n e) = e_1
(equal? (term (fltr n e)) (term e_1))
#:attempts 25
#:print? #f))
(define g (redex-generator l (fltr n e_1) = e_2 5)) (define g (redex-generator l (fltr n e_1) = e_2 5))
(define terms (filter values (for/list ([_ 50]) (g)))) (define terms (filter values (for/list ([_ 50]) (g))))
(test (length terms) (test (length terms)
@ -550,7 +642,17 @@
(test (generate-term l #:satisfying (t 6 7) = 2 +inf.0) (test (generate-term l #:satisfying (t 6 7) = 2 +inf.0)
#f) #f)
(test (generate-term l #:satisfying (t 6 7) = 1 +inf.0) (test (generate-term l #:satisfying (t 6 7) = 1 +inf.0)
#f)) #f)
(no-counterexample
(redex-check l
#:satisfying
(t n_1 n_2) = n_3
(equal? (term (t n_1 n_2)) (term n_3))
#:attempts 50
#:print? #f))
)
(let () (let ()
(define-judgment-form L0 (define-judgment-form L0