Fixed bugs related to `cross' patterns.
svn: r14414
This commit is contained in:
Casey Klein
parent
b79a2ae792
commit
e9cf5787c1
|
|
@ -20,21 +20,28 @@
|
|||
(define-language lc
|
||||
(e x (e e) (λ (x) e))
|
||||
(x variable))
|
||||
(test (to-table (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)))))
|
||||
(let ([bc (find-base-cases lc)])
|
||||
(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 ()
|
||||
(define-language lang
|
||||
(e (e e)))
|
||||
(test (to-table (find-base-cases lang))
|
||||
'((e . (inf)) (e-e . (0 inf inf)))))
|
||||
(let ([bc (find-base-cases lang)])
|
||||
(test (to-table (base-cases-non-cross bc)) '((e . (inf))))
|
||||
(test (to-table (base-cases-cross bc)) '((e-e . (0 inf inf))))))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a 1 2 3)
|
||||
(b a (a_1 b_!_1)))
|
||||
(test (to-table (find-base-cases lang))
|
||||
'((a . (0 0 0)) (a-a . (0)) (a-b . (1)) (b . (1 2)) (b-b . (0)))))
|
||||
(let ([bc (find-base-cases lang)])
|
||||
(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 ()
|
||||
(define-language lc
|
||||
|
|
@ -45,24 +52,28 @@
|
|||
(v (λ (x) e)
|
||||
number)
|
||||
(x variable))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (2 2 1 1)) (e-e . (0 2 2 2 2 2)) (e-v . (1))
|
||||
(v . (2 0)) (v-e . (2 2 2 2 1)) (v-v . (0 2))
|
||||
(x . (0)) (x-e . (2 2 2 2 1 3)) (x-v . (2 2)) (x-x . (0)))))
|
||||
(let ([bc (find-base-cases lc)])
|
||||
(test (to-table (base-cases-non-cross bc))
|
||||
'((e . (2 2 1 1)) (v . (2 0)) (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 ()
|
||||
(define-language L
|
||||
(x (variable-prefix x)
|
||||
(variable-except 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 ()
|
||||
(define-language lang
|
||||
(e number x y)
|
||||
(x variable)
|
||||
(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)))))))
|
||||
|
||||
(define (make-random . nums)
|
||||
|
|
@ -106,16 +117,17 @@
|
|||
(define-language L
|
||||
(a 5 (x a))
|
||||
(b 4))
|
||||
(test (pick-nt 'a L 1 'dontcare)
|
||||
(test (pick-nt 'a #f L 1 'dontcare)
|
||||
(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))))
|
||||
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
|
||||
(test (pick-nt 'a L preferred-production-threshold
|
||||
(make-immutable-hash `((a ,pref)))
|
||||
(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 L preferred-production-threshold #f)
|
||||
(test (pick-nt 'b #f L preferred-production-threshold #f)
|
||||
(nt-rhs (cadr (compiled-lang-lang L)))))
|
||||
|
||||
(define-syntax raised-exn-msg
|
||||
|
|
@ -131,8 +143,8 @@
|
|||
|
||||
(define (patterns . selectors)
|
||||
(map (λ (selector)
|
||||
(λ (name lang size pref-prods)
|
||||
(list (selector (nt-rhs (nt-by-name lang name))))))
|
||||
(λ (name cross? lang size pref-prods)
|
||||
(list (selector (nt-rhs (nt-by-name lang name cross?))))))
|
||||
selectors))
|
||||
|
||||
(define (iterator name items)
|
||||
|
|
@ -449,11 +461,24 @@
|
|||
(e x (e e) v)
|
||||
(v (λ (x) e))
|
||||
(x variable-not-otherwise-mentioned))
|
||||
(define-extended-language name-collision lang (e-e 47))
|
||||
|
||||
(test (generate-term/decisions
|
||||
lang (cross e) 3 0
|
||||
(decisions #:nt (patterns fourth first first second first first first)
|
||||
#: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 ()
|
||||
(define-language L
|
||||
(a ((a ...) ...)))
|
||||
|
|
@ -517,11 +542,15 @@
|
|||
(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
|
||||
(define-language L
|
||||
(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
|
||||
(generate-term/decisions
|
||||
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))))
|
||||
'(+ (+ 7 7) (+ 7 7)))
|
||||
(test
|
||||
|
|
@ -534,10 +563,23 @@
|
|||
(test
|
||||
(generate-term/decisions
|
||||
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))
|
||||
#: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
|
||||
|
|
@ -550,8 +592,13 @@
|
|||
#:pref (list (λ (_) 'dontcare)
|
||||
(λ (_) 'dontcare)
|
||||
(λ (_) 'dontcare)
|
||||
(λ (L) (make-immutable-hash `((e ,(car (pats L))))))
|
||||
(λ (L) (make-immutable-hash `((e ,(cadr (pats L))))))))
|
||||
; 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))))
|
||||
|
|
|
|||
|
|
@ -64,18 +64,27 @@
|
|||
(define (pick-string lang-chars lang-lits attempt [random 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]
|
||||
[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))
|
||||
(hash-ref pref-prods name)]
|
||||
(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)
|
||||
(for/hash ([nt (append (compiled-lang-lang lang)
|
||||
(compiled-lang-cclang lang))])
|
||||
(values (nt-name nt) (list (pick-from-list (nt-rhs nt))))))
|
||||
(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))))
|
||||
|
||||
|
|
@ -163,17 +172,18 @@
|
|||
[min-size (apply min/f sizes)])
|
||||
(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)
|
||||
(let ([lits (map symbol->string (compiled-lang-literals lang))])
|
||||
(make-rg-lang (parse-language lang) lits (unique-chars lits) (find-base-cases lang))))
|
||||
(let ([lits (map symbol->string (compiled-lang-literals lang))]
|
||||
[parsed (parse-language lang)])
|
||||
(make-rg-lang parsed lits (unique-chars lits) (find-base-cases parsed))))
|
||||
|
||||
(define (generate lang decisions@ retries what)
|
||||
(define-values/invoke-unit decisions@
|
||||
(import) (export decisions^))
|
||||
|
||||
(define ((generate-nt lang generate base-table pref-prods)
|
||||
name size attempt in-hole state)
|
||||
(define ((generate-nt lang base-cases generate pref-prods)
|
||||
name cross? size attempt in-hole state)
|
||||
(let*-values
|
||||
([(term _)
|
||||
(generate/pred
|
||||
|
|
@ -181,8 +191,10 @@
|
|||
(λ (size attempt)
|
||||
(let ([rhs (pick-from-list
|
||||
(if (zero? size)
|
||||
(min-prods (nt-by-name lang name) base-table)
|
||||
((next-non-terminal-decision) name lang attempt pref-prods)))])
|
||||
(min-prods (nt-by-name lang name cross?)
|
||||
((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
|
||||
(make-state #hash())
|
||||
in-hole (rhs-pattern rhs))))
|
||||
|
|
@ -283,11 +295,12 @@
|
|||
(generate-pat lang sexp pref-prods size attempt state in-hole pat))
|
||||
|
||||
(define clang (rg-lang-clang lang))
|
||||
(define gen-nt (generate-nt
|
||||
clang
|
||||
(curry generate-pat lang sexp pref-prods)
|
||||
(rg-lang-base-table lang)
|
||||
pref-prods))
|
||||
(define gen-nt
|
||||
(generate-nt
|
||||
clang
|
||||
(rg-lang-base-cases lang)
|
||||
(curry generate-pat lang sexp pref-prods)
|
||||
pref-prods))
|
||||
|
||||
(match pat
|
||||
[`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)])
|
||||
(values term state))]
|
||||
[(? (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))))))
|
||||
(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)))))
|
||||
(generate/prior pat state (λ () (recur/pat b)))]
|
||||
[(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)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
|
||||
(let-values ([(term state) (recur/pat b)])
|
||||
(values term (set-env state pat term)))]
|
||||
[`(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)]
|
||||
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
|
||||
(let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
|
||||
|
|
@ -381,9 +394,11 @@
|
|||
size attempt)])
|
||||
(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 nt-table (make-hasheq))
|
||||
(define nt-table (make-hash))
|
||||
(define changed? #f)
|
||||
(define (nt-get nt) (hash-ref nt-table nt 'inf))
|
||||
(define (nt-set nt new)
|
||||
|
|
@ -392,8 +407,8 @@
|
|||
(set! changed? #t)
|
||||
(hash-set! nt-table nt new))))
|
||||
|
||||
(define (process-nt nt)
|
||||
(nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt)))))
|
||||
(define ((process-nt cross?) nt)
|
||||
(nt-set (cons cross? (nt-name nt)) (apply min/f (map process-rhs (nt-rhs nt)))))
|
||||
|
||||
(define (process-rhs rhs)
|
||||
(let ([nts (rhs->nts (rhs-pattern rhs))])
|
||||
|
|
@ -401,7 +416,7 @@
|
|||
0
|
||||
(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
|
||||
(define (rhs->nts pat)
|
||||
(let ([nts '()])
|
||||
|
|
@ -409,9 +424,9 @@
|
|||
(match pat
|
||||
[(? symbol? 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))
|
||||
(set! nts (cons x-nt nts))]
|
||||
(set! nts (cons (cons #t x-nt) nts))]
|
||||
[`(variable-except ,s ...) (void)]
|
||||
[`(variable-prefix ,p) (void)]
|
||||
[`() (void)]
|
||||
|
|
@ -422,19 +437,25 @@
|
|||
(loop b)]
|
||||
[_ (void)]))
|
||||
nts))
|
||||
|
||||
(let ([nts (append (compiled-lang-lang lang) (compiled-lang-cclang lang))])
|
||||
(let loop ()
|
||||
(set! changed? #f)
|
||||
(for-each process-nt nts)
|
||||
(when changed?
|
||||
(loop)))
|
||||
|
||||
(let ([ht (make-hash)])
|
||||
|
||||
;; build-table : (listof nt) -> hash
|
||||
(define (build-table nts)
|
||||
(let ([tbl (make-hasheq)])
|
||||
(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)
|
||||
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
|
||||
(case-lambda
|
||||
|
|
@ -464,11 +485,12 @@
|
|||
(define (built-in? x)
|
||||
(and (memq x underscore-allowed) #t))
|
||||
|
||||
;; nt-by-name : lang symbol -> nt
|
||||
(define (nt-by-name lang name)
|
||||
;; nt-by-name : lang symbol boolean -> nt
|
||||
(define (nt-by-name lang name cross?)
|
||||
(findf (λ (nt) (eq? name (nt-name nt)))
|
||||
(append (compiled-lang-lang lang)
|
||||
(compiled-lang-cclang lang))))
|
||||
(if cross?
|
||||
(compiled-lang-cclang lang)
|
||||
(compiled-lang-lang lang))))
|
||||
|
||||
(define named-nt-rx #rx"^([^_]+)_[^_]*$")
|
||||
(define mismatch-nt-rx #rx"([^_]+)_!_[^_]*$")
|
||||
|
|
@ -896,18 +918,30 @@
|
|||
|
||||
(define generation-decisions (make-parameter random-decisions@))
|
||||
|
||||
(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length
|
||||
is-nt? pick-char random-string pick-string redex-check nt-by-name
|
||||
pick-nt unique-chars pick-any sexp generate-term parse-pattern
|
||||
class-reassignments reassign-classes unparse-pattern
|
||||
(struct-out ellipsis) (struct-out mismatch) (struct-out class)
|
||||
(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 redex-check
|
||||
generate-term
|
||||
check-metafunction-contract
|
||||
check-reduction-relation
|
||||
check-metafunction)
|
||||
|
||||
(provide/contract
|
||||
[find-base-cases (-> compiled-lang? hash?)])
|
||||
(provide (struct-out ellipsis)
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user