diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 103dec9f7c..fafdb8079d 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -81,6 +81,10 @@ (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)) +(test (pick-natural 224 (make-random 1/5)) 5) +(test (pick-integer 900 (make-random 0 0 1/5)) -7) +(test (pick-real 9000 (make-random 0 0 0 .5 1 1/8)) 11.0) + (let* ([lits '("bcd" "cbd")] [chars (sort (unique-chars lits) char<=?)]) (test (pick-char 0 chars (make-random 1)) #\c) @@ -148,6 +152,9 @@ #:nt [nt pick-nt] #:str [str pick-string] #:num [num pick-number] + #:nat [nat pick-natural] + #:int [int pick-integer] + #:real [real pick-real] #:any [any pick-any] #:seq [seq pick-sequence-length] #:pref [pref pick-preferred-productions]) @@ -158,6 +165,9 @@ (define next-variable-decision (decision var)) (define next-non-terminal-decision (decision nt)) (define next-number-decision (decision num)) + (define next-natural-decision (decision nat)) + (define next-integer-decision (decision int)) + (define next-real-decision (decision real)) (define next-string-decision (decision str)) (define next-any-decision (decision any)) (define next-sequence-decision (decision seq)) @@ -236,6 +246,24 @@ (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) 'z)) +(let () + (define-language L + (n natural) + (i integer) + (r real)) + (test (let ([n (generate-term L n 0 #:attempt 10000)]) + (and (integer? n) + (exact? n) + (not (negative? n)))) + #t) + (test (generate-term/decisions L n 0 1 (decisions #:nat (λ (_) 42))) 42) + (test (let ([i (generate-term L i 0 #:attempt 10000)]) + (and (integer? i) (exact? i))) + #t) + (test (generate-term/decisions L i 0 1 (decisions #:int (λ (_) -42))) -42) + (test (real? (generate-term L r 0 #:attempt 10000)) #t) + (test (generate-term/decisions L r 0 1 (decisions #:real (λ (_) 4.2))) 4.2)) + (let () (define-language lang (a (number number ... "foo" ... "bar" #t ...)) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 0fa360b0d6..50732ad1bd 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -153,16 +153,28 @@ To do a better job of not generating programs with free variables, (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->size attempt)) random)] - [(or (< attempt rational-threshold) (not (exotic-choice? 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->size (- attempt rational-threshold))) random)] - [(or (< attempt complex-threshold) (not (exotic-choice? 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-number attempt #:top-threshold [top-threshold complex-threshold] [random random]) + (let loop ([threshold 0] + [generator random-natural] + [levels `((,integer-threshold . ,random-integer) + (,rational-threshold . ,random-rational) + (,real-threshold . ,random-real) + (,complex-threshold . ,random-complex))]) + (if (or (null? levels) + (< attempt (caar levels)) + (< top-threshold (caar levels)) + (not (exotic-choice? random))) + (generator (expected-value->p (attempt->size (- attempt threshold))) random) + (loop (caar levels) (cdar levels) (cdr levels))))) + +(define (pick-natural attempt [random random]) + (pick-number attempt #:top-threshold 0 random)) + +(define (pick-integer attempt [random random]) + (pick-number attempt #:top-threshold integer-threshold random)) + +(define (pick-real attempt [random random]) + (pick-number attempt #:top-threshold real-threshold random)) (define (pick-sequence-length attempt) (random-natural (expected-value->p (attempt->size attempt)))) @@ -309,6 +321,9 @@ To do a better job of not generating programs with free variables, (match pat [`number (values ((next-number-decision) attempt) state)] + [`natural (values ((next-natural-decision) attempt) state)] + [`integer (values ((next-integer-decision) attempt) state)] + [`real (values ((next-real-decision) attempt) state)] [`(variable-except ,vars ...) (generate/pred 'variable (recur/pat/size-attempt 'variable) @@ -875,6 +890,9 @@ To do a better job of not generating programs with free variables, (define-signature decisions^ (next-variable-decision next-number-decision + next-natural-decision + next-integer-decision + next-real-decision next-non-terminal-decision next-sequence-decision next-any-decision @@ -885,6 +903,9 @@ To do a better job of not generating programs with free variables, (unit (import) (export decisions^) (define (next-variable-decision) pick-var) (define (next-number-decision) pick-number) + (define (next-natural-decision) pick-natural) + (define (next-integer-decision) pick-integer) + (define (next-real-decision) pick-real) (define (next-non-terminal-decision) pick-nt) (define (next-sequence-decision) pick-sequence-length) (define (next-any-decision) pick-any) @@ -899,7 +920,8 @@ To do a better job of not generating programs with free variables, 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 parse-language check-reduction-relation + 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