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

Fixed bugs related to `cross' patterns.

Browse Source 
svn: r14414
This commit is contained in:
Casey Klein 2009-04-03 10:47:42 +00:00
parent b79a2ae792
commit e9cf5787c1
2 changed files with 164 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
collects/redex/private/rg-test.ss
View File

@ -20,21 +20,28 @@
(define-language lc (define-language lc
(e x (e e) (λ (x) e)) (e x (e e) (λ (x) e))
(x variable)) (x variable))
(test (to-table (find-base-cases lc)) (let ([bc (find-base-cases lc)])
'((e . (1 2 2)) (e-e . (0 2 2 1)) (x . (0)) (x-e . (1 2 2 2 2)) (x-x . (0))))) (test (to-table (base-cases-non-cross bc))
'((e . (1 2 2)) (x . (0))))
(test (to-table (base-cases-cross bc))
'((e-e . (0 2 2 1)) (x-e . (1 2 2 2 2)) (x-x . (0))))))
(let () (let ()
(define-language lang (define-language lang
(e (e e))) (e (e e)))
(test (to-table (find-base-cases lang)) (let ([bc (find-base-cases lang)])
'((e . (inf)) (e-e . (0 inf inf))))) (test (to-table (base-cases-non-cross bc)) '((e . (inf))))
(test (to-table (base-cases-cross bc)) '((e-e . (0 inf inf))))))
(let () (let ()
(define-language lang (define-language lang
(a 1 2 3) (a 1 2 3)
(b a (a_1 b_!_1))) (b a (a_1 b_!_1)))
(test (to-table (find-base-cases lang)) (let ([bc (find-base-cases lang)])
'((a . (0 0 0)) (a-a . (0)) (a-b . (1)) (b . (1 2)) (b-b . (0))))) (test (to-table (base-cases-non-cross bc))
'((a . (0 0 0)) (b . (1 2))))
(test (to-table (base-cases-cross bc))
'((a-a . (0)) (a-b . (1)) (b-b . (0))))))
(let () (let ()
(define-language lc (define-language lc
@ -45,24 +52,28 @@
(v (λ (x) e) (v (λ (x) e)
number) number)
(x variable)) (x variable))
(test (to-table (find-base-cases lc)) (let ([bc (find-base-cases lc)])
'((e . (2 2 1 1)) (e-e . (0 2 2 2 2 2)) (e-v . (1)) (test (to-table (base-cases-non-cross bc))
(v . (2 0)) (v-e . (2 2 2 2 1)) (v-v . (0 2)) '((e . (2 2 1 1)) (v . (2 0)) (x . (0))))
(x . (0)) (x-e . (2 2 2 2 1 3)) (x-v . (2 2)) (x-x . (0))))) (test (to-table (base-cases-cross bc))
'((e-e . (0 2 2 2 2 2)) (e-v . (1)) (v-e . (2 2 2 2 1)) (v-v . (0 2))
(x-e . (2 2 2 2 1 3)) (x-v . (2 2)) (x-x . (0))))))
(let () (let ()
(define-language L (define-language L
(x (variable-prefix x) (x (variable-prefix x)
(variable-except y)) (variable-except y))
(y y)) (y y))
(test (hash-ref (find-base-cases L) 'x) '(0 0))) (test (hash-ref (base-cases-non-cross (find-base-cases L)) 'x)
'(0 0)))
(let () (let ()
(define-language lang (define-language lang
(e number x y) (e number x y)
(x variable) (x variable)
(y y)) (y y))
(test (min-prods (car (compiled-lang-lang lang)) (find-base-cases lang)) (test (min-prods (car (compiled-lang-lang lang))
(base-cases-non-cross (find-base-cases lang)))
(list (car (nt-rhs (car (compiled-lang-lang lang))))))) (list (car (nt-rhs (car (compiled-lang-lang lang)))))))
(define (make-random . nums) (define (make-random . nums)
@ -106,16 +117,17 @@
(define-language L (define-language L
(a 5 (x a)) (a 5 (x a))
(b 4)) (b 4))
(test (pick-nt 'a L 1 'dontcare) (test (pick-nt 'a #f L 1 'dontcare)
(nt-rhs (car (compiled-lang-lang L)))) (nt-rhs (car (compiled-lang-lang L))))
(test (pick-nt 'a L preferred-production-threshold 'dontcare (make-random 1)) (test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1))
(nt-rhs (car (compiled-lang-lang L)))) (nt-rhs (car (compiled-lang-lang L))))
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))]) (let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
(test (pick-nt 'a L preferred-production-threshold (test (pick-nt 'a #f L preferred-production-threshold
(make-immutable-hash `((a ,pref))) (make-pref-prods 'dont-care
(make-immutable-hash `((a ,pref))))
(make-random 0)) (make-random 0))
(list pref))) (list pref)))
(test (pick-nt 'b L preferred-production-threshold #f) (test (pick-nt 'b #f L preferred-production-threshold #f)
(nt-rhs (cadr (compiled-lang-lang L))))) (nt-rhs (cadr (compiled-lang-lang L)))))
(define-syntax raised-exn-msg (define-syntax raised-exn-msg
@ -131,8 +143,8 @@
(define (patterns . selectors) (define (patterns . selectors)
(map (λ (selector) (map (λ (selector)
(λ (name lang size pref-prods) (λ (name cross? lang size pref-prods)
(list (selector (nt-rhs (nt-by-name lang name)))))) (list (selector (nt-rhs (nt-by-name lang name cross?))))))
selectors)) selectors))
(define (iterator name items) (define (iterator name items)
@ -449,11 +461,24 @@
(e x (e e) v) (e x (e e) v)
(v (λ (x) e)) (v (λ (x) e))
(x variable-not-otherwise-mentioned)) (x variable-not-otherwise-mentioned))
(define-extended-language name-collision lang (e-e 47))
(test (generate-term/decisions (test (generate-term/decisions
lang (cross e) 3 0 lang (cross e) 3 0
(decisions #:nt (patterns fourth first first second first first first) (decisions #:nt (patterns fourth first first second first first first)
#:var (list (λ _ 'x) (λ _ 'y)))) #:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y))))) (term (λ (x) (hole y))))
(test (generate-term/decisions name-collision (cross e) 3 0
(decisions #:nt (patterns first)))
(term hole))
(test (generate-term/decisions name-collision e-e 3 0
(decisions #:nt (patterns first)))
47)
(test (hash-ref (base-cases-non-cross (find-base-cases name-collision)) 'e-e)
'(0)))
(let () (let ()
(define-language L (define-language L
(a ((a ...) ...))) (a ((a ...) ...)))
@ -517,11 +542,15 @@
(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))]) (let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
(define-language L (define-language L
(e (+ e e) (* e e) 7)) (e (+ e e) (* e e) 7))
(let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang (parse-language L)))))]) (define-language M (e 0) (e-e 1))
(let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))])
(test (test
(generate-term/decisions (generate-term/decisions
L e 2 preferred-production-threshold L e 2 preferred-production-threshold
(decisions #:pref (list (λ (L) (make-immutable-hash `((e ,(car (pats L))))))) (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)))) #:nt (make-pick-nt (make-random 0 0 0))))
'(+ (+ 7 7) (+ 7 7))) '(+ (+ 7 7) (+ 7 7)))
(test (test
@ -534,10 +563,23 @@
(test (test
(generate-term/decisions (generate-term/decisions
L any 2 preferred-production-threshold L any 2 preferred-production-threshold
(decisions #:pref (list (λ (L) (make-immutable-hash `((e ,(car (pats L))))))) (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)) #:nt (make-pick-nt (make-random 0 0 0))
#:any (list (λ (lang sexp) (values lang 'e))))) #:any (list (λ (lang sexp) (values lang 'e)))))
'(+ (+ 7 7) (+ 7 7))) '(+ (+ 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 (test
(let ([generated null]) (let ([generated null])
(output (output
@ -550,8 +592,13 @@
#:pref (list (λ (_) 'dontcare) #:pref (list (λ (_) 'dontcare)
(λ (_) 'dontcare) (λ (_) 'dontcare)
(λ (_) 'dontcare) (λ (_) 'dontcare)
(λ (L) (make-immutable-hash `((e ,(car (pats L)))))) ; size 0 terms prior to this attempt
(λ (L) (make-immutable-hash `((e ,(cadr (pats L)))))))) (λ (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))) #:attempts 5)))
generated) generated)
'((* 7 7) (+ 7 7) 7 7 7)))) '((* 7 7) (+ 7 7) 7 7 7))))

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

@ -64,18 +64,27 @@
(define (pick-string lang-chars lang-lits attempt [random random]) (define (pick-string lang-chars lang-lits attempt [random random])
(random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
(define (pick-nt name lang attempt pref-prods (define (pick-nt name cross? lang attempt pref-prods
[random random] [random random]
[pref-prod? preferred-production?]) [pref-prod? preferred-production?])
(let ([prods (nt-rhs (nt-by-name lang name))]) (let ([prods (nt-rhs (nt-by-name lang name cross?))])
(cond [(and pref-prods (pref-prod? attempt random)) (cond [(and pref-prods (pref-prod? attempt random))
(hash-ref pref-prods name)] (hash-ref
((if cross? pref-prods-cross pref-prods-non-cross)
pref-prods)
name)]
[else prods]))) [else prods])))
(define-struct pref-prods (cross non-cross))
(define (pick-preferred-productions lang) (define (pick-preferred-productions lang)
(for/hash ([nt (append (compiled-lang-lang lang) (let ([pick (λ (sel)
(compiled-lang-cclang lang))]) (for/hash ([nt (sel lang)])
(values (nt-name nt) (list (pick-from-list (nt-rhs nt)))))) (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))))
@ -163,17 +172,18 @@
[min-size (apply min/f sizes)]) [min-size (apply min/f sizes)])
(map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) (map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
(define-struct rg-lang (clang lits chars base-table)) (define-struct rg-lang (clang lits chars base-cases))
(define (prepare-lang lang) (define (prepare-lang lang)
(let ([lits (map symbol->string (compiled-lang-literals lang))]) (let ([lits (map symbol->string (compiled-lang-literals lang))]
(make-rg-lang (parse-language lang) lits (unique-chars lits) (find-base-cases lang)))) [parsed (parse-language lang)])
(make-rg-lang parsed lits (unique-chars lits) (find-base-cases parsed))))
(define (generate lang decisions@ 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 generate base-table pref-prods) (define ((generate-nt lang base-cases generate pref-prods)
name size attempt in-hole state) name cross? size attempt in-hole state)
(let*-values (let*-values
([(term _) ([(term _)
(generate/pred (generate/pred
@ -181,8 +191,10 @@
(λ (size attempt) (λ (size attempt)
(let ([rhs (pick-from-list (let ([rhs (pick-from-list
(if (zero? size) (if (zero? size)
(min-prods (nt-by-name lang name) base-table) (min-prods (nt-by-name lang name cross?)
((next-non-terminal-decision) name lang attempt pref-prods)))]) ((if cross? base-cases-cross base-cases-non-cross)
base-cases))
((next-non-terminal-decision) name cross? lang attempt pref-prods)))])
(generate (max 0 (sub1 size)) attempt (generate (max 0 (sub1 size)) attempt
(make-state #hash()) (make-state #hash())
in-hole (rhs-pattern rhs)))) in-hole (rhs-pattern rhs))))
@ -283,11 +295,12 @@
(generate-pat lang sexp pref-prods size attempt state in-hole pat)) (generate-pat lang sexp pref-prods size attempt state in-hole pat))
(define clang (rg-lang-clang lang)) (define clang (rg-lang-clang lang))
(define gen-nt (generate-nt (define gen-nt
clang (generate-nt
(curry generate-pat lang sexp pref-prods) clang
(rg-lang-base-table lang) (rg-lang-base-cases lang)
pref-prods)) (curry generate-pat lang sexp pref-prods)
pref-prods))
(match pat (match pat
[`number (values ((next-number-decision) attempt) state)] [`number (values ((next-number-decision) attempt) state)]
@ -336,19 +349,19 @@
[(term _) (generate-pat new-lang sexp pref-prods size attempt new-state the-hole nt)]) [(term _) (generate-pat new-lang sexp pref-prods size attempt new-state the-hole nt)])
(values term state))] (values term state))]
[(? (is-nt? clang)) [(? (is-nt? clang))
(values (gen-nt pat size attempt in-hole state) state)] (values (gen-nt pat #f size attempt in-hole state) state)]
[(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))) [(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))))
(generate/prior pat state (λ () (values (gen-nt nt size attempt in-hole state) state)))] (generate/prior pat state (λ () (values (gen-nt nt #f size attempt in-hole state) state)))]
[(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b))))) [(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat state (λ () (recur/pat b)))] (generate/prior pat state (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt))))) [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt)))))
(let ([term (gen-nt nt size attempt in-hole state)]) (let ([term (gen-nt nt #f size attempt in-hole state)])
(values term (set-env state pat term)))] (values term (set-env state pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b))))) [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
(let-values ([(term state) (recur/pat b)]) (let-values ([(term state) (recur/pat b)])
(values term (set-env state pat term)))] (values term (set-env state pat term)))]
[`(cross ,(? symbol? cross-nt)) [`(cross ,(? symbol? cross-nt))
(values (gen-nt cross-nt size attempt in-hole state) state)] (values (gen-nt cross-nt #t size attempt in-hole state) state)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)]) (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
@ -381,9 +394,11 @@
size attempt)]) size attempt)])
(values term (bindings (state-env state))))))))) (values term (bindings (state-env state)))))))))
;; find-base-cases : compiled-language -> hash-table (define-struct base-cases (cross non-cross))
;; find-base-cases : (list/c nt) -> base-cases
(define (find-base-cases lang) (define (find-base-cases lang)
(define nt-table (make-hasheq)) (define nt-table (make-hash))
(define changed? #f) (define changed? #f)
(define (nt-get nt) (hash-ref nt-table nt 'inf)) (define (nt-get nt) (hash-ref nt-table nt 'inf))
(define (nt-set nt new) (define (nt-set nt new)
@ -392,8 +407,8 @@
(set! changed? #t) (set! changed? #t)
(hash-set! nt-table nt new)))) (hash-set! nt-table nt new))))
(define (process-nt nt) (define ((process-nt cross?) nt)
(nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt))))) (nt-set (cons cross? (nt-name nt)) (apply min/f (map process-rhs (nt-rhs nt)))))
(define (process-rhs rhs) (define (process-rhs rhs)
(let ([nts (rhs->nts (rhs-pattern rhs))]) (let ([nts (rhs->nts (rhs-pattern rhs))])
@ -401,7 +416,7 @@
0 0
(add1/f (apply max/f (map nt-get nts)))))) (add1/f (apply max/f (map nt-get nts))))))
;; rhs->path : pattern -> (listof symbol) ;; rhs->path : pattern -> (listof (cons/c boolean symbol))
;; determines all of the non-terminals in a pattern ;; determines all of the non-terminals in a pattern
(define (rhs->nts pat) (define (rhs->nts pat)
(let ([nts '()]) (let ([nts '()])
@ -409,9 +424,9 @@
(match pat (match pat
[(? symbol? pat) [(? symbol? pat)
(when ((is-nt? lang) (symbol->nt pat)) (when ((is-nt? lang) (symbol->nt pat))
(set! nts (cons (symbol->nt pat) nts)))] (set! nts (cons (cons #f (symbol->nt pat)) nts)))]
[`(cross ,(? symbol? x-nt)) [`(cross ,(? symbol? x-nt))
(set! nts (cons x-nt nts))] (set! nts (cons (cons #t x-nt) nts))]
[`(variable-except ,s ...) (void)] [`(variable-except ,s ...) (void)]
[`(variable-prefix ,p) (void)] [`(variable-prefix ,p) (void)]
[`() (void)] [`() (void)]
@ -422,19 +437,25 @@
(loop b)] (loop b)]
[_ (void)])) [_ (void)]))
nts)) nts))
(let ([nts (append (compiled-lang-lang lang) (compiled-lang-cclang lang))]) ;; build-table : (listof nt) -> hash
(let loop () (define (build-table nts)
(set! changed? #f) (let ([tbl (make-hasheq)])
(for-each process-nt nts)
(when changed?
(loop)))
(let ([ht (make-hash)])
(for-each (for-each
(λ (nt) (hash-set! ht (nt-name nt) (map process-rhs (nt-rhs nt)))) (λ (nt) (hash-set! tbl (nt-name nt) (map process-rhs (nt-rhs nt))))
nts) nts)
ht))) tbl))
(let loop ()
(set! changed? #f)
(for-each (process-nt #f) (compiled-lang-lang lang))
(for-each (process-nt #t) (compiled-lang-cclang lang))
(when changed?
(loop)))
(make-base-cases
(build-table (compiled-lang-cclang lang))
(build-table (compiled-lang-lang lang))))
(define min/f (define min/f
(case-lambda (case-lambda
@ -464,11 +485,12 @@
(define (built-in? x) (define (built-in? x)
(and (memq x underscore-allowed) #t)) (and (memq x underscore-allowed) #t))
;; nt-by-name : lang symbol -> nt ;; nt-by-name : lang symbol boolean -> nt
(define (nt-by-name lang name) (define (nt-by-name lang name cross?)
(findf (λ (nt) (eq? name (nt-name nt))) (findf (λ (nt) (eq? name (nt-name nt)))
(append (compiled-lang-lang lang) (if cross?
(compiled-lang-cclang lang)))) (compiled-lang-cclang lang)
(compiled-lang-lang lang))))
(define named-nt-rx #rx"^([^_]+)_[^_]*$") (define named-nt-rx #rx"^([^_]+)_[^_]*$")
(define mismatch-nt-rx #rx"([^_]+)_!_[^_]*$") (define mismatch-nt-rx #rx"([^_]+)_!_[^_]*$")
@ -896,18 +918,30 @@
(define generation-decisions (make-parameter random-decisions@)) (define generation-decisions (make-parameter random-decisions@))
(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length (provide redex-check
is-nt? pick-char random-string pick-string redex-check nt-by-name generate-term
pick-nt unique-chars pick-any sexp generate-term parse-pattern check-metafunction-contract
class-reassignments reassign-classes unparse-pattern check-reduction-relation
(struct-out ellipsis) (struct-out mismatch) (struct-out class) check-metafunction)
(struct-out binder) check-metafunction-contract prepare-lang
pick-number pick-natural pick-integer pick-real
parse-language check-reduction-relation
preferred-production-threshold check-metafunction
generation-decisions pick-preferred-productions
default-retries proportion-at-size retry-threshold
proportion-before-threshold post-threshold-incr)
(provide/contract (provide (struct-out ellipsis)
[find-base-cases (-> compiled-lang? hash?)]) (struct-out mismatch)
(struct-out class)
(struct-out binder)
(struct-out base-cases)
(struct-out pref-prods))
(provide pick-from-list pick-sequence-length
pick-char pick-var pick-string
pick-nt pick-any pick-preferred-productions
pick-number pick-natural pick-integer pick-real
parse-pattern unparse-pattern
parse-language prepare-lang
class-reassignments reassign-classes
default-retries proportion-at-size
preferred-production-threshold retry-threshold
proportion-before-threshold post-threshold-incr
is-nt? nt-by-name min-prods
generation-decisions decisions^
random-string unique-chars
sexp find-base-cases)