From 9e316c31620b25df420c0ab27bbd3cfa651edab0 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 13 Oct 2008 15:19:13 +0000 Subject: [PATCH] 1. Improved support for generating random numbers. 2. Fixed bug in find-base-cases. svn: r12002 --- collects/redex/private/rg-test.ss | 76 +++++++++++---------- collects/redex/private/rg.ss | 105 +++++++++++++++++++----------- 2 files changed, 106 insertions(+), 75 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index d36b9036cf..c4d60d01a1 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -36,7 +36,7 @@ (let () (define-language lc - (e (e e) + (e (e e ...) (+ e e) x v) @@ -56,34 +56,39 @@ (test (min-prods (car (compiled-lang-lang lang)) (find-base-cases lang)) (list (car (nt-rhs (car (compiled-lang-lang lang))))))) -(define (make-random nums) +(define (make-random . nums) (let ([nums (box nums)]) - (λ (m) + (λ ([m +inf.0]) (cond [(null? (unbox nums)) (error 'make-random "out of numbers")] [(>= (car (unbox nums)) m) (error 'make-random "number too large")] [else (begin0 (car (unbox nums)) (set-box! nums (cdr (unbox nums))))])))) -(test (pick-from-list '(a b c) (make-random '(1))) 'b) +(test (pick-from-list '(a b c) (make-random 1)) 'b) -(test (pick-length (make-random '(1 1 1 0))) 3) +(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)) (let* ([lits '("bcd" "cbd")] [chars (sort (unique-chars lits) char<=?)]) - (test (pick-char 0 chars (make-random '(1))) #\c) - (test (pick-char 50 chars (make-random '(1 1))) #\c) - (test (pick-char 50 chars (make-random '(0 65))) #\a) - (test (pick-char 500 chars (make-random '(0 1 65))) #\a) - (test (pick-char 500 chars (make-random '(0 0 3))) #\⇒) - (test (pick-char 2000 chars (make-random '(0 0 1 3))) #\⇒) - (test (pick-char 2000 chars (make-random '(0 0 0 1))) (integer->char #x4E01)) - (test (pick-char 50 chars (make-random `(0 ,(- (char->integer #\_) #x20)))) #\`) - (test (random-string chars lits 3 0 (make-random '(0 1))) "cbd") - (test (random-string chars lits 3 0 (make-random '(1 2 1 0))) "dcb") - (test (pick-string chars lits 0 (make-random '(1 1 1 0 1 2 1 0))) "dcb") - (test (pick-var chars lits null 0 (make-random '(0 0 1 1 2 1 0))) 'dcb) - (test (pick-var chars lits '(x) 0 (make-random '(1 0))) 'x) - (test (pick-char 0 null (make-random '(65))) #\a) - (test (random-string null null 1 0 (make-random '(65))) "a")) + (test (pick-char 0 chars (make-random 1)) #\c) + (test (pick-char 50 chars (make-random 1 1)) #\c) + (test (pick-char 50 chars (make-random 0 65)) #\a) + (test (pick-char 500 chars (make-random 0 1 65)) #\a) + (test (pick-char 500 chars (make-random 0 0 3)) #\⇒) + (test (pick-char 2000 chars (make-random 0 0 1 3)) #\⇒) + (test (pick-char 2000 chars (make-random 0 0 0 1)) (integer->char #x4E01)) + (test (pick-char 50 chars (make-random 0 (- (char->integer #\_) #x20))) #\`) + (test (random-string chars lits 3 0 (make-random 0 1)) "cbd") + (test (random-string chars lits 3 0 (make-random 1 2 1 0)) "dcb") + (test (pick-string chars lits 0 (make-random .5 1 2 1 0)) "dcb") + (test (pick-var chars lits null 0 (make-random .01 1 2 1 0)) 'dcb) + (test (pick-var chars lits '(x) 0 (make-random .5 0)) 'x) + (test (pick-char 0 null (make-random 65)) #\a) + (test (random-string null null 1 0 (make-random 65)) "a")) (define-syntax exn:fail-message (syntax-rules () @@ -113,9 +118,9 @@ (define (decisions #:var [var pick-var] #:nt [nt pick-nt] #:str [str pick-string] - #:num [num pick-from-list] + #:num [num pick-number] #:any [any pick-any] - #:seq [seq pick-length]) + #:seq [seq pick-sequence-length]) (define-syntax decision (syntax-rules () [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) @@ -216,23 +221,23 @@ (generate/decisions lang a 2 0 (decisions #:num (build-list 3 (λ (n) (λ (_) n))) - #:seq (list (λ () 2) (λ () 3) (λ () 1)))) + #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1)))) `(0 1 2 "foo" "foo" "foo" "bar" #t)) - (test (generate/decisions lang b 5 0 (decisions #:seq (list (λ () 0)))) + (test (generate/decisions lang b 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate/decisions lang c 5 0 (decisions #:seq (list (λ () 0)))) + (test (generate/decisions lang c 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate/decisions lang d 5 0 (decisions #:seq (list (λ () 2)))) + (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\\)") - (test (generate/decisions lang f 5 0 (decisions #:seq (list (λ () 0)))) null) + (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) - (λ () 2) (λ () 3) (λ () 4) (λ () 1) (λ () 3)))) + (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) + (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3)))) '((0 0 0) (0 0 0 0) (1 1 1))) (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 - (decisions #:seq (list (λ () 2) (λ () 3) (λ () 4) (λ () 2) (λ () 3) (λ () 5)))) + (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1)))) (let () @@ -249,7 +254,7 @@ lc e 10 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))) #:nt (patterns first first first third first) - #:seq (list (λ () 2))))) + #:seq (list (λ (_) 2))))) '(y x))) (let () @@ -347,7 +352,7 @@ (test ; bindings within ellipses collected properly (let/ec k (generate/decisions lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 - (decisions #:seq (list (λ () 2) (λ () 3) (λ () 4)) + (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4)) #:num (build-list 7 (λ (n) (λ (_) n)))))) '((0 1 2) (3 4 5 6)))) @@ -417,9 +422,9 @@ (define-language empty) ;; `any' pattern - (test (call-with-values (λ () (pick-any four (make-random (list 0 1)))) list) + (test (call-with-values (λ () (pick-any four (make-random 0 1))) list) (list four 'f)) - (test (call-with-values (λ () (pick-any four (make-random (list 1)))) list) + (test (call-with-values (λ () (pick-any four (make-random 1))) list) (list sexp 'sexp)) (test (generate/decisions four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4) (test (generate/decisions four any 5 0 @@ -480,7 +485,6 @@ "failed after 1 attempts:\n5\n")) ;; check-metafunction -;; TODO: handle no metafunctions with no contract (let () (define-language empty) (define-metafunction empty @@ -511,7 +515,7 @@ "failed after 1 attempts:\n(1 1)\n") ;; OK -- generated from Dom(h) (test (check-metafunction h) #t) - ;; OK -- generated from pattern 'any + ;; OK -- generated from pattern (any ...) (test (check-metafunction i) #t)) ;; parse/unparse-pattern diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 1b994a9f6b..f473a71d88 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -1,7 +1,5 @@ #| -iteratively grow the set of numbers & variables during generation. - redex: disallow non-terminals on rhs of rules unless they are actually bound(?) need support for: @@ -29,7 +27,7 @@ To do a better job of not generating programs with free variables, (define random-numbers '(0 1 -1 17 8)) (define (allow-free-var? [random random]) (= 0 (random 30))) -(define (exotic-char? [random random]) (= 0 (random 10))) +(define (exotic-choice? [random random]) (= 0 (random 5))) (define (use-lang-literal? [random random]) (= 0 (random 20))) (define (try-to-introduce-binder?) (= 0 (random 2)) #f) @@ -50,43 +48,22 @@ To do a better job of not generating programs with free variables, (define tex-chars-threshold 500) (define chinese-chars-threshold 2000) -;; E(pick-length) = 4/5(1 + E(pick-length)) = 4 -;; P(pick-length >= 50) = 4/5^50 ≈ 0.00143% -(define (pick-length [random random]) - (cond - [(zero? (random 5)) 0] - [else (+ 1 (pick-length random))])) - -;; pick-length averages about 4, has a max of about 50 and likes the small numbers: -#; -(let ([l (build-list 100000 (λ (x) (pick-length)))]) - (values (/ (apply + l) (length l)) - (apply max l) - (let ([ht (make-hash)]) - (for-each - (λ (n) (hash-set! ht n (+ 1 (hash-ref ht n 0)))) - l) - (sort (hash-map ht (λ (x y) (list x (/ y (length l) 1.0)))) - (λ (x y) (> (cadr x) (cadr y))))))) - (define (pick-var lang-chars lang-lits bound-vars attempt [random random]) - ;; E(length) = 4/5 + 1/5(1 + E(length)) = 5/4 - ;; P(length=c) = 4/(5^c) - (define (length) (if (not (zero? (random 5))) 1 (add1 (length)))) (if (or (null? bound-vars) (allow-free-var? random)) - (string->symbol (random-string lang-chars lang-lits (length) attempt random)) + (let ([length (add1 (random-natural 4/5 random))]) + (string->symbol (random-string lang-chars lang-lits length attempt random))) (pick-from-list bound-vars random))) (define (pick-char attempt lang-chars [random random]) (if (and (not (null? lang-chars)) (or (< attempt ascii-chars-threshold) - (not (exotic-char? random)))) + (not (exotic-choice? random)))) (pick-from-list lang-chars random) - (if (or (< attempt tex-chars-threshold) (not (exotic-char? random))) + (if (or (< attempt tex-chars-threshold) (not (exotic-choice? random))) (let ([i (random (- #x7E #x20 1))] [_ (- (char->integer #\_) #x20)]) (integer->char (+ #x20 (if (= i _) (add1 i) i)))) - (if (or (< attempt chinese-chars-threshold) (not (exotic-char? random))) + (if (or (< attempt chinese-chars-threshold) (not (exotic-choice? random))) (car (string->list (pick-from-list (map cadr tex-shortcut-table) random))) (integer->char (+ #x4E00 (random (- #x9FCF #x4E00)))))))) @@ -101,7 +78,7 @@ To do a better job of not generating programs with free variables, (values sexp (nt-name (car (compiled-lang-lang sexp)))))) (define (pick-string lang-chars lang-lits attempt [random random]) - (random-string lang-chars lang-lits (pick-length random) attempt random)) + (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) (define (pick-nt prods bound-vars size) (let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)] @@ -111,6 +88,56 @@ To do a better job of not generating programs with free variables, (define (pick-from-list l [random random]) (list-ref l (random (length l)))) +;; Chooses a random (exact) natural number from the "shifted" geometric distribution: +;; P(random-natural = k) = p(1-p)^k +;; +;; P(random-natural >= k) = (1-p)^(k+1) +;; E(random-natural) = (1-p)/p +;; Var(random-natural) = (1-p)/p^2 +(define (random-natural p [random random]) + (sub1 (inexact->exact (ceiling (real-part (/ (log (random)) (log (- 1 p)))))))) + +(define (negative? random) + (zero? (random 2))) + +(define (random-integer p [random random]) + (* (if (negative? random) -1 1) (random-natural p random))) + +(define (random-rational p [random random]) + (/ (random-integer p random) (add1 (random-natural p random)))) + +(define (random-real p [random random]) + (* (random) 2 (random-integer p random))) + +(define (random-complex p [random random]) + (let ([randoms (list random-integer random-rational random-real)]) + (make-rectangular ((pick-from-list randoms random) p random) + ((pick-from-list randoms random) p random)))) + +(define integer-threshold 100) +(define rational-threshold 500) +(define real-threshold 1000) +(define complex-threshold 2000) + +;; Determines the parameter p for which random-natural's expected value is E +(define (expected-value->p E) + ;; E = 0 => p = 1, which breaks random-natural + (/ 1 (+ (max 1 E) 1))) + +(define (pick-number attempt [random random]) + (cond [(or (< attempt integer-threshold) (not (exotic-choice? random))) + (random-natural (expected-value->p attempt) random)] + [(or (< attempt rational-threshold) (not (exotic-choice? random))) + (random-integer (expected-value->p (- attempt integer-threshold)) random)] + [(or (< attempt real-threshold) (not (exotic-choice? random))) + (random-rational (expected-value->p (- 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)])) + +(define (pick-sequence-length attempt) + (random-natural (expected-value->p (/ (log (add1 attempt)) (log 2))))) + (define (min-prods nt base-table) (let* ([sizes (hash-ref base-table (nt-name nt))] [min-size (apply min/f sizes)] @@ -223,7 +250,7 @@ To do a better job of not generating programs with free variables, (define (recur/pat pat) ((recur pat in-hole) state)) (match pat - [`number (values ((next-number-decision) random-numbers) state)] + [`number (values ((next-number-decision) attempt) state)] [`(variable-except ,vars ...) (generate/pred 'variable recur/pat (λ (var _) (not (memq var vars))))] [`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)] @@ -266,7 +293,7 @@ To do a better job of not generating programs with free variables, [(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)]) - (if prior prior ((next-sequence-decision))))] + (if prior prior ((next-sequence-decision) attempt)))] [(seq state) (generate-sequence ellipsis recur state length)] [(rest state) ((recur rest in-hole) (set-env (set-env state class length) name length))]) @@ -355,9 +382,8 @@ To do a better job of not generating programs with free variables, [`(cross ,(? symbol? x-nt)) (set! nts (cons x-nt nts))] [`() (void)] - [`(,a ,'... . ,b) - (loop a) - (loop b)] + [(struct ellipsis (_ p _ _)) + (loop p)] [`(,a . ,b) (loop a) (loop b)] @@ -650,18 +676,19 @@ To do a better job of not generating programs with free variables, (define random-decisions@ (unit (import) (export decisions^) (define (next-variable-decision) pick-var) - (define (next-number-decision) pick-from-list) + (define (next-number-decision) pick-number) (define (next-non-terminal-decision) pick-nt) - (define (next-sequence-decision) pick-length) + (define (next-sequence-decision) pick-sequence-length) (define (next-any-decision) pick-any) (define (next-string-decision) pick-string))) -(provide pick-from-list pick-var pick-length min-prods decisions^ +(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length is-nt? pick-char random-string pick-string check 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 + pick-number parse-language) (provide/contract [find-base-cases (-> compiled-lang? hash?)]) \ No newline at end of file