Term generator now less aggressive about producing weird variables and

strings.

svn: r15860

collects/redex/private/rg-test.ss

@@ -96,22 +96,20 @@
 (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")]
+(let* ([lits '("bcd" "cbd")])
-       [chars (sort (unique-chars lits) char<=?)])
+  (test (pick-char 0 (make-random 0 0)) #\A)
-  (test (pick-char 0 chars (make-random 1)) #\c)
+  (test (pick-char 0 (make-random 2 1)) #\c)
-  (test (pick-char 50 chars (make-random 1 1)) #\c)
+  (test (pick-char 1000 (make-random 1 25 0)) #\Z)
-  (test (pick-char 50 chars (make-random 0 65)) #\a)
+  (test (pick-char 1000 (make-random 0 65)) #\a)
-  (test (pick-char 500 chars (make-random 0 1 65)) #\a)
+  (test (pick-char 1500 (make-random 0 1 65)) #\a)
-  (test (pick-char 500 chars (make-random 0 0 3)) #\⇒)
+  (test (pick-char 1500 (make-random 0 0 3)) #\⇒)
-  (test (pick-char 2000 chars (make-random 0 0 1 3)) #\⇒)
+  (test (pick-char 2500 (make-random 0 0 1 3)) #\⇒)
-  (test (pick-char 2000 chars (make-random 0 0 0 1)) (integer->char #x4E01))
+  (test (pick-char 2500 (make-random 0 0 0 1)) (integer->char #x4E01))
-  (test (pick-char 50 chars (make-random 0 (- (char->integer #\_) #x20))) #\`)
+  (test (pick-char 1000 (make-random 0 (- (char->integer #\_) #x20))) #\`)
-  (test (random-string chars lits 3 0 (make-random 0 1)) "cbd")
+  (test (random-string lits 3 0 (make-random 0 1)) "cbd")
-  (test (random-string chars lits 3 0 (make-random 1 2 1 0)) "dcb")
+  (test (random-string lits 3 0 (make-random 1 0 1 1 1 2 1)) "abc")
-  (test (pick-string chars lits 0 (make-random .5 1 2 1 0)) "dcb")
+  (test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc")
-  (test (pick-var chars lits 0 (make-random .01 1 2 1 0)) 'dcb)
+  (test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc))
-  (test (pick-char 0 null (make-random 65)) #\a)
-  (test (random-string null null 1 0 (make-random 65)) "a"))
 
 (let ()
   (define-language L
@@ -332,9 +330,8 @@
    (let/ec k 
      (generate-term/decisions 
       lang e 5 0 
-      (decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
+      (decisions #:str (list (λ (l a) (k (sort l string<=?)))))))
-   (cons '(#\a #\b #\f #\o #\r)
+   '("bar" "foo")))
-         '("bar" "foo"))))
 
 (let ()
   (define-language lang
@@ -518,7 +515,7 @@
   (test
    (generate-term/decisions
     L (side-condition x (number? (term x))) 0 0
-    (decisions #:var (λ (lang-chars lang-lits attempt)
+    (decisions #:var (λ (lang-lits attempt)
                        (if (>= attempt retry-threshold) 0 'x))))
    0)
   
@@ -527,7 +524,7 @@
         [finish (+ retry-threshold post-threshold-incr)])
     (generate-term/decisions
      L (side-condition x (number? (term x))) 0 start
-     (decisions #:var (λ (lang-chars lang-lits attempt)
+     (decisions #:var (λ (lang-lits attempt)
                         (set! attempts (cons attempt attempts))
                         (if (= attempt finish) 0 'x))))
     (test attempts (list finish retry-threshold start))))

collects/redex/private/rg.ss

@@ -18,41 +18,34 @@
   (and (>= attempt preferred-production-threshold)
        (zero? (random 2))))
 
-;; unique-chars : (listof string) -> (listof char)
-(define (unique-chars strings)
-  (let ([uniq (make-hasheq)])
-    (for ([lit strings])
-         (for ([char lit])
-              (hash-set! uniq char #t)))
-    (hash-map uniq (λ (k v) k))))
-
 (define default-check-attempts 1000)
 
-(define ascii-chars-threshold 50)
+(define ascii-chars-threshold 1000)
-(define tex-chars-threshold 500)
+(define tex-chars-threshold 1500)
-(define chinese-chars-threshold 2000)
+(define chinese-chars-threshold 2500)
 
-(define (pick-var lang-chars lang-lits attempt [random random])
+(define (pick-var lang-lits attempt [random random])
   (let ([length (add1 (random-natural 4/5 random))])
-    (string->symbol (random-string lang-chars lang-lits length attempt random))))
+    (string->symbol (random-string lang-lits length attempt random))))
 
-(define (pick-char attempt lang-chars [random random])
+(define (pick-char attempt [random random])
-  (if (and (not (null? lang-chars)) 
+  (cond [(or (< attempt ascii-chars-threshold) (not (exotic-choice? random)))
-           (or (< attempt ascii-chars-threshold)
+         (let ([i (random (add1 (- (char->integer #\z) (char->integer #\a))))]
-               (not (exotic-choice? random))))
+               [cap? (zero? (random 2))])
-      (pick-from-list lang-chars random)
+           (integer->char (+ i (char->integer (if cap? #\A #\a)))))]
-      (if (or (< attempt tex-chars-threshold) (not (exotic-choice? random)))
+        [(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))))
+           (integer->char (+ #x20 (if (= i _) (add1 i) i))))]
-          (if (or (< attempt chinese-chars-threshold) (not (exotic-choice? random)))
+        [(or (< attempt chinese-chars-threshold) (not (exotic-choice? random)))
-              (car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))
+         (car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))]
-              (integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))))))
+        [else
+         (integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))]))
 
-(define (random-string lang-chars lang-lits length attempt [random random])
+(define (random-string lang-lits length attempt [random random])
   (if (and (not (null? lang-lits)) (use-lang-literal? random))
       (pick-from-list lang-lits random)
-      (list->string (build-list length (λ (_) (pick-char attempt lang-chars random))))))
+      (list->string (build-list length (λ (_) (pick-char attempt random))))))
 
 (define (pick-any lang sexp [random random]) 
   (let ([c-lang (rg-lang-clang lang)]
@@ -61,8 +54,8 @@
         (values lang (pick-from-list (map nt-name (compiled-lang-lang c-lang)) random))
         (values sexp (nt-name (car (compiled-lang-lang c-sexp)))))))
 
-(define (pick-string lang-chars lang-lits attempt [random random])
+(define (pick-string lang-lits attempt [random random])
-  (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
+  (random-string lang-lits (random-natural 1/5 random) attempt random))
 
 (define (pick-nt name cross? lang attempt pref-prods 
                  [random random]
@@ -172,11 +165,11 @@
          [min-size (apply min/f sizes)])
     (map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
 
-(define-struct rg-lang (clang lits chars base-cases))
+(define-struct rg-lang (clang lits base-cases))
 (define (prepare-lang lang)
   (let ([lits (map symbol->string (compiled-lang-literals lang))]
         [parsed (parse-language lang)])
-    (make-rg-lang parsed lits (unique-chars lits) (find-base-cases parsed))))
+    (make-rg-lang parsed lits (find-base-cases parsed))))
 
 (define (generate lang decisions@ user-gen retries what)
   (define-values/invoke-unit decisions@
@@ -309,8 +302,7 @@
                         (λ (var _) (not (memq var vars)))
                         size attempt)]
         [`variable 
-         (values ((next-variable-decision)
+         (values ((next-variable-decision) (rg-lang-lits lang) attempt)
-                  (rg-lang-chars lang) (rg-lang-lits lang) attempt)
                  env)]
         [`variable-not-otherwise-mentioned
          (generate/pred 'variable
@@ -323,7 +315,7 @@
          (let-values ([(term env) (recur/pat 'variable)])
            (values (symbol-append prefix term) env))]
         [`string 
-         (values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt)
+         (values ((next-string-decision) (rg-lang-lits lang) attempt)
                  env)]
         [`(side-condition ,pat ,(? procedure? condition))
          (generate/pred (unparse-pattern pat) 
@@ -998,5 +990,5 @@
          proportion-before-threshold post-threshold-incr
          is-nt? nt-by-name min-prods
          generation-decisions decisions^ 
-         random-string unique-chars
+         random-string
          sexp find-base-cases)