suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix redex repeat enum bug.

Browse Source 
Also small api change, variable enumeration change (again) and more
experimentation with a sound dep/e.
This commit is contained in:
Max New 2013-09-13 01:11:18 -07:00
parent 3899da968d
commit 1574d5c9c6
4 changed files with 152 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
pkgs/redex-pkgs/redex-lib/redex/private/enum.rkt
View File

@ -362,7 +362,7 @@
[`any [`any
(sum/e (sum/e
any/e any/e
(listof/e any/e))] (many/e any/e))]
[`number num/e] [`number num/e]
[`string string/e] [`string string/e]
[`natural natural/e] [`natural natural/e]
@ -416,11 +416,13 @@
(λ (rep) (λ (rep)
(cons (repeat-n rep) (cons (repeat-n rep)
(repeat-terms rep))) (repeat-terms rep)))
(dep/e (sum/e
nats (const/e (cons 0 '()))
(λ (n) (dep/e
(list/e (nats+/e 1)
(build-list n (const (loop pat)))))))] (λ (n)
(list/e
(build-list n (const (loop pat))))))))]
[`(repeat ,pat ,name #f) [`(repeat ,pat ,name #f)
(error 'unimplemented "named-repeat")] (error 'unimplemented "named-repeat")]
[`(repeat ,pat #f ,mismatch) [`(repeat ,pat #f ,mismatch)
@ -459,7 +461,7 @@
(map/e (map/e
list->string list->string
string->list string->list
(listof/e char/e))) (many/e char/e)))
(define integer/e (define integer/e
#; ;; Simple "turn down the volume" list #; ;; Simple "turn down the volume" list
@ -479,16 +481,10 @@
(from-list/e '(#t #f))) (from-list/e '(#t #f)))
(define var/e (define var/e
#; ;; "turn down the volume" variables
(from-list/e '(x y z))
(map/e (map/e
(compose string->symbol list->string list) (compose string->symbol list->string)
(λ (sym) (compose string->list symbol->string)
(let ([chars (string->list (symbol->string sym))]) (many1/e char/e)))
(match chars
[`(,c) c]
[_ (error "not an enumerated variable name")])))
char/e))
(define any/e (define any/e
(sum/e num/e (sum/e num/e

206
pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt
View File

@ -15,13 +15,16 @@
sum/e sum/e
prod/e prod/e
dep/e dep/e
dep2/e ;; doesn't require size dep2/e ;; requires size (eventually should replace dep/e with this)
map/e map/e
filter/e ;; very bad, only use for small enums filter/e ;; very bad, only use for small enums
except/e except/e
thunk/e thunk/e
listof/e many/e
many1/e
list/e list/e
traverse/e
fail/e fail/e
to-list to-list
@ -160,6 +163,7 @@
;; from-list/e :: Listof a -> Gen a ;; from-list/e :: Listof a -> Gen a
;; input list should not contain duplicates ;; input list should not contain duplicates
;; equality on eq?
(define (from-list/e l) (define (from-list/e l)
(if (empty? l) (if (empty? l)
empty/e empty/e
@ -337,6 +341,8 @@
(define (traverse/e f xs) (define (traverse/e f xs)
(list/e (map f xs))) (list/e (map f xs)))
;; sequence/e : listof (enum a) -> enum (listof a)
;; the nth triangle number ;; the nth triangle number
(define (tri n) (define (tri n)
(/ (* n (+ n 1)) (/ (* n (+ n 1))
@ -478,73 +484,106 @@
#f] #f]
[else (bin-search 0 (- size 1))]))) [else (bin-search 0 (- size 1))])))
;; dep2 : enum a (a -> enum b) -> enum (a,b) ;; dep2 : natural (enum a) (a -> enum b) -> enum (a,b)
(define (dep2/e e f) (define (dep2/e n e f)
(cond [(= 0 (size e)) empty/e] (define (search-size sizes n)
[(not (infinite? (size (f (decode e 0))))) (define (loop cur)
;; memoize tab : boxof (hash nat -o> (nat . nat)) (let* ([lastSize (gvector-ref sizes (- cur 1))]
;; maps an index into the dep/e to the 2 indices that we need [e2 (f (decode e cur))]
(let ([tab (box (hash))]) [s (+ lastSize (size e2))])
(enum (if (infinite? (size e)) (gvector-add! sizes s)
+inf.f (if (> s n)
(foldl + 0 (map (compose size f) (to-list e)))) cur
(λ (n) ;; n -> axb (loop (+ cur 1)))))
(call-with-values (loop (gvector-count sizes)))
(λ () ;; fill-table - find sizes[n], filling the table as it goes
(letrec ;; assumption: n >= (gvector-count sizes)
;; go : nat -> nat nat (define (fill-table sizes n)
([go (let loop ([cur (gvector-count sizes)])
(λ (n) (let* ([prevSize (gvector-ref sizes (- cur 1))]
(cond [(hash-has-key? (unbox tab) n) [curE (f (decode e cur))]
(let ([ij (hash-ref (unbox tab) n)]) [s (+ prevSize (size curE))])
(values (car ij) (cdr ij)))] (gvector-add! sizes s)
[(= n 0) ;; find the first element (if (= cur n)
(find 0 0 0)] s
[else ;; recur (loop (+ cur 1))))))
(call-with-values (if (= 0 (size e))
(λ () (go (- n 1))) empty/e
(λ (ai bi) (cond
(find ai (- n bi 1) n)))]))] [(not (infinite? n))
;; find : nat nat nat -> nat ;; memo table caches the size of the dependent enumerators
[find ;; sizes[n] = # of terms with left side index <= n
;; start is our starting eindex ;; sizes : gvector int
;; seen is how many we've already seen (let* ([first (size (f (decode e 0)))]
(λ (start seen n) [sizes (gvector first)])
(let loop ([ai start] (enum (if (infinite? (size e))
[seen seen]) +inf.f
(let* ([a (decode e ai)] (foldl
[bs (f a)]) (λ (curSize acc)
(cond [(< (- n seen) (let ([sum (+ curSize acc)])
(size bs)) (gvector-add! sizes sum)
(let ([bi (- n seen)]) sum))
(begin first (map (compose size f) (cdr (to-list e)))))
(set-box! tab (λ (n)
(hash-set (unbox tab) (let* ([ind (or (find-size sizes n)
n (search-size sizes n))]
(cons ai bi))) [l (if (= ind 0)
(values ai bi)))] 0
[else (gvector-ref sizes (- ind 1)))]
(loop (+ ai 1) [m (- n l)]
(+ seen (size bs)))]))))]) [x (decode e ind)]
(go n))) [e2 (f x)]
(λ (ai bi) [y (decode e2 m)])
(let ([a (decode e ai)]) (cons x y)))
(cons a (λ (ab)
(decode (f a) bi)))))) (let* ([a (car ab)]
;; todo: memoize encode [b (cdr ab)]
(λ (ab) ;; axb -> n [ai (encode e a)]
(let ([ai (encode e (car ab))]) [ei (f a)]
(+ (let loop ([i 0] [nextSize (size ei)]
[sum 0]) [sizeUpTo (if (= ai 0)
(if (>= i ai) 0
sum (or (gvector-ref sizes (- ai 1) #f)
(loop (+ i 1) (let ([sizeUp
(+ sum (fill-table sizes (- ai 1))])
(size (f (decode e i))))))) (begin0
(encode (f (car ab)) sizeUp
(cdr ab)))))))] (gvector-add! sizes
[else ;; both infinite, same as prod/e (+ nextSize
(dep/e e f)])) sizeUp))))))])
(+ sizeUpTo
(encode ei b))))))]
[(not (infinite? (size e)))
(enum +inf.f
(λ (n)
(call-with-values
(λ ()
(quotient/remainder n (size e)))
(λ (q r)
(cons (decode e r)
(decode (f (decode e r)) q)))))
(λ (ab)
(+ (* (size e) (encode (f (car ab)) (cdr ab)))
(encode e (car ab)))))]
[else ;; both infinite, same as prod/e
(enum +inf.f
(λ (n)
(let* ([k (floor-untri n)]
[t (tri k)]
[l (- n t)]
[m (- k l)]
[a (decode e l)])
(cons a
(decode (f a) m))))
(λ (xs) ;; bijection from nxn -> n, inverse of previous
;; (n,m) -> (n+m)(n+m+1)/2 + n
(unless (pair? xs)
(error "not a pair"))
(let ([l (encode e (car xs))]
[m (encode (f (car xs)) (cdr xs))])
(+ (/ (* (+ l m) (+ l m 1))
2)
l))))])))
;; fold-enum : ((listof a), b -> enum a), (listof b) -> enum (listof a) ;; fold-enum : ((listof a), b -> enum a), (listof b) -> enum (listof a)
(define (fold-enum f l) (define (fold-enum f l)
@ -606,16 +645,25 @@
(λ (x) (λ (x)
(encode (thunk) x)))) (encode (thunk) x))))
;; listof/e : enum a -> enum (listof a) ;; many/e : enum a -> enum (listof a)
(define (listof/e e) ;; or : enum a, #:length natural -> enum (listof a)
(thunk/e (define many/e
(if (= 0 (size e)) (case-lambda
0 [(e)
+inf.f) (thunk/e
(λ () (if (= 0 (size e))
(sum/e 0
(const/e '()) +inf.f)
(prod/e e (listof/e e)))))) (λ ()
(sum/e
(const/e '())
(prod/e e (many/e e)))))]
[(e n)
(list/e (build-list n (const e)))]))
;; many1/e : enum a -> enum (nonempty listof a)
(define (many1/e e)
(prod/e e (many/e e)))
;; list/e : listof (enum any) -> enum (listof any) ;; list/e : listof (enum any) -> enum (listof any)
(define (list/e es) (define (list/e es)

5
pkgs/redex-pkgs/redex-test/redex/tests/enum-examples.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require rackunit (require rackunit
redex) redex)
(define-language Base (define-language Base
(x a b c) (x a b c)
(y d e f)) (y d e f))
@ -172,9 +173,9 @@
;; you also must enumerate all variables that are at that ;; you also must enumerate all variables that are at that
;; depth, in this way named vals and named repeats are similar ;; depth, in this way named vals and named repeats are similar
(dep/e (vals/e ((iterate 1 (curry listof/e (dep/e (vals/e ((iterate 1 (curry many/e
len2)) nats) len2)) nats)
((iterate 1 (curry listof/e ((iterate 1 (curry many/e
len2)) (enum y))) len2)) (enum y)))
(λ (len1s ys) (λ (len1s ys)
(dep/e (dep/e

10
pkgs/redex-pkgs/redex-test/redex/tests/enum-test.rkt
View File

@ -33,6 +33,16 @@
(try-it 250 Λc e) (try-it 250 Λc e)
(try-it 24 Λc x) (try-it 24 Λc x)
;; De Bruijn for performance comparison
(define-language DBλc
(e (e e)
(λ e)
x)
(x natural))
(try-it 500 DBλc e)
;; Name test ;; Name test
(define-language Named (define-language Named
(n (number_1 number_1))) (n (number_1 number_1)))