1. Improved support for generating random numbers.
2. Fixed bug in find-base-cases. svn: r12002
This commit is contained in:
Casey Klein
parent
86671cf6dc
commit
9e316c3162
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?)])
|
||||
Loading…
Reference in New Issue
Block a user