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

Fixed bug in generating `in-hole' patterns.

Browse Source 
svn: r11464
This commit is contained in:
Casey Klein 2008-08-28 15:25:35 +00:00
parent 6fb9a4243f
commit 538b6e5e90
2 changed files with 65 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -281,7 +281,6 @@
'number) 'number)
#:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) #:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
'(2 3 4 2 3)) '(2 3 4 2 3))
;;FIXME
#;(test #;(test
(generate (generate
lang (variable_1 ...) 5 0 lang (variable_1 ...) 5 0
@ -309,8 +308,7 @@
(test (test
(generate (generate
lang e 5 0 lang e 5 0
(decisions #:nt (patterns '(number_!_1 number_!_2 number_!_1 number_!_2)) (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2) (λ _ 3))))
#:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2) (λ _ 3))))
'(1 1 2 3))) '(1 1 2 3)))
(let () (let ()
@ -392,25 +390,27 @@
(define-language lang (define-language lang
(a number (+ a a)) (a number (+ a a))
(A hole (+ a A) (+ A a)) (A hole (+ a A) (+ A a))
(B (6 (hole h)))
(C hole) (C hole)
(d (x (in-hole C y)) #:binds x y) (d (x (in-hole C y)) #:binds x y)
(e ((in-hole (in-hole f (number_1 hole)) number_1) number_1)) (e ((in-hole (in-hole f (number_1 hole)) number_1) number_1))
(f (in-hole C (number_1 hole))) (f (in-hole C (number_1 hole)))
(g (in-hole (side-condition (hole number_1) (zero? (term number_1))) number_2)) (g (in-hole (side-condition (hole number_1) (zero? (term number_1))) number_2))
(h ((in-hole i number_1) number_1))
(i (number_1 (in-hole j (number_1 hole))))
(j (in-hole (hole number_1) (number_1 hole)))
(x variable) (x variable)
(y variable)) (y variable))
(test (test
(generate (generate
lang (in-hole A number ) 5 0 lang (in-hole A number ) 5 0
(decisions (decisions
#:nt (patterns '(+ a A) '(+ a a) 'number 'number '(+ A a) 'hole '(+ a a) 'number 'number) #:nt (patterns '(+ a A) '(+ a a) 'number 'number '(+ A a) 'hole '(+ a a) 'number 'number)
#:num (build-list 5 (λ (x) (λ (_) x))))) #:num (build-list 5 (λ (x) (λ (_) x)))))
'(+ (+ 0 1) (+ 2 (+ 3 4)))) '(+ (+ 1 2) (+ 0 (+ 3 4))))
(test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5 0) '(1 5)) (test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5 0) '(1 5))
(test (generate lang hole 5 0) (term hole)) (test (generate lang (hole 4) 5 0) (term (hole 4)))
(test (generate lang (hole h) 5 0) (term (hole h)))
(test (generate lang (variable_1 (in-hole C variable_1)) 5 0 (test (generate lang (variable_1 (in-hole C variable_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
'(x x)) '(x x))
@ -420,9 +420,11 @@
(test (let/ec k (generate lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) (test (let/ec k (generate lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x)) '(x))
(test (generate lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) (test (generate lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
'((1 (2 2)) 2)) '((2 (1 1)) 1))
(test (generate lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) (test (generate lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
'(1 0))) '(1 0))
(test (generate lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
'((2 ((3 (2 1)) 3)) 1)))
(let () (let ()
(define-language lc (define-language lc

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

@ -130,11 +130,6 @@ To do a better job of not generating programs with free variables,
(error 'generate "unable to generate pattern ~s in ~s attempts" (error 'generate "unable to generate pattern ~s in ~s attempts"
pat generation-retries)) pat generation-retries))
(define ((disjunction . preds) x)
(if (null? preds)
#f
(or ((car preds) x) ((apply disjunction (cdr preds)) x))))
;; used in generating the `any' pattern ;; used in generating the `any' pattern
(define-language sexp (sexp variable string number hole (sexp ...))) (define-language sexp (sexp variable string number hole (sexp ...)))
@ -146,7 +141,7 @@ To do a better job of not generating programs with free variables,
(define lang-chars (unique-chars lang-lits)) (define lang-chars (unique-chars lang-lits))
(define base-table (find-base-cases lang)) (define base-table (find-base-cases lang))
(define (generate-nt nt fvt-id bound-vars size in-hole initial-state) (define (generate-nt nt fvt-id bound-vars size in-hole env)
(let loop ([nts (compiled-lang-lang lang)]) (let loop ([nts (compiled-lang-lang lang)])
(cond (cond
[(null? nts) (error 'generate-nt "didn't find non-terminal ~s" nt)] [(null? nts) (error 'generate-nt "didn't find non-terminal ~s" nt)]
@ -156,116 +151,99 @@ To do a better job of not generating programs with free variables,
((next-non-terminal-decision) ((next-non-terminal-decision)
(if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts))) (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))
bound-vars size)] bound-vars size)]
[(term post-nt-state) [(term _)
(((generate-pat (((generate-pat
(append (extract-bound-vars fvt-id initial-state) bound-vars) (append (extract-bound-vars fvt-id env) bound-vars)
(max 0 (sub1 size))) (max 0 (sub1 size)))
(rhs-pattern rhs) in-hole) (rhs-pattern rhs) in-hole)
(make-gen-state (make-environment (map fvt-entry (rhs-var-info rhs)) #hasheq() #hasheq()))])
(make-state (map fvt-entry (rhs-var-info rhs)) #hasheq() #hasheq()) (values term (extend-found-vars fvt-id term env)))]
(if in-hole initial-state #f)))]
[(new-state) (if in-hole (gen-state-hole post-nt-state) initial-state)])
(values term (extend-found-vars fvt-id term new-state)))]
[else (loop (cdr nts))]))) [else (loop (cdr nts))])))
(define-struct gen-state (current hole)) (define-struct environment (fvt matches mismatches))
(define-struct state (fvt matches mismatches))
(define (set-current-matches state id term)
(make-gen-state
(make-state
(state-fvt (gen-state-current state))
(hash-set (state-matches (gen-state-current state)) id term)
(state-mismatches (gen-state-current state)))
(gen-state-hole state)))
(define (set-current-mismatches state id term)
(make-gen-state
(make-state
(state-fvt (gen-state-current state))
(state-matches (gen-state-current state))
(hash-set (state-mismatches (gen-state-current state)) id term))
(gen-state-hole state)))
(define-struct found-vars (nt source bound-vars found-nt?)) (define-struct found-vars (nt source bound-vars found-nt?))
(define (fvt-entry binds) (define (fvt-entry binds)
(make-found-vars (binds-binds binds) (binds-source binds) '() #f)) (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
(define (((generate-pat bound-vars size) pat in-hole [fvt-id pat]) state) (define (((generate-pat bound-vars size) pat in-hole [fvt-id pat]) env)
(define recur (generate-pat bound-vars size)) (define recur (generate-pat bound-vars size))
(define (recur/pat pat) ((recur pat in-hole) state)) (define (recur/pat pat) ((recur pat in-hole) env))
(define (generate/pred pred pat [gen (λ () (recur/pat pat))]) (define (generate/pred pred pat [gen (λ () (recur/pat pat))])
(let retry ([remaining generation-retries]) (let retry ([remaining generation-retries])
(if (zero? remaining) (if (zero? remaining)
(generation-failure pat) (generation-failure pat)
(let-values ([(term state) (gen)]) (let-values ([(term env) (gen)])
(if (pred term (state-matches (gen-state-current state))) (if (pred term (environment-matches env))
(values term state) (values term env)
(retry (sub1 remaining))))))) (retry (sub1 remaining)))))))
(match pat (match pat
[`number (values ((next-number-decision) random-numbers) state)] [`number (values ((next-number-decision) random-numbers) env)]
[`(variable-except ,vars ...) [`(variable-except ,vars ...)
(generate/pred (λ (var _) (not (memq var vars))) 'variable)] (generate/pred (λ (var _) (not (memq var vars))) 'variable)]
[`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)] [`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) env)]
[`variable-not-otherwise-mentioned [`variable-not-otherwise-mentioned
(generate/pred (λ (var _) (not (memq var (compiled-lang-literals lang)))) 'variable)] (generate/pred (λ (var _) (not (memq var (compiled-lang-literals lang)))) 'variable)]
[`(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 state) (recur/pat 'variable)]) (let-values ([(term env) (recur/pat 'variable)])
(values (symbol-append prefix term) state))] (values (symbol-append prefix term) env))]
[`string (values ((next-string-decision) lang-chars lang-lits attempt) state)] [`string (values ((next-string-decision) lang-chars lang-lits attempt) env)]
[`(side-condition ,pat ,(? procedure? condition)) [`(side-condition ,pat ,(? procedure? condition))
;; `matches' includes bindings beyond those bound in `pat', ;; `matches' includes bindings beyond those bound in `pat',
;; but compiled side-conditions ignore these. ;; but compiled side-conditions ignore these.
(generate/pred (λ (_ matches) (condition (make-bindings (hash-map matches make-bind)))) pat)] (generate/pred (λ (_ matches) (condition (make-bindings (hash-map matches make-bind)))) pat)]
[`(name ,(? symbol? id) ,p) [`(name ,(? symbol? id) ,p)
(let-values ([(term state) (recur/pat p)]) (let-values ([(term env) (recur/pat p)])
(values term (set-current-matches state id term)))] (values term (make-environment (environment-fvt env)
[`hole (hash-set (environment-matches env) id term)
(cond [(not in-hole) (values the-hole state)] (environment-mismatches env))))]
[(gen-state-hole state) [`hole (values in-hole env)]
(let-values ([(term hole-state) (in-hole (gen-state-hole state))])
(values term (make-gen-state (gen-state-current state) hole-state)))]
[else (in-hole state)])]
[`(in-hole ,context ,contractum) [`(in-hole ,context ,contractum)
((recur context (recur contractum in-hole)) state)] (let-values ([(term env) (recur/pat contractum)])
[`(hide-hole ,pattern) ((recur pattern #f) state)] ((recur context term) env))]
[`(hide-hole ,pattern) ((recur pattern the-hole) env)]
[`any [`any
(let-values ([(lang nt) ((next-any-decision) lang)]) (let-values ([(lang nt) ((next-any-decision) lang)])
(values (generate* lang nt size attempt decisions@) state))] (values (generate* lang nt size attempt decisions@) env))]
[(? (λ (p) (is-nt? lang p))) [(? (λ (p) (is-nt? lang p)))
(generate-nt pat fvt-id bound-vars size in-hole state)] (generate-nt pat fvt-id bound-vars size in-hole env)]
[(and (? symbol?) (app symbol->string (regexp named-nt-rx (list _ nt)))) [(and (? symbol?) (app symbol->string (regexp named-nt-rx (list _ nt))))
(let* ([undecorated (string->symbol nt)] (let* ([undecorated (string->symbol nt)]
[none (gensym)] [none (gensym)]
[prior (hash-ref (state-matches (gen-state-current state)) pat none)]) [prior (hash-ref (environment-matches env) pat none)])
(if (eq? prior none) (if (eq? prior none)
(let-values (let-values
([(term state) ((recur undecorated in-hole pat) state)]) ([(term env) ((recur undecorated in-hole pat) env)])
(values term (set-current-matches state pat term))) (values term (make-environment (environment-fvt env)
(values prior state)))] (hash-set (environment-matches env) pat term)
(environment-mismatches env))))
(values prior env)))]
[(and (? symbol?) (app symbol->string (regexp mismatch-nt-rx (list _ nt)))) [(and (? symbol?) (app symbol->string (regexp mismatch-nt-rx (list _ nt))))
(let*-values (let*-values
([(undecorated) (string->symbol nt)] ([(undecorated) (string->symbol nt)]
[(prior) (hash-ref (state-mismatches (gen-state-current state)) pat null)] [(prior) (hash-ref (environment-mismatches env) pat null)]
[(generate-mismatch) [(generate-mismatch)
(λ () ((recur undecorated in-hole pat) state))] (λ () ((recur undecorated in-hole pat) env))]
[(term state) [(term env)
(generate/pred (λ (t _) (not (member t prior))) undecorated generate-mismatch)]) (generate/pred (λ (t _) (not (member t prior))) undecorated generate-mismatch)])
(values term (set-current-mismatches state pat (cons term prior))))] (values term (make-environment (environment-fvt env)
[(? (disjunction symbol? number? string? boolean? null?)) (values pat state)] (environment-matches env)
(hash-set (environment-mismatches env) pat (cons term prior)))))]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
[(list-rest pat '... rest) [(list-rest pat '... rest)
(recur/pat (append (build-list ((next-sequence-decision)) (λ (_) pat)) rest))] (recur/pat (append (build-list ((next-sequence-decision)) (λ (_) pat)) rest))]
[(list-rest pat rest) [(list-rest pat rest)
(let*-values (let*-values
([(pat-term state) (recur/pat pat)] ([(pat-term env) (recur/pat pat)]
[(rest-term state) [(rest-term env) ((recur rest in-hole) env)])
((recur rest in-hole) state)]) (values (cons pat-term rest-term) env))]
(values (cons pat-term rest-term) state))]
[else [else
(error 'generate "unknown pattern ~s\n" pat)])) (error 'generate "unknown pattern ~s\n" pat)]))
(define (extract-bound-vars pat state) (define (extract-bound-vars pat env)
(let loop ([found-vars-table (state-fvt (gen-state-current state))]) (let loop ([found-vars-table (environment-fvt env)])
(cond (cond
[(null? found-vars-table) '()] [(null? found-vars-table) '()]
[else (let ([found-vars (car found-vars-table)]) [else (let ([found-vars (car found-vars-table)])
@ -273,9 +251,8 @@ To do a better job of not generating programs with free variables,
(found-vars-bound-vars found-vars) (found-vars-bound-vars found-vars)
(loop (cdr found-vars-table))))]))) (loop (cdr found-vars-table))))])))
(define (extend-found-vars pat res state) (define (extend-found-vars pat res env)
(make-gen-state (make-environment
(make-state
(map (map
(λ (found-vars) (λ (found-vars)
(cond (cond
@ -296,13 +273,12 @@ To do a better job of not generating programs with free variables,
(found-vars-bound-vars found-vars) (found-vars-bound-vars found-vars)
#t)] #t)]
[else found-vars])) [else found-vars]))
(state-fvt (gen-state-current state))) (environment-fvt env))
(state-matches (gen-state-current state)) (environment-matches env)
(state-mismatches (gen-state-current state))) (environment-mismatches env)))
(gen-state-hole state)))
(let ([initial-state (make-gen-state (make-state null #hasheq() #hasheq()) #f)]) (let ([initial-state (make-environment null #hasheq() #hasheq())])
(let-values ([(term _) (((generate-pat null size) pat #f) initial-state)]) (let-values ([(term _) (((generate-pat null size) pat the-hole) initial-state)])
term))) term)))
;; find-base-cases : compiled-language -> hash-table ;; find-base-cases : compiled-language -> hash-table