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

Implement fast fair boxy list/e

Browse Source
This commit is contained in:
Max New 2014-04-05 21:13:46 -05:00 committed by Robby Findler
parent 11bf21420c
commit 6c618efddd
2 changed files with 81 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -11,7 +11,9 @@
data/gvector
math/flonum
(only-in math/number-theory binomial)
(only-in math/number-theory
binomial
integer-root)
"error.rkt")
@ -939,7 +941,8 @@
;; ordering is monotonic in the sum of the elements of the list
(define (cantor-list/e . es)
(define all-inf? (all-infinite? es))
(cond [(not all-inf?)
(cond [(empty? es) (const/e '())]
[(not all-inf?)
;; TODO: improve mixed finite/infinite
(list/e es)]
[else
@ -958,20 +961,60 @@
;; ordering is monotonic in the max of the elements of the list
(define (box-list/e . es)
(define all-inf? (all-infinite? es))
(cond [(not all-inf?) (list/e es)]
(cond [(empty? es) (const/e '())]
[(not all-inf?) (list/e es)]
[else
(define k (length es))
(define dec (box-untuple k))
(define enc (box-tuple k))
(define dec
(compose
(λ (xs) (map decode es xs))
(box-untuple k)))
(define enc
(compose
(box-tuple k)
(λ (xs) (map encode es xs))))
(enum +inf.0 dec enc)]))
(define (box-untuple k)
(λ (xs)
(error 'unimpl)))
;; Tuples of length k with maximum bound
(define (bounded-list/e len bound)
(define (loop len)
(match len
[0 (const/e '())]
[1 (const/e `(,bound))]
[_
(define smallers/e (loop (sub1 len)))
(define bounded/e (take/e nats/e (add1 bound)))
(define first-max/e
(map/e
(curry cons bound)
cdr
(list/e
(for/list ([_ (in-range (sub1 len))])
bounded/e))))
(define first-not-max/e
(match bound
[0 empty/e]
[_ (cons/e (take/e nats/e bound)
smallers/e)]))
(define (first-max? l)
((first l) . = . bound))
(disj-append/e (cons first-not-max/e (negate first-max?))
(cons first-max/e first-max?))]))
(loop len))
(define (box-tuple k)
(λ (xs)
(define layer (apply max xs))
(define smallest (expt layer k))
(define layer/e (bounded-list/e k layer))
(smallest . + . (encode layer/e xs))))
(define (box-untuple k)
(λ (n)
(error 'unimpl)))
(define layer (integer-root n k))
(define smallest (expt layer k))
(define layer/e (bounded-list/e k layer))
(decode layer/e (n . - . smallest))))
(define (nats+/e n)
(map/e (λ (k)

31
pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt
View File

@ -288,7 +288,35 @@
(test-begin
(check-bijection? (cantor-vec/e string/e nats/e real/e))
(check-bijection? (cantor-list/e string/e nats/e real/e)))
(check-bijection? (cantor-list/e string/e nats/e real/e))
(check-bijection? (cantor-list/e)))
(test-begin
(define n*n (box-list/e nats/e nats/e))
(check-range? n*n 0 1 '((0 0)))
(check-range? n*n 1 4 '((0 1) (1 0) (1 1)))
(check-range? n*n 4 9 '((0 2) (1 2) (2 1) (2 0) (2 2))))
(test-begin
(define n*n*n (box-list/e nats/e nats/e nats/e))
(check-range? n*n*n 0 1 '((0 0 0)))
(check-range? n*n*n 1 8 '((0 0 1) (0 1 1) (0 1 0)
(1 0 0) (1 0 1) (1 1 0) (1 1 1)))
(check-range? n*n*n 8 27 '((0 0 2) (0 1 2) (0 2 2)
(0 2 0) (0 2 1)
(1 0 2) (1 1 2) (1 2 2)
(1 2 0) (1 2 1)
(2 0 0) (2 0 1) (2 0 2)
(2 1 0) (2 1 1) (2 1 2)
(2 2 0) (2 2 1) (2 2 2))))
(test-begin
(check-bijection? (box-vec/e string/e nats/e real/e))
(check-bijection? (box-list/e string/e nats/e real/e))
(check-bijection? (box-list/e)))
;; helper
(test-begin
@ -459,4 +487,3 @@
(many/e empty/e))
(check-equal? (decode emptys/e 0) '())
(check-bijection? emptys/e)