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

Another generator optimization

Browse Source 
svn: r17902
This commit is contained in:
Casey Klein 2010-01-30 22:36:44 +00:00
parent aa67a279ab
commit d9e5d3aa98
2 changed files with 121 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -158,22 +158,16 @@
([(productions) ([(productions)
(hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)] (hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)]
[(term _) [(term _)
(generate/pred
name
(λ (size attempt)
(let ([gen (pick-from-list (let ([gen (pick-from-list
(if (zero? size) (if (zero? size)
(min-prods name productions (min-prods name productions
((if cross? base-cases-cross base-cases-non-cross) ((if cross? base-cases-cross base-cases-non-cross)
(rg-lang-base-cases lang))) (rg-lang-base-cases lang)))
((next-non-terminal-decision) productions)))]) ((next-non-terminal-decision) productions)))])
(gen retries (max 0 (sub1 size)) attempt empty-env in-hole))) (gen retries (max 0 (sub1 size)) attempt empty-env in-hole))])
(λ (_ env) (mismatches-satisfied? env))
size attempt retries)])
term)) term))
(define (generate/pred name gen pred init-sz init-att retries) (define (generate/pred name gen pred init-sz init-att retries)
#;(gen init-sz init-att)
(let ([pre-threshold-incr (let ([pre-threshold-incr
(ceiling (ceiling
(/ (- retry-threshold init-att) (/ (- retry-threshold init-att)
@ -258,15 +252,17 @@
(letrec-values (letrec-values
([(compile) ([(compile)
(λ (pat any?) (λ (pat any?)
(let ([nt? (is-nt? (if any? sexpp langp))]) (let* ([nt? (is-nt? (if any? sexpp langp))]
; retries size attempt env in-hole -> (values term env) [mismatches? #f]
[generator ; retries size attempt env in-hole -> (values term env)
(let recur ([pat pat])
(match pat (match pat
[`number (λ (r s a e h) (values ((next-number-decision) a) e))] [`number (λ (r s a e h) (values ((next-number-decision) a) e))]
[`natural (λ (r s a e h) (values ((next-natural-decision) a) e))] [`natural (λ (r s a e h) (values ((next-natural-decision) a) e))]
[`integer (λ (r s a e h) (values ((next-integer-decision) a) e))] [`integer (λ (r s a e h) (values ((next-integer-decision) a) e))]
[`real (λ (r s a e h) (values ((next-real-decision) a) e))] [`real (λ (r s a e h) (values ((next-real-decision) a) e))]
[`(variable-except ,vars ...) [`(variable-except ,vars ...)
(let ([g (compile 'variable any?)]) (let ([g (recur 'variable)])
(λ (r s a e h) (λ (r s a e h)
(generate/pred pat (generate/pred pat
(λ (s a) (g r s a e h)) (λ (s a) (g r s a e h))
@ -276,7 +272,7 @@
(λ (r s a e h) (λ (r s a e h)
(values ((next-variable-decision) lits a) e))] (values ((next-variable-decision) lits a) e))]
[`variable-not-otherwise-mentioned [`variable-not-otherwise-mentioned
(let ([g (compile 'variable any?)]) (let ([g (recur 'variable)])
(λ (r s a e h) (λ (r s a e h)
(generate/pred pat (generate/pred pat
(λ (s a) (g r s a e h)) (λ (s a) (g r s a e h))
@ -285,7 +281,7 @@
[`(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 ([g (compile 'variable any?)]) (let ([g (recur 'variable)])
(λ (r s a e h) (λ (r s a e h)
(let-values ([(term _) (g r s a e h)]) (let-values ([(term _) (g r s a e h)])
(values (symbol-append prefix term) e))))] (values (symbol-append prefix term) e))))]
@ -293,26 +289,26 @@
(λ (r s a e h) (λ (r s a e h)
(values ((next-string-decision) lits a) e))] (values ((next-string-decision) lits a) e))]
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
(let ([g (compile pat any?)]) (let ([g (recur pat)])
(λ (r s a e h) (λ (r s a e h)
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
(λ (s a) (g r s a e h)) (λ (s a) (g r s a e h))
(λ (_ env) (condition (bindings env))) (λ (_ env) (condition (bindings env)))
s a r)))] s a r)))]
[`(name ,(? symbol? id) ,p) [`(name ,(? symbol? id) ,p)
(let ([g (compile p any?)]) (let ([g (recur p)])
(λ (r s a e h) (λ (r s a e h)
(let-values ([(term env) (g r s a e h)]) (let-values ([(term env) (g r s a e h)])
(values term (hash-set env (make-binder id) term)))))] (values term (hash-set env (make-binder id) term)))))]
[`hole (λ (r s a e h) (values h e))] [`hole (λ (r s a e h) (values h e))]
[`(in-hole ,context ,contractum) [`(in-hole ,context ,contractum)
(let ([ctx (compile context any?)] (let ([ctx (recur context)]
[ctm (compile contractum any?)]) [ctm (recur contractum)])
(λ (r s a e h) (λ (r s a e h)
(let-values ([(term env) (ctm r s a e h)]) (let-values ([(term env) (ctm r s a e h)])
(ctx r s a env term))))] (ctx r s a env term))))]
[`(hide-hole ,pattern) [`(hide-hole ,pattern)
(let ([g (compile pattern any?)]) (let ([g (recur pattern)])
(λ (r s a e h) (λ (r s a e h)
(g r s a e the-hole)))] (g r s a e the-hole)))]
[`any [`any
@ -325,19 +321,22 @@
(λ (r s a e h) (λ (r s a e h)
(values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))] (values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))]
[(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p))) [(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p)))
(let ([g (compile p any?)]) (let ([g (recur p)])
(λ (r s a e h) (λ (r s a e h)
(generate/prior pat e (λ () (g r s a e h)))))] (generate/prior pat e (λ () (g r s a e h)))))]
[(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p))) [(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p)))
(let ([g (compile p any?)]) (let ([g (recur p)])
(set! mismatches? #t)
(λ (r s a e h) (λ (r s a e h)
(let-values ([(term _) (g r s a e h)]) (let-values ([(term _) (g r s a e h)])
(values term (hash-set e pat term)))))] (values term (hash-set e pat term)))))]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?))
(λ (r s a e h) (values pat e))] (λ (r s a e h) (values pat e))]
[(list-rest (struct ellipsis (name sub-pat class vars)) rest) [(list-rest (struct ellipsis (name sub-pat class vars)) rest)
(let ([elemg (compile sub-pat any?)] (let ([elemg (recur sub-pat)]
[tailg (compile rest any?)]) [tailg (recur rest)])
(when (mismatch? name)
(set! mismatches? #t))
(λ (r s a e h) (λ (r s a e h)
(let*-values ([(len) (let*-values ([(len)
(let ([prior (hash-ref e class #f)]) (let ([prior (hash-ref e class #f)])
@ -349,15 +348,21 @@
(tailg r s a e h))]) (tailg r s a e h))])
(values (append seq tail) env))))] (values (append seq tail) env))))]
[(list-rest hdp tlp) [(list-rest hdp tlp)
(let ([hdg (compile hdp any?)] (let ([hdg (recur hdp)]
[tlg (compile tlp any?)]) [tlg (recur tlp)])
(λ (r s a e h) (λ (r s a e h)
(let*-values (let*-values
([(hd env) (hdg r s a e h)] ([(hd env) (hdg r s a e h)]
[(tl env) (tlg r s a env h)]) [(tl env) (tlg r s a env h)])
(values (cons hd tl) env))))] (values (cons hd tl) env))))]
[else [else
(error what "unknown pattern ~s\n" pat)])))] (error what "unknown pattern ~s\n" pat)]))])
(if mismatches?
(λ (r s a e h)
(let ([g (λ (s a) (generator r s a e h))]
[p? (λ (_ e) (mismatches-satisfied? e))])
(generate/pred (unparse-pattern pat) g p? s a r)))
generator)))]
[(compile-non-terminals) [(compile-non-terminals)
(λ (nts any?) (λ (nts any?)
(make-immutable-hash (make-immutable-hash
@ -377,11 +382,9 @@
(compile-language sexpp sexp-bases #t) (compile-language sexpp sexp-bases #t)
(λ (pat) (compile pat #f)))]) (λ (pat) (compile pat #f)))])
(λ (pat) (λ (pat)
(let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))] (let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))])
[mm-ok? (λ (_ env) (mismatches-satisfied? env))])
(λ (size attempt retries) (λ (size attempt retries)
(let*-values ([(gen) (λ (s a) (g retries s a empty-env the-hole))] (let-values ([(term env) (g retries size attempt empty-env the-hole)])
[(term env) (generate/pred pat gen mm-ok? size attempt retries)])
(values term (bindings env))))))))) (values term (bindings env)))))))))
(define-struct base-cases (cross non-cross)) (define-struct base-cases (cross non-cross))

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

@ -252,7 +252,7 @@
(test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) (test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
'(4 4 4 4 (4 4) (4 4))) '(4 4 4 4 (4 4) (4 4)))
(test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang e 5 #:retries 42)) (test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang e 5 #:retries 42))
#rx"generate-term: unable to generate pattern e in 42") #rx"generate-term: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\) in 42")
(test (raised-exn-msg (test (raised-exn-msg
exn:fail:redex:generation-failure? exn:fail:redex:generation-failure?
(parameterize ([generation-decisions (parameterize ([generation-decisions