Generator support for natural', integer', and `real' patterns.

svn: r13961

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 ...))

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])
+(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random random])
-  (cond [(or (< attempt integer-threshold) (not (exotic-choice? random)))
+  (let loop ([threshold 0] 
-         (random-natural (expected-value->p (attempt->size attempt)) random)]
+             [generator random-natural]
-        [(or (< attempt rational-threshold) (not (exotic-choice? random)))
+             [levels `((,integer-threshold . ,random-integer)
-         (random-integer (expected-value->p (attempt->size (- attempt integer-threshold))) random)]
+                       (,rational-threshold . ,random-rational)
-        [(or (< attempt real-threshold) (not (exotic-choice? random)))
+                       (,real-threshold . ,random-real)
-         (random-rational (expected-value->p (attempt->size (- attempt rational-threshold))) random)]
+                       (,complex-threshold . ,random-complex))])
-        [(or (< attempt complex-threshold) (not (exotic-choice? random)))
+    (if (or (null? levels)
-         (random-real (expected-value->p (attempt->size (- attempt real-threshold))) random)]
+            (< attempt (caar levels))
-        [else (random-complex (expected-value->p (attempt->size (- attempt complex-threshold))) random)]))
+            (< 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