diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 6a7e93fc9c..dc6520eb2d 100644 --- a/collects/redex/private/rg-test.ss +++ b/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")] - [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 .5 1 2 1 0)) "dcb") - (test (pick-var chars lits 0 (make-random .01 1 2 1 0)) 'dcb) - (test (pick-char 0 null (make-random 65)) #\a) - (test (random-string null null 1 0 (make-random 65)) "a")) +(let* ([lits '("bcd" "cbd")]) + (test (pick-char 0 (make-random 0 0)) #\A) + (test (pick-char 0 (make-random 2 1)) #\c) + (test (pick-char 1000 (make-random 1 25 0)) #\Z) + (test (pick-char 1000 (make-random 0 65)) #\a) + (test (pick-char 1500 (make-random 0 1 65)) #\a) + (test (pick-char 1500 (make-random 0 0 3)) #\⇒) + (test (pick-char 2500 (make-random 0 0 1 3)) #\⇒) + (test (pick-char 2500 (make-random 0 0 0 1)) (integer->char #x4E01)) + (test (pick-char 1000 (make-random 0 (- (char->integer #\_) #x20))) #\`) + (test (random-string lits 3 0 (make-random 0 1)) "cbd") + (test (random-string lits 3 0 (make-random 1 0 1 1 1 2 1)) "abc") + (test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc") + (test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc)) (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<=?)))))))) - (cons '(#\a #\b #\f #\o #\r) - '("bar" "foo")))) + (decisions #:str (list (λ (l a) (k (sort l string<=?))))))) + '("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)))) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 2d627a047f..091f8ec73e 100644 --- a/collects/redex/private/rg.ss +++ b/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 tex-chars-threshold 500) -(define chinese-chars-threshold 2000) +(define ascii-chars-threshold 1000) +(define tex-chars-threshold 1500) +(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]) - (if (and (not (null? lang-chars)) - (or (< attempt ascii-chars-threshold) - (not (exotic-choice? random)))) - (pick-from-list lang-chars 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-choice? random))) - (car (string->list (pick-from-list (map cadr tex-shortcut-table) random))) - (integer->char (+ #x4E00 (random (- #x9FCF #x4E00)))))))) +(define (pick-char attempt [random random]) + (cond [(or (< attempt ascii-chars-threshold) (not (exotic-choice? random))) + (let ([i (random (add1 (- (char->integer #\z) (char->integer #\a))))] + [cap? (zero? (random 2))]) + (integer->char (+ i (char->integer (if cap? #\A #\a)))))] + [(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))))] + [(or (< attempt chinese-chars-threshold) (not (exotic-choice? random))) + (car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))] + [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]) - (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) +(define (pick-string lang-lits attempt [random 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) - (rg-lang-chars lang) (rg-lang-lits lang) attempt) + (values ((next-variable-decision) (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)