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

Simplified generator, due to removal of named holes.

Browse Source 
svn: r11096
This commit is contained in:
Casey Klein 2008-08-05 23:38:30 +00:00
parent ac509e8b2d
commit 40056b3d62
2 changed files with 19 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -410,7 +410,8 @@
#: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)))) '(+ (+ 0 1) (+ 2 (+ 3 4))))
(test (generate lang (in-hole (in-hole ((in-hole hole 4) hole) 3) 5) 5 0) '(4 3))
(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 5 0) (term hole))
(test (generate lang (hole h) 5 0) (term (hole h))) (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

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

@ -141,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 bound-vars size holes) (define (generate-nt nt bound-vars size in-hole)
(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)]
@ -149,17 +149,17 @@ To do a better job of not generating programs with free variables,
(let* ([prods (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))] (let* ([prods (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))]
[rhs ((next-non-terminal-decision) prods bound-vars size)] [rhs ((next-non-terminal-decision) prods bound-vars size)]
[size (max 0 (sub1 size))]) [size (max 0 (sub1 size))])
(generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) size holes))] (generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) size in-hole))]
[else (loop (cdr nts))]))) [else (loop (cdr nts))])))
(define-struct found-vars (nt source bound-vars found-nt?)) (define-struct found-vars (nt source bound-vars found-nt?))
(define (generate-pat pat bound-vars var-info size holes) (define (generate-pat pat bound-vars var-info size in-hole)
(let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f)) (let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
var-info)] var-info)]
[bindings (make-immutable-hasheq null)] [bindings (make-immutable-hasheq null)]
[mismatches (make-immutable-hasheq null)]) [mismatches (make-immutable-hasheq null)])
(let loop ([pat pat] [holes holes]) (let loop ([pat pat] [in-hole in-hole])
(define (generate/retry #:gen [gen (λ (p) (loop p holes))] success? . subpatterns) (define (generate/retry #:gen [gen (λ (p) (loop p in-hole))] success? . subpatterns)
(let ([old-fvt found-vars-table] (let ([old-fvt found-vars-table]
[old-bindings bindings] [old-bindings bindings]
[old-mismatches mismatches]) [old-mismatches mismatches])
@ -176,13 +176,6 @@ To do a better job of not generating programs with free variables,
(set! bindings old-bindings) (set! bindings old-bindings)
(set! mismatches old-mismatches) (set! mismatches old-mismatches)
(retry (sub1 remaining))))))))) (retry (sub1 remaining)))))))))
(define (generate-hole name)
(let* ([not-in-hole (gensym)]
[generate-contractum (hash-ref holes name not-in-hole)])
(if (eq? generate-contractum not-in-hole)
the-hole
(generate-contractum))))
(match pat (match pat
[`number ((next-number-decision) random-numbers)] [`number ((next-number-decision) random-numbers)]
[`(variable-except ,vars ...) [`(variable-except ,vars ...)
@ -192,7 +185,7 @@ To do a better job of not generating programs with free variables,
(generate/retry (λ (var) (not (memq var (compiled-lang-literals lang)))) 'variable)] (generate/retry (λ (var) (not (memq var (compiled-lang-literals lang)))) 'variable)]
[`(variable-prefix ,prefix) [`(variable-prefix ,prefix)
(string->symbol (string-append (symbol->string prefix) (string->symbol (string-append (symbol->string prefix)
(symbol->string (loop 'variable holes))))] (symbol->string (loop 'variable in-hole))))]
[`string ((next-string-decision) lang-chars lang-lits attempt)] [`string ((next-string-decision) lang-chars lang-lits attempt)]
[`(side-condition ,pattern ,(? procedure? condition)) [`(side-condition ,pattern ,(? procedure? condition))
(define (condition-bindings bindings) (define (condition-bindings bindings)
@ -200,14 +193,14 @@ To do a better job of not generating programs with free variables,
(generate/retry (λ _ (condition (condition-bindings bindings))) pattern)] (generate/retry (λ _ (condition (condition-bindings bindings))) pattern)]
[`(name ,(? symbol? id) ,p) [`(name ,(? symbol? id) ,p)
(define (generate/record) (define (generate/record)
(let ([term (loop p holes)]) (let ([term (loop p in-hole)])
(set! bindings (hash-set bindings id term)) (set! bindings (hash-set bindings id term))
term)) term))
(hash-ref bindings id generate/record)] (hash-ref bindings id generate/record)]
[`hole (generate-hole #f)] [`hole (if in-hole (in-hole) the-hole)]
[`(in-hole ,context ,contractum) [`(in-hole ,context ,contractum)
(loop context (hash-set holes #f (λ () (loop contractum holes))))] (loop context (λ () (loop contractum in-hole)))]
[`(hide-hole ,pattern) (loop pattern (make-immutable-hasheq null))] [`(hide-hole ,pattern) (loop pattern #f)]
[`any [`any
(let-values ([(lang nt) ((next-any-decision) lang)]) (let-values ([(lang nt) ((next-any-decision) lang)])
(generate* lang nt size attempt decisions@))] (generate* lang nt size attempt decisions@))]
@ -215,8 +208,8 @@ To do a better job of not generating programs with free variables,
(define ((generate-nt/underscored decorated) undecorated) (define ((generate-nt/underscored decorated) undecorated)
(let* ([vars (append (extract-bound-vars decorated found-vars-table) bound-vars)] (let* ([vars (append (extract-bound-vars decorated found-vars-table) bound-vars)]
[term (if (is-nt? lang undecorated) [term (if (is-nt? lang undecorated)
(generate-nt undecorated vars size holes) (generate-nt undecorated vars size in-hole)
(generate-pat undecorated vars null size holes))]) (generate-pat undecorated vars null size in-hole))])
(begin (begin
(set! found-vars-table (extend-found-vars decorated term found-vars-table)) (set! found-vars-table (extend-found-vars decorated term found-vars-table))
term))) term)))
@ -242,10 +235,10 @@ To do a better job of not generating programs with free variables,
[(? pair? pat) [(? pair? pat)
(if (or (null? (cdr pat)) (if (or (null? (cdr pat))
(not (eq? '... (cadr pat)))) (not (eq? '... (cadr pat))))
(cons (loop (car pat) holes) (cons (loop (car pat) in-hole)
(loop (cdr pat) holes)) (loop (cdr pat) in-hole))
(append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat) holes))) (append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat) in-hole)))
(loop (cddr pat) holes)))] (loop (cddr pat) in-hole)))]
[else [else
(error 'generate "unknown pattern ~s\n" pat)])))) (error 'generate "unknown pattern ~s\n" pat)]))))
@ -281,7 +274,7 @@ To do a better job of not generating programs with free variables,
[else found-vars])) [else found-vars]))
found-vars-table)) found-vars-table))
(generate-pat nt '() '() size (make-immutable-hasheq null))) (generate-pat nt '() '() size #f))
;; find-base-cases : compiled-language -> hash-table ;; find-base-cases : compiled-language -> hash-table
(define (find-base-cases lang) (define (find-base-cases lang)