From 8bd2b94dea39d873db040caf26cbae5e98e93d1f Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sat, 29 Nov 2008 14:41:49 +0000 Subject: [PATCH] 1. Renamed `check-metafunction' to `check-metafunction-contract'. 2. Generator now eventually focuses probability on randomly chosen preferred productions. svn: r12636 --- collects/redex/private/rg-test.ss | 79 ++++++++++--------- collects/redex/private/rg.ss | 124 ++++++++++++++++++------------ 2 files changed, 114 insertions(+), 89 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index c4d60d01a1..836183f185 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -65,12 +65,12 @@ (test (pick-from-list '(a b c) (make-random 1)) 'b) -(test (pick-number 3 (make-random .5)) 2) -(test (pick-number 109 (make-random 0 0 .5)) -6) -(test (pick-number 509 (make-random 0 0 1 .5 .25)) 3/7) -(test (pick-number 1009 (make-random 0 0 0 .5 1 .5)) 6.0) -(test (pick-number 2009 (make-random 0 0 0 0 2 .5 1 .5 0 0 .5)) - (make-rectangular 6.0 -6)) +(test (pick-number 24 (make-random 1/5)) 3) +(test (pick-number 224 (make-random 0 0 1/5)) -5) +(test (pick-number 524 (make-random 0 0 1 1/5 1/5)) 3/4) +(test (pick-number 1624 (make-random 0 0 0 .5 1 .5)) 3.0) +(test (pick-number 2624 (make-random 0 0 0 0 1 1 1/5 1/5 2 .5 0 .5)) + (make-rectangular 7/8 -3.0)) (let* ([lits '("bcd" "cbd")] [chars (sort (unique-chars lits) char<=?)]) @@ -101,7 +101,8 @@ (make-exn-not-raised))))])) (define (patterns . selectors) - (map (λ (selector) (λ (prods . _) (selector prods))) selectors)) + (map (λ (selector) (λ (name prods vars size) (list (selector prods)))) + selectors)) (define (iterator name items) (let ([bi (box items)]) @@ -124,13 +125,18 @@ (define-syntax decision (syntax-rules () [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) - (unit (import) (export decisions^) - (define next-variable-decision (decision var)) - (define next-non-terminal-decision (decision nt)) - (define next-number-decision (decision num)) - (define next-string-decision (decision str)) - (define next-any-decision (decision any)) - (define next-sequence-decision (decision seq)))) + (λ (lang) + (unit (import) (export decisions^) + (define next-variable-decision (decision var)) + (define next-non-terminal-decision + (if (procedure? nt) + (let ([next (nt lang)]) + (λ () next)) + (iterator 'nt nt))) + (define next-number-decision (decision num)) + (define next-string-decision (decision str)) + (define next-any-decision (decision any)) + (define next-sequence-decision (decision seq))))) (let () (define-language lc @@ -152,22 +158,13 @@ (decisions #:var (list (λ _ 'x) (λ _ 'y)))) '(x x y y)) - ;; Minimum rhs is chosen with zero size - (test - (let/ec k - (generate/decisions - lc e 0 0 - (decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods))))))) - '(x)) - - ;; Size decremented - (let ([size 5]) - (test - (let/ec k - (generate/decisions - lc e size 0 - (decisions #:nt (list (λ (prods . _) (cadr prods)) (λ (p b s) (k s)))))) - (sub1 size)))) + ; After choosing (e e), size decremented forces each e to x. + (test + (generate/decisions + lc e 1 0 + (decisions #:nt (patterns first) + #:var (list (λ _ 'x) (λ _ 'y)))) + '(x y))) ;; #:binds (let () @@ -230,7 +227,7 @@ (test (generate/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) '(4 4 4 4 (4 4) (4 4))) (test (exn:fail-message (generate lang e 5)) - #rx"generate: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\)") + #rx"generate: unable to generate pattern e") (test (generate/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) @@ -460,6 +457,9 @@ #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) +; preferred productions + + ;; current-error-port-output : (-> (-> any) string) (define (current-error-port-output thunk) (let ([p (open-output-string)]) @@ -484,7 +484,7 @@ (test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised)))) "failed after 1 attempts:\n5\n")) -;; check-metafunction +;; check-metafunction-contract (let () (define-language empty) (define-metafunction empty @@ -504,19 +504,22 @@ [(i any ...) (any ...)]) ;; Dom(f) < Ctc(f) - (test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 2) (λ _ 5)))))) + (test (current-error-port-output + (λ () (check-metafunction-contract f (decisions #:num (list (λ _ 2) (λ _ 5)))))) "failed after 1 attempts:\n(5)\n") ;; Rng(f) > Codom(f) - (test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 3)))))) + (test (current-error-port-output + (λ () (check-metafunction-contract f (decisions #:num (list (λ _ 3)))))) "failed after 1 attempts:\n(3)\n") ;; LHS matches multiple ways - (test (current-error-port-output (λ () (check-metafunction g (decisions #:num (list (λ _ 1) (λ _ 1)) - #:seq (list (λ _ 2)))))) + (test (current-error-port-output + (λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1)) + #:seq (list (λ _ 2)))))) "failed after 1 attempts:\n(1 1)\n") ;; OK -- generated from Dom(h) - (test (check-metafunction h) #t) + (test (check-metafunction-contract h) #t) ;; OK -- generated from pattern (any ...) - (test (check-metafunction i) #t)) + (test (check-metafunction-contract i) #t)) ;; parse/unparse-pattern (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index f473a71d88..4131ea1eef 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -25,10 +25,12 @@ To do a better job of not generating programs with free variables, (for-syntax "reduction-semantics.ss") mrlib/tex-table) -(define random-numbers '(0 1 -1 17 8)) (define (allow-free-var? [random random]) (= 0 (random 30))) (define (exotic-choice? [random random]) (= 0 (random 5))) (define (use-lang-literal? [random random]) (= 0 (random 20))) +(define (preferred-production? attempt [random random]) + (and (>= attempt preferred-production-threshold) + (zero? (random 2)))) (define (try-to-introduce-binder?) (= 0 (random 2)) #f) ;; unique-chars : (listof string) -> (listof char) @@ -42,12 +44,13 @@ To do a better job of not generating programs with free variables, (define generation-retries 100) (define default-check-attempts 100) -(define check-growth-base 5) (define ascii-chars-threshold 50) (define tex-chars-threshold 500) (define chinese-chars-threshold 2000) +(define preferred-production-threshold 3000) + (define (pick-var lang-chars lang-lits bound-vars attempt [random random]) (if (or (null? bound-vars) (allow-free-var? random)) (let ([length (add1 (random-natural 4/5 random))]) @@ -80,11 +83,14 @@ To do a better job of not generating programs with free variables, (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 prods bound-vars size) +(define ((pick-nt pref-prods) nt prods bound-vars attempt) (let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)] - [do-intro-binder? (and (not (zero? size)) (null? bound-vars) - (not (null? binders)) (try-to-introduce-binder?))]) - (pick-from-list (if do-intro-binder? binders prods)))) + [do-intro-binder? (and (null? bound-vars) + (not (null? binders)) + (try-to-introduce-binder?))]) + (cond [do-intro-binder? binders] + [(preferred-production? attempt) (list (hash-ref pref-prods nt))] + [else prods]))) (define (pick-from-list l [random random]) (list-ref l (random (length l)))) @@ -124,19 +130,24 @@ To do a better job of not generating programs with free variables, ;; E = 0 => p = 1, which breaks random-natural (/ 1 (+ (max 1 E) 1))) +; Determines a size measure for numbers, sequences, etc., using the +; attempt count. +(define (attempt->size n) + (inexact->exact (floor (/ (log (add1 n)) (log 5))))) + (define (pick-number attempt [random random]) (cond [(or (< attempt integer-threshold) (not (exotic-choice? random))) - (random-natural (expected-value->p attempt) random)] + (random-natural (expected-value->p (attempt->size attempt)) random)] [(or (< attempt rational-threshold) (not (exotic-choice? random))) - (random-integer (expected-value->p (- attempt integer-threshold)) random)] + (random-integer (expected-value->p (attempt->size (- attempt integer-threshold))) random)] [(or (< attempt real-threshold) (not (exotic-choice? random))) - (random-rational (expected-value->p (- attempt rational-threshold)) random)] + (random-rational (expected-value->p (attempt->size (- attempt rational-threshold))) random)] [(or (< attempt complex-threshold) (not (exotic-choice? random))) - (random-real (expected-value->p (- attempt real-threshold)) random)] - [else (random-complex (expected-value->p (- attempt complex-threshold)) random)])) + (random-real (expected-value->p (attempt->size (- attempt real-threshold))) random)] + [else (random-complex (expected-value->p (attempt->size (- attempt complex-threshold))) random)])) (define (pick-sequence-length attempt) - (random-natural (expected-value->p (/ (log (add1 attempt)) (log 2))))) + (random-natural (expected-value->p (attempt->size attempt)))) (define (min-prods nt base-table) (let* ([sizes (hash-ref base-table (nt-name nt))] @@ -144,11 +155,7 @@ To do a better job of not generating programs with free variables, [zip (λ (l m) (map cons l m))]) (map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) -(define (generation-failure pat) - (error 'generate "unable to generate pattern ~s in ~s attempts" - (unparse-pattern pat) generation-retries)) - -(define (generate* lang pat [decisions@ random-decisions@]) +(define (generate* lang pat decisions@) (define-values/invoke-unit decisions@ (import) (export decisions^)) @@ -161,16 +168,17 @@ To do a better job of not generating programs with free variables, ([(nt) (findf (λ (nt) (eq? name (nt-name nt))) (append (compiled-lang-lang lang) (compiled-lang-cclang lang)))] - [(rhs) - ((next-non-terminal-decision) - (if (zero? size) (min-prods nt base-table) (nt-rhs nt)) - bound-vars size)] [(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)] - [(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())] [(term _) (generate/pred - (rhs-pattern rhs) - (λ (pat) (((generate-pat bound-vars (max 0 (sub1 size)) attempt) pat in-hole) nt-state)) + name + (λ () + (let ([rhs (pick-from-list + (if (zero? size) + (min-prods nt base-table) + ((next-non-terminal-decision) name (nt-rhs nt) bound-vars attempt)))]) + (((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole) + (make-state (map fvt-entry (rhs-var-info rhs)) #hash())))) (λ (_ env) (mismatches-satisfied? env)))]) (values term (extend-found-vars fvt-id term state)))) @@ -199,11 +207,12 @@ To do a better job of not generating programs with free variables, (values (cons term terms) (cons (state-env state) envs) fvt))))]) (values seq (make-state fvt (merge-environments envs))))) - (define (generate/pred pat gen pred) + (define (generate/pred name gen pred) (let retry ([remaining generation-retries]) (if (zero? remaining) - (generation-failure pat) - (let-values ([(term state) (gen pat)]) + (error 'generate "unable to generate pattern ~s in ~s attempts" + name generation-retries) + (let-values ([(term state) (gen)]) (if (pred term (state-env state)) (values term state) (retry (sub1 remaining))))))) @@ -252,10 +261,14 @@ To do a better job of not generating programs with free variables, (match pat [`number (values ((next-number-decision) attempt) state)] [`(variable-except ,vars ...) - (generate/pred 'variable recur/pat (λ (var _) (not (memq var vars))))] + (generate/pred 'variable + (λ () (recur/pat 'variable)) + (λ (var _) (not (memq var vars))))] [`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)] [`variable-not-otherwise-mentioned - (generate/pred 'variable recur/pat (λ (var _) (not (memq var (compiled-lang-literals lang)))))] + (generate/pred 'variable + (λ () (recur/pat 'variable)) + (λ (var _) (not (memq var (compiled-lang-literals lang)))))] [`(variable-prefix ,prefix) (define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) @@ -263,7 +276,9 @@ To do a better job of not generating programs with free variables, (values (symbol-append prefix term) state))] [`string (values ((next-string-decision) lang-chars lang-lits attempt) state)] [`(side-condition ,pat ,(? procedure? condition)) - (generate/pred pat recur/pat (λ (_ env) (condition (bindings env))))] + (generate/pred (unparse-pattern pat) + (λ () (recur/pat pat)) + (λ (_ env) (condition (bindings env))))] [`(name ,(? symbol? id) ,p) (let-values ([(term state) (recur/pat p)]) (values term (set-env state (make-binder id) term)))] @@ -343,8 +358,8 @@ To do a better job of not generating programs with free variables, (λ (size attempt) (let-values ([(term state) (generate/pred - pat - (λ (pat) + (unparse-pattern pat) + (λ () (((generate-pat null size attempt) pat the-hole) (make-state null #hash()))) (λ (_ env) (mismatches-satisfied? env)))]) @@ -596,7 +611,7 @@ To do a better job of not generating programs with free variables, [(name/ellipses ...) names/ellipses]) (syntax/loc stx (check-property - (term-generator lang pat random-decisions@) + (term-generator lang pat random-decisions) (λ (_ bindings) (with-handlers ([exn:fail? (λ (_) #f)]) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) @@ -609,7 +624,7 @@ To do a better job of not generating programs with free variables, #t (let ([attempt (add1 (- attempts remaining))]) (let-values ([(term bindings) - (generate (floor (/ (log attempt) (log check-growth-base))) attempt)]) + (generate (attempt->size attempt) attempt)]) (if (property term bindings) (loop (sub1 remaining)) (begin @@ -621,7 +636,7 @@ To do a better job of not generating programs with free variables, (define-syntax generate (syntax-rules () [(_ lang pat size attempt) - (let-values ([(term _) ((term-generator lang pat random-decisions@) size attempt)]) + (let-values ([(term _) ((term-generator lang pat random-decisions) size attempt)]) term)] [(_ lang pat size) (generate lang pat size 0)])) @@ -633,37 +648,39 @@ To do a better job of not generating programs with free variables, (define-syntax (term-generator stx) (syntax-case stx () - [(_ lang pat decisions@) + [(_ lang pat decisions) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts #'lang 'generate) 'generate #t #'pat)]) (syntax/loc stx - (generate* - (parse-language lang) - (reassign-classes (parse-pattern `pattern lang 'top-level)) - decisions@)))])) + (let ([lang (parse-language lang)]) + (generate* + lang + (reassign-classes (parse-pattern `pattern lang 'top-level)) + (decisions lang)))))])) -(define-syntax (check-metafunction stx) +(define-syntax (check-metafunction-contract stx) (syntax-case stx () - [(_ name) (syntax/loc stx (check-metafunction name random-decisions@))] - [(_ name decisions@) + [(_ name) + (syntax/loc stx (check-metafunction-contract name random-decisions))] + [(_ name decisions) (identifier? #'name) (with-syntax ([m (let ([tf (syntax-local-value #'name (λ () #f))]) (if (term-fn? tf) (term-fn-get-id tf) (raise-syntax-error #f "not a metafunction" stx #'name)))]) - (syntax - (let ([lang (metafunc-proc-lang m)] + (syntax/loc stx + (let ([lang (parse-language (metafunc-proc-lang m))] [dom (metafunc-proc-dom-pat m)]) (check-property - (generate* (parse-language lang) + (generate* lang (reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level)) - decisions@) + (decisions lang)) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) (begin (term (name ,@t)) #t))) - 100))))])) + default-check-attempts))))])) (define-signature decisions^ (next-variable-decision @@ -673,11 +690,16 @@ To do a better job of not generating programs with free variables, next-any-decision next-string-decision)) -(define random-decisions@ +(define (random-decisions lang) + (define preferred-productions + (make-immutable-hasheq + (map (λ (nt) (cons (nt-name nt) (pick-from-list (nt-rhs nt)))) + (append (compiled-lang-lang lang) + (compiled-lang-cclang lang))))) (unit (import) (export decisions^) (define (next-variable-decision) pick-var) (define (next-number-decision) pick-number) - (define (next-non-terminal-decision) pick-nt) + (define (next-non-terminal-decision) (pick-nt preferred-productions)) (define (next-sequence-decision) pick-sequence-length) (define (next-any-decision) pick-any) (define (next-string-decision) pick-string))) @@ -687,7 +709,7 @@ To do a better job of not generating programs with free variables, pick-nt unique-chars pick-any sexp generate parse-pattern class-reassignments reassign-classes unparse-pattern (struct-out ellipsis) (struct-out mismatch) (struct-out class) - (struct-out binder) generate/decisions check-metafunction + (struct-out binder) generate/decisions check-metafunction-contract pick-number parse-language) (provide/contract