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

Dropped the "preferred productions" heuristic and the failed prototype

Browse Source 
supporting accumulator-style generators.

svn: r17851
This commit is contained in:
Casey Klein 2010-01-27 15:52:15 +00:00
parent 980d48ce19
commit 4271b7970c
2 changed files with 119 additions and 352 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

296
collects/redex/private/rg.ss
View File

@ -14,9 +14,6 @@
(define (exotic-choice? [random random]) (= 0 (random 5))) (define (exotic-choice? [random random]) (= 0 (random 5)))
(define (use-lang-literal? [random random]) (= 0 (random 20))) (define (use-lang-literal? [random random]) (= 0 (random 20)))
(define (preferred-production? attempt [random random])
(and (>= attempt preferred-production-threshold)
(zero? (random 2))))
(define default-check-attempts 1000) (define default-check-attempts 1000)
@ -57,27 +54,8 @@
(define (pick-string lang-lits attempt [random random]) (define (pick-string lang-lits attempt [random random])
(random-string lang-lits (random-natural 1/5 random) attempt random)) (random-string lang-lits (random-natural 1/5 random) attempt random))
(define (pick-nt name cross? lang attempt pref-prods (define (pick-nts name cross? lang attempt)
[random random] (nt-rhs (nt-by-name lang name cross?)))
[pref-prod? preferred-production?])
(let ([prods (nt-rhs (nt-by-name lang name cross?))])
(cond [(and pref-prods (pref-prod? attempt random))
(hash-ref
((if cross? pref-prods-cross pref-prods-non-cross)
pref-prods)
name)]
[else prods])))
(define-struct pref-prods (cross non-cross))
(define (pick-preferred-productions lang)
(let ([pick (λ (sel)
(for/hash ([nt (sel lang)])
(values (nt-name nt)
(list (pick-from-list (nt-rhs nt))))))])
(make-pref-prods
(pick compiled-lang-cclang)
(pick compiled-lang-lang))))
(define (pick-from-list l [random random]) (list-ref l (random (length l)))) (define (pick-from-list l [random random]) (list-ref l (random (length l))))
@ -118,9 +96,6 @@
(define proportion-at-size 1/10) (define proportion-at-size 1/10)
(define post-threshold-incr 50) (define post-threshold-incr 50)
(define preferred-production-threshold
(+ retry-threshold 2000))
;; Determines the parameter p for which random-natural's expected value is E ;; Determines the parameter p for which random-natural's expected value is E
(define (expected-value->p E) (define (expected-value->p E)
;; E = 0 => p = 1, which breaks random-natural ;; E = 0 => p = 1, which breaks random-natural
@ -177,11 +152,11 @@
who what attempts (if (= attempts 1) "" "s"))]) who what attempts (if (= attempts 1) "" "s"))])
(raise (make-exn:fail:redex:generation-failure str (current-continuation-marks))))) (raise (make-exn:fail:redex:generation-failure str (current-continuation-marks)))))
(define (generate lang decisions@ user-gen retries what) (define (generate lang decisions@ retries what)
(define-values/invoke-unit decisions@ (define-values/invoke-unit decisions@
(import) (export decisions^)) (import) (export decisions^))
(define ((generate-nt lang base-cases generate pref-prods) (define ((generate-nt lang base-cases generate)
name cross? size attempt in-hole env) name cross? size attempt in-hole env)
(let*-values (let*-values
([(term _) ([(term _)
@ -193,7 +168,7 @@
(min-prods (nt-by-name lang name cross?) (min-prods (nt-by-name lang name cross?)
((if cross? base-cases-cross base-cases-non-cross) ((if cross? base-cases-cross base-cases-non-cross)
base-cases)) base-cases))
((next-non-terminal-decision) name cross? lang attempt pref-prods)))]) ((next-non-terminal-decision) name cross? lang attempt)))])
(generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs)))) (generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs))))
(λ (_ env) (mismatches-satisfied? env)) (λ (_ env) (mismatches-satisfied? env))
size attempt)]) size attempt)])
@ -279,114 +254,101 @@
(cons (make-bind (binder-name key) val) bindings) (cons (make-bind (binder-name key) val) bindings)
bindings)))) bindings))))
(define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat) (define (generate-pat lang sexp size attempt env in-hole pat)
(define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt)) (define recur (curry generate-pat lang sexp size attempt))
(define recur/pat (recur env in-hole)) (define recur/pat (recur env in-hole))
(define ((recur/pat/size-attempt pat) size attempt) (define ((recur/pat/size-attempt pat) size attempt)
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)) (generate-pat lang sexp size attempt env in-hole pat))
(define clang (rg-lang-clang lang)) (define clang (rg-lang-clang lang))
(define gen-nt (define gen-nt
(generate-nt (generate-nt
clang clang
(rg-lang-base-cases lang) (rg-lang-base-cases lang)
(curry generate-pat lang sexp pref-prods user-gen user-acc) (curry generate-pat lang sexp)))
pref-prods))
(define (default-gen user-acc) (match pat
(match pat [`number (values ((next-number-decision) attempt) env)]
[`number (values ((next-number-decision) attempt) env)] [`natural (values ((next-natural-decision) attempt) env)]
[`natural (values ((next-natural-decision) attempt) env)] [`integer (values ((next-integer-decision) attempt) env)]
[`integer (values ((next-integer-decision) attempt) env)] [`real (values ((next-real-decision) attempt) env)]
[`real (values ((next-real-decision) attempt) env)] [`(variable-except ,vars ...)
[`(variable-except ,vars ...) (generate/pred 'variable
(generate/pred 'variable (recur/pat/size-attempt 'variable)
(recur/pat/size-attempt 'variable) (λ (var _) (not (memq var vars)))
(λ (var _) (not (memq var vars))) size attempt)]
size attempt)] [`variable
[`variable (values ((next-variable-decision) (rg-lang-lits lang) attempt)
(values ((next-variable-decision) (rg-lang-lits lang) attempt) env)]
env)] [`variable-not-otherwise-mentioned
[`variable-not-otherwise-mentioned (generate/pred 'variable
(generate/pred 'variable (recur/pat/size-attempt 'variable)
(recur/pat/size-attempt 'variable) (λ (var _) (not (memq var (compiled-lang-literals clang))))
(λ (var _) (not (memq var (compiled-lang-literals clang)))) size attempt)]
size attempt)] [`(variable-prefix ,prefix)
[`(variable-prefix ,prefix) (define (symbol-append prefix suffix)
(define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) (let-values ([(term env) (recur/pat 'variable)])
(let-values ([(term env) (recur/pat 'variable)]) (values (symbol-append prefix term) env))]
(values (symbol-append prefix term) env))] [`string
[`string (values ((next-string-decision) (rg-lang-lits lang) attempt)
(values ((next-string-decision) (rg-lang-lits lang) attempt) env)]
env)] [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) (recur/pat/size-attempt pat)
(recur/pat/size-attempt pat) (λ (_ env) (condition (bindings env)))
(λ (_ env) (condition (bindings env))) size attempt)]
size attempt)] [`(name ,(? symbol? id) ,p)
[`(name ,(? symbol? id) ,p) (let-values ([(term env) (recur/pat p)])
(let-values ([(term env) (recur/pat p)]) (values term (hash-set env (make-binder id) term)))]
(values term (hash-set env (make-binder id) term)))] [`hole (values in-hole env)]
[`hole (values in-hole env)] [`(in-hole ,context ,contractum)
[`(in-hole ,context ,contractum) (let-values ([(term env) (recur/pat contractum)])
(let-values ([(term env) (recur/pat contractum)]) (recur env term context))]
(recur env term context))] [`(hide-hole ,pattern) (recur env the-hole pattern)]
[`(hide-hole ,pattern) (recur env the-hole pattern)] [`any
[`any (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] [(term _) (generate-pat new-lang
; Don't use preferred productions for the sexp language. sexp
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)] size
[(term _) (generate-pat new-lang attempt
sexp empty-env
pref-prods the-hole
user-gen nt)])
user-acc (values term env))]
size [(? (is-nt? clang))
attempt (values (gen-nt pat #f size attempt in-hole env) env)]
empty-env [(struct binder ((or (? (is-nt? clang) nt)
the-hole (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
nt)]) (generate/prior pat env (λ () (recur/pat nt)))]
(values term env))] [(struct binder ((or (? built-in? b)
[(? (is-nt? clang)) (app (symbol-match named-nt-rx) (? built-in? b)))))
(values (gen-nt pat #f size attempt in-hole env) env)] (generate/prior pat env (λ () (recur/pat b)))]
[(struct binder ((or (? (is-nt? clang) nt) [(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))) (? symbol? (? (is-nt? clang) nt)))))
(generate/prior pat env (λ () (recur/pat nt)))] (let-values ([(term _) (recur/pat nt)])
[(struct binder ((or (? built-in? b) (values term (hash-set env pat term)))]
(app (symbol-match named-nt-rx) (? built-in? b))))) [(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(generate/prior pat env (λ () (recur/pat b)))] (? symbol? (? built-in? b)))))
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (let-values ([(term _) (recur/pat b)])
(? symbol? (? (is-nt? clang) nt))))) (values term (hash-set env pat term)))]
(let-values ([(term _) (recur/pat nt)]) [`(cross ,(? symbol? cross-nt))
(values term (hash-set env pat term)))] (values (gen-nt cross-nt #t size attempt in-hole env) env)]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
(? symbol? (? built-in? b))))) [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let-values ([(term _) (recur/pat b)]) (let*-values ([(length) (let ([prior (hash-ref env class #f)])
(values term (hash-set env pat term)))] (if prior prior ((next-sequence-decision) attempt)))]
[`(cross ,(? symbol? cross-nt)) [(seq env) (generate-sequence ellipsis recur env length)]
(values (gen-nt cross-nt #t size attempt in-hole env) env)] [(rest env) (recur (hash-set (hash-set env class length) name length)
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)] in-hole rest)])
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) (values (append seq rest) env))]
(let*-values ([(length) (let ([prior (hash-ref env class #f)]) [(list-rest pat rest)
(if prior prior ((next-sequence-decision) attempt)))] (let*-values
[(seq env) (generate-sequence ellipsis recur env length)] ([(pat-term env) (recur/pat pat)]
[(rest env) (recur (hash-set (hash-set env class length) name length) [(rest-term env) (recur env in-hole rest)])
in-hole rest)]) (values (cons pat-term rest-term) env))]
(values (append seq rest) env))] [else
[(list-rest pat rest) (error what "unknown pattern ~s\n" pat)]))
(let*-values
([(pat-term env) (recur/pat pat)]
[(rest-term env) (recur env in-hole rest)])
(values (cons pat-term rest-term) env))]
[else
(error what "unknown pattern ~s\n" pat)]))
(user-gen
pat size in-hole user-acc env attempt
(λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env])
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
default-gen))
(let ([rg-lang (prepare-lang lang)] (let ([rg-lang (prepare-lang lang)]
[rg-sexp (prepare-lang sexp)]) [rg-sexp (prepare-lang sexp)])
@ -400,9 +362,6 @@
(generate-pat (generate-pat
rg-lang rg-lang
rg-sexp rg-sexp
((next-pref-prods-decision) (rg-lang-clang rg-lang))
user-gen
#f
size size
attempt attempt
empty-env empty-env
@ -684,26 +643,24 @@
(define (defer-all pat size in-hole acc env att recur defer) (define (defer-all pat size in-hole acc env att recur defer)
(defer acc)) (defer acc))
(define-for-syntax (term-generator lang pat decisions@ custom retries what) (define-for-syntax (term-generator lang pat decisions@ retries what)
(with-syntax ([pattern (with-syntax ([pattern
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
(language-id-nts lang what) (language-id-nts lang what)
what #t pat)]) what #t pat)])
#`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern))) #`((generate #,lang #,decisions@ #,retries '#,what) `pattern)))
(define-syntax (generate-term stx) (define-syntax (generate-term stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang pat size . kw-args) [(_ lang pat size . kw-args)
(with-syntax ([(attempt retries custom) (with-syntax ([(attempt retries)
(parse-kw-args `((#:attempt . 1) (parse-kw-args `((#:attempt . 1)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries))
(#:custom . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx)]) stx)])
(with-syntax ([generate (term-generator #'lang (with-syntax ([generate (term-generator #'lang
#'pat #'pat
#'(generation-decisions) #'(generation-decisions)
#'custom
#'retries #'retries
'generate-term)]) 'generate-term)])
(syntax/loc stx (syntax/loc stx
@ -734,12 +691,11 @@
(let-values ([(names names/ellipses) (let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'redex-check) (extract-names (language-id-nts #'lang 'redex-check)
'redex-check #t #'pat)] 'redex-check #t #'pat)]
[(attempts-stx source-stx retries-stx custom-stx) [(attempts-stx source-stx retries-stx)
(apply values (apply values
(parse-kw-args `((#:attempts . ,#'default-check-attempts) (parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:source . #f) (#:source . #f)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries))
(#:custom . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx))]) stx))])
(with-syntax ([(name ...) names] (with-syntax ([(name ...) names]
@ -751,18 +707,7 @@
property)))]) property)))])
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([att (assert-nat 'redex-check #,attempts-stx)] (let ([att (assert-nat 'redex-check #,attempts-stx)]
[ret (assert-nat 'redex-check #,retries-stx)] [ret (assert-nat 'redex-check #,retries-stx)])
[custom (contract
(-> any/c natural-number/c any/c any/c hash? natural-number/c
(->* (any/c)
(#:size natural-number/c
#:contractum any/c
#:acc any/c
#:env hash?)
(values any/c hash?))
(-> any/c (values any/c hash?))
(values any/c hash?))
#,custom-stx '+ '-)])
(unsyntax (unsyntax
(if source-stx (if source-stx
#`(let-values ([(metafunc/red-rel num-cases) #`(let-values ([(metafunc/red-rel num-cases)
@ -776,7 +721,6 @@
metafunc/red-rel metafunc/red-rel
property property
random-decisions@ random-decisions@
custom
(max 1 (floor (/ att num-cases))) (max 1 (floor (/ att num-cases)))
ret ret
'redex-check 'redex-check
@ -784,7 +728,7 @@
(test-match lang pat) (test-match lang pat)
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) (λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
#`(check-prop #`(check-prop
#,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check) #,(term-generator #'lang #'pat #'random-decisions@ #'ret 'redex-check)
property att show))) property att show)))
(void))))))])) (void))))))]))
@ -831,10 +775,9 @@
[(_ name . kw-args) [(_ name . kw-args)
(identifier? #'name) (identifier? #'name)
(with-syntax ([m (metafunc/err #'name stx)] (with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries custom) [(attempts retries)
(parse-kw-args `((#:attempts . ,#'default-check-attempts) (parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries))
(#:custom . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx)] stx)]
[show (show-message stx)]) [show (show-message stx)])
@ -844,7 +787,7 @@
[decisions@ (generation-decisions)] [decisions@ (generation-decisions)]
[att (assert-nat 'check-metafunction-contract attempts)]) [att (assert-nat 'check-metafunction-contract attempts)])
(check-prop (check-prop
((generate lang decisions@ custom retries 'check-metafunction-contract) ((generate lang decisions@ retries 'check-metafunction-contract)
(if dom dom '(any (... ...)))) (if dom dom '(any (... ...))))
(λ (t _) (λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)]) (with-handlers ([exn:fail:redex? (λ (_) #f)])
@ -852,10 +795,10 @@
att att
show))))])) show))))]))
(define (check-lhs-pats lang mf/rr prop decisions@ custom attempts retries what show (define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show
[match #f] [match #f]
[match-fail #f]) [match-fail #f])
(let ([lang-gen (generate lang decisions@ custom retries what)]) (let ([lang-gen (generate lang decisions@ retries what)])
(let-values ([(pats srcs) (let-values ([(pats srcs)
(cond [(metafunc-proc? mf/rr) (cond [(metafunc-proc? mf/rr)
(values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr)) (values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
@ -884,10 +827,9 @@
(syntax-case stx () (syntax-case stx ()
[(_ name property . kw-args) [(_ name property . kw-args)
(with-syntax ([m (metafunc/err #'name stx)] (with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries custom) [(attempts retries)
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries))
(#:custm . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx)] stx)]
[show (show-message stx)]) [show (show-message stx)])
@ -899,7 +841,6 @@
m m
(λ (term _) (property term)) (λ (term _) (property term))
(generation-decisions) (generation-decisions)
custom
att att
ret ret
'check-metafunction 'check-metafunction
@ -917,11 +858,10 @@
(define-syntax (check-reduction-relation stx) (define-syntax (check-reduction-relation stx)
(syntax-case stx () (syntax-case stx ()
[(_ relation property . kw-args) [(_ relation property . kw-args)
(with-syntax ([(attempts retries decisions@ custom) (with-syntax ([(attempts retries decisions@)
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:decisions . ,#'random-decisions@) (#:decisions . ,#'random-decisions@))
(#:custom . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx)] stx)]
[show (show-message stx)]) [show (show-message stx)])
@ -934,7 +874,6 @@
rel rel
(λ (term _) (property term)) (λ (term _) (property term))
decisions@ decisions@
custom
attempts attempts
retries retries
'check-reduction-relation 'check-reduction-relation
@ -949,8 +888,7 @@
next-non-terminal-decision next-non-terminal-decision
next-sequence-decision next-sequence-decision
next-any-decision next-any-decision
next-string-decision next-string-decision))
next-pref-prods-decision))
(define random-decisions@ (define random-decisions@
(unit (import) (export decisions^) (unit (import) (export decisions^)
@ -959,11 +897,10 @@
(define (next-natural-decision) pick-natural) (define (next-natural-decision) pick-natural)
(define (next-integer-decision) pick-integer) (define (next-integer-decision) pick-integer)
(define (next-real-decision) pick-real) (define (next-real-decision) pick-real)
(define (next-non-terminal-decision) pick-nt) (define (next-non-terminal-decision) pick-nts)
(define (next-sequence-decision) pick-sequence-length) (define (next-sequence-decision) pick-sequence-length)
(define (next-any-decision) pick-any) (define (next-any-decision) pick-any)
(define (next-string-decision) pick-string) (define (next-string-decision) pick-string)))
(define (next-pref-prods-decision) pick-preferred-productions)))
(define generation-decisions (make-parameter random-decisions@)) (define generation-decisions (make-parameter random-decisions@))
@ -978,19 +915,16 @@
(struct-out mismatch) (struct-out mismatch)
(struct-out class) (struct-out class)
(struct-out binder) (struct-out binder)
(struct-out base-cases) (struct-out base-cases))
(struct-out pref-prods))
(provide pick-from-list pick-sequence-length (provide pick-from-list pick-sequence-length pick-nts
pick-char pick-var pick-string pick-char pick-var pick-string pick-any
pick-nt pick-any pick-preferred-productions
pick-number pick-natural pick-integer pick-real pick-number pick-natural pick-integer pick-real
parse-pattern unparse-pattern parse-pattern unparse-pattern
parse-language prepare-lang parse-language prepare-lang
class-reassignments reassign-classes class-reassignments reassign-classes
default-retries proportion-at-size default-retries proportion-at-size
preferred-production-threshold retry-threshold retry-threshold proportion-before-threshold post-threshold-incr
proportion-before-threshold post-threshold-incr
is-nt? nt-by-name min-prods is-nt? nt-by-name min-prods
generation-decisions decisions^ generation-decisions decisions^
random-string random-string

175
collects/redex/tests/rg-test.ss
View File

@ -111,23 +111,6 @@
(test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc") (test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc")
(test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc)) (test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc))
(let ()
(define-language L
(a 5 (x a))
(b 4))
(test (pick-nt 'a #f L 1 'dontcare)
(nt-rhs (car (compiled-lang-lang L))))
(test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1))
(nt-rhs (car (compiled-lang-lang L))))
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
(test (pick-nt 'a #f L preferred-production-threshold
(make-pref-prods 'dont-care
(make-immutable-hash `((a ,pref))))
(make-random 0))
(list pref)))
(test (pick-nt 'b #f L preferred-production-threshold #f)
(nt-rhs (cadr (compiled-lang-lang L)))))
(define-syntax raised-exn-msg (define-syntax raised-exn-msg
(syntax-rules () (syntax-rules ()
[(_ expr) (raised-exn-msg exn:fail? expr)] [(_ expr) (raised-exn-msg exn:fail? expr)]
@ -141,7 +124,7 @@
(define (patterns . selectors) (define (patterns . selectors)
(map (λ (selector) (map (λ (selector)
(λ (name cross? lang size pref-prods) (λ (name cross? lang sizes)
(list (selector (nt-rhs (nt-by-name lang name cross?)))))) (list (selector (nt-rhs (nt-by-name lang name cross?))))))
selectors)) selectors))
@ -158,15 +141,14 @@
(test (raised-exn-msg (iter)) #rx"empty")) (test (raised-exn-msg (iter)) #rx"empty"))
(define (decisions #:var [var pick-var] (define (decisions #:var [var pick-var]
#:nt [nt pick-nt] #:nt [nt pick-nts]
#:str [str pick-string] #:str [str pick-string]
#:num [num pick-number] #:num [num pick-number]
#:nat [nat pick-natural] #:nat [nat pick-natural]
#:int [int pick-integer] #:int [int pick-integer]
#:real [real pick-real] #:real [real pick-real]
#:any [any pick-any] #:any [any pick-any]
#:seq [seq pick-sequence-length] #:seq [seq pick-sequence-length])
#:pref [pref pick-preferred-productions])
(define-syntax decision (define-syntax decision
(syntax-rules () (syntax-rules ()
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
@ -179,8 +161,7 @@
(define next-real-decision (decision real)) (define next-real-decision (decision real))
(define next-string-decision (decision str)) (define next-string-decision (decision str))
(define next-any-decision (decision any)) (define next-any-decision (decision any))
(define next-sequence-decision (decision seq)) (define next-sequence-decision (decision seq))))
(define next-pref-prods-decision (decision pref))))
(define-syntax generate-term/decisions (define-syntax generate-term/decisions
(syntax-rules () (syntax-rules ()
@ -539,71 +520,6 @@
(get-output-string p) (get-output-string p)
(close-output-port p)))) (close-output-port p))))
;; preferred productions
(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
(define-language L
(e (+ e e) (* e e) 7))
(define-language M (e 0) (e-e 1))
(let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))])
(test
(generate-term/decisions
L e 2 preferred-production-threshold
(decisions #:pref (list (λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(car (pats L))))))))
#:nt (make-pick-nt (make-random 0 0 0))))
'(+ (+ 7 7) (+ 7 7)))
(test
(generate-term/decisions
L any 2 preferred-production-threshold
(decisions #:nt (patterns first)
#:var (list (λ _ 'x))
#:any (list (λ (lang sexp) (values sexp 'sexp)))))
'x)
(test
(generate-term/decisions
L any 2 preferred-production-threshold
(decisions #:pref (list (λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(car (pats L))))))))
#:nt (make-pick-nt (make-random 0 0 0))
#:any (list (λ (lang sexp) (values lang 'e)))))
'(+ (+ 7 7) (+ 7 7)))
(test
(generate-term/decisions
M (cross e) 2 preferred-production-threshold
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
(term hole))
(test
(generate-term/decisions
M e-e 2 preferred-production-threshold
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
1)
(test
(let ([generated null])
(output
(λ ()
(check-reduction-relation
(reduction-relation L (--> e e))
(λ (t) (set! generated (cons t generated)))
#:decisions (decisions #:nt (make-pick-nt (make-random)
(λ (att rand) #t))
#:pref (list (λ (_) 'dontcare)
(λ (_) 'dontcare)
(λ (_) 'dontcare)
; size 0 terms prior to this attempt
(λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(car (pats L)))))))
(λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(cadr (pats L)))))))))
#:attempts 5)))
generated)
'((* 7 7) (+ 7 7) 7 7 7))))
;; redex-check ;; redex-check
(let () (let ()
(define-language lang (define-language lang
@ -890,89 +806,6 @@
(check-metafunction n (λ (_) #t) #:retries 42)) (check-metafunction n (λ (_) #t) #:retries 42))
#rx"check-metafunction: unable .* in 42")) #rx"check-metafunction: unable .* in 42"))
;; custom generators
(let ()
(define-language L
(x variable))
(test
(generate-term
L x_1 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['x (values 'x env)]
[_ (def acc)])))
'x)
(test
(let/ec k
(equal?
(generate-term
L (x x) 0
#:custom (let ([once? #f])
(λ (pat sz i-h acc env att rec def)
(match pat
['x (if once?
(k #f)
(begin
(set! once? #t)
(values 'x env)))]
[_ (def acc)]))))
'(x x)))
#t)
(test
(hash-ref
(let/ec k
(generate-term
L (x (x)) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
[(struct binder ('x))
(values 'y (hash-set env pat 'y))]
[(list (struct binder ('x))) (k env)]
[_ (def acc)]))))
(make-binder 'x))
'y)
(test
(generate-term
L (in-hole hole 7) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
[`(in-hole hole 7)
(rec 'hole #:contractum 7)]
[_ (def acc)])))
7)
(test
(let/ec k
(generate-term
L any 10
#:attempt 42
#:custom (λ (pat sz i-h acc env att rec def) (k (list sz att)))))
'(10 42))
(test
(let/ec k
(generate-term
L x 10
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['x (rec 7 #:size 0)]
[7 (k sz)]
[_ (def att)]))))
0)
(test
(generate-term
L (q 7) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['q (rec '(7 7) #:acc 8)]
[7 (values (or acc 7) env)]
[_ (def att)])))
'((8 8) 7)))
;; parse/unparse-pattern ;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
(define-language lang (x variable)) (define-language lang (x variable))