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

Have cons/e use list/e and make explicit when using finite cons/e

Browse Source 
Also add to-stream and make cons/e tests less specific
This commit is contained in:
Max New 2014-04-13 17:46:59 -05:00 committed by Robby Findler
parent f309685999
commit 7032acc066
2 changed files with 178 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,6 +6,7 @@
racket/math racket/math
racket/match racket/match
racket/promise racket/promise
racket/stream
racket/vector racket/vector
data/gvector data/gvector
@ -55,6 +56,7 @@
approximate approximate
to-list to-list
to-stream
take/e take/e
fold-enum fold-enum
@ -148,6 +150,15 @@
e e
excepts)) excepts))
(define (to-stream e)
(define (loop n)
(cond [(n . >= . (size e))
empty-stream]
[else
(stream-cons (decode e n)
(loop (add1 n)))]))
(loop 0))
(define (approximate e n) (define (approximate e n)
(for/list ([i (in-range n)]) (for/list ([i (in-range n)])
(decode e i))) (decode e i)))
@ -241,6 +252,11 @@
y)) y))
(foldl exact-min-2 +inf.0 xs)) (foldl exact-min-2 +inf.0 xs))
(struct fin-layer
(bound ;; nat
enums) ;; Vectorof (Enum a, list-index)
#:transparent)
(struct upper-bound (struct upper-bound
(total-bound ;; Nat (total-bound ;; Nat
individual-bound ;; Nat individual-bound ;; Nat
@ -248,8 +264,19 @@
) )
#:transparent) #:transparent)
;; layers : Listof Enum -> Listof Upper-Bound ; scanl :: (a -> b -> b) -> b -> [a] -> [b]
(define (mk-layers es) (define (scanl f base xs)
(let loop ([cur base]
[xs xs]
[acc '()])
(match xs
['() (cons base (reverse acc))]
[(cons x xs)
(define step (f x cur))
(loop step xs (cons step acc))])))
(define/contract (mk-fin-layers es)
((listof enum?) . -> . (listof fin-layer?))
(define (loop eis prev) (define (loop eis prev)
(define non-emptys (filter (negate (compose empty/e? car)) eis)) (define non-emptys (filter (negate (compose empty/e? car)) eis))
(match non-emptys (match non-emptys
@ -263,18 +290,7 @@
(filter not-min-size? non-emptys)) (filter not-min-size? non-emptys))
(define veis (define veis
(apply vector non-emptys)) (apply vector non-emptys))
(match-define (upper-bound prev-tb (define cur-layer (fin-layer min-size veis))
prev-ib
prev-es)
prev)
(define diff-min-size
(min-size . - . prev-ib))
(define total-bound
(prev-tb . + . (diff-min-size . * . (vector-length veis))))
(define cur-layer
(upper-bound total-bound
min-size
veis))
(define remaining-layers (define remaining-layers
(loop leftover cur-layer)) (loop leftover cur-layer))
(cons cur-layer (cons cur-layer
@ -283,9 +299,40 @@
(for/list [(i (in-naturals)) (for/list [(i (in-naturals))
(e (in-list es))] (e (in-list es))]
(cons e i))) (cons e i)))
(apply vector (loop eis (fin-layer 0 eis)))
(loop eis
(upper-bound 0 0 eis)))) ;; layers : Listof Enum -> Listof Upper-Bound
(define/contract (disj-sum-layers es)
((listof enum?) . -> . (vectorof upper-bound?))
(define fin-layers (mk-fin-layers es))
(define/contract (loop fin-layers prev)
(-> (listof fin-layer?)
upper-bound?
(listof upper-bound?))
(match fin-layers
['() '()]
[(cons (fin-layer cur-bound eis) rest-fin-layers)
(match-define (upper-bound prev-tb
prev-ib
_)
prev)
(define min-size cur-bound)
(define diff-min-size
(min-size . - . prev-ib))
(define total-bound
(prev-tb . + . (diff-min-size . * . (vector-length eis))))
(define cur-layer
(upper-bound total-bound
cur-bound
eis))
(define rest-layers (loop rest-fin-layers cur-layer))
(cons cur-layer
rest-layers)]))
(define eis
(for/list [(i (in-naturals))
(e (in-list es))]
(cons e i)))
(apply vector (loop fin-layers (upper-bound 0 0 eis))))
;; find-layer : Nat, Nonempty-Listof Upper-bound -> Upper-bound, Upper-bound ;; find-layer : Nat, Nonempty-Listof Upper-bound -> Upper-bound, Upper-bound
;; Given an index, find the first layer ;; Given an index, find the first layer
@ -347,7 +394,7 @@
;; fairly interleave a list of enumerations ;; fairly interleave a list of enumerations
(define (disj-sum/e . e-ps) (define (disj-sum/e . e-ps)
(define layers (define layers
(mk-layers (map car e-ps))) (disj-sum-layers (map car e-ps)))
(define (empty-e-p? e-p) (define (empty-e-p? e-p)
(= 0 (size (car e-p)))) (= 0 (size (car e-p))))
(match (filter (negate empty-e-p?) e-ps) (match (filter (negate empty-e-p?) e-ps)
@ -357,7 +404,7 @@
(define (dec i) (define (dec i)
(define-values (prev-up-bound cur-up-bound) (define-values (prev-up-bound cur-up-bound)
(find-dec-layer i layers)) (find-dec-layer i layers))
(match-define (upper-bound so-far prev-ib es1) prev-up-bound) (match-define (upper-bound so-far prev-ib _) prev-up-bound)
(match-define (upper-bound ctb cib es) cur-up-bound) (match-define (upper-bound ctb cib es) cur-up-bound)
(define this-i (i . - . so-far)) (define this-i (i . - . so-far))
(define len (vector-length es)) (define len (vector-length es))
@ -410,9 +457,7 @@
[(cons x '()) x] [(cons x '()) x]
[(cons x xs) (f x (foldr1 f xs))])) [(cons x xs) (f x (foldr1 f xs))]))
;; cons/e : enum a, enum b ... -> enum (cons a b ...) (define (fin-cons/e e1 e2)
(define (cons/e e . es)
(define (cons/e2 e1 e2)
(define s1 (enum-size e1)) (define s1 (enum-size e1))
(define s2 (enum-size e2)) (define s2 (enum-size e2))
(define size (* s1 s2)) (define size (* s1 s2))
@ -426,38 +471,34 @@
(define (dec n) (define (dec n)
(define-values (q r) (define-values (q r)
(quotient/remainder n fin-size)) (quotient/remainder n fin-size))
(define x1 (decode e1 (if fst-finite? r q))) (define-values (n1 n2)
(define x2 (decode e2 (if fst-finite? q r))) (if fst-finite?
(cons x1 x2)) (values r q)
(values q r)))
(cons (decode e1 n1)
(decode e2 n2)))
(define/match (enc p) (define/match (enc p)
[((cons x1 x2)) [((cons x1 x2))
(define n1 (encode e1 x1)) (define n1 (encode e1 x1))
(define n2 (encode e2 x2)) (define n2 (encode e2 x2))
(define q (if fst-finite? n2 n1)) (define-values (q r)
(define r (if fst-finite? n1 n2)) (if fst-finite?
(values n2 n1)
(values n1 n2)))
(+ (* fin-size q) (+ (* fin-size q)
r)]) r)])
(enum size dec enc)] (enum size dec enc)]
[else [else
;; based on http://en.wikipedia.org/wiki/Pairing_function (redex-error 'internal "fin-cons/e should only be called on finite enumerations")]))
(define (dec n)
(define k (floor-untri n)) ;; cons/e : enum a, enum b ... -> enum (cons a b ...)
(define t (tri k)) (define (cons/e e1 e2)
(define l (- n t)) (map/e (λ (x)
(define m (- k l)) (cons (first x)
(define x1 (decode e1 l)) (second x)))
(define x2 (decode e2 m)) (λ (x-y)
(cons x1 x2)) (list (car x-y) (cdr x-y)))
(define/match (enc p) (list/e e1 e2)))
[((cons x1 x2))
(define l (encode e1 x1))
(define m (encode e2 x2))
(+ (/ (* (+ l m)
(+ l m 1))
2)
l)])
(enum size dec enc)]))
(foldr1 cons/e2 (cons e es)))
(define (elegant-cons/e e1 e2) (define (elegant-cons/e e1 e2)
(define s1 (size e1)) (define s1 (size e1))
@ -504,7 +545,8 @@
;; on-cdr : (cons k a) -> enum (cons k b) ;; on-cdr : (cons k a) -> enum (cons k b)
(define/match (on-cdr pr) (define/match (on-cdr pr)
[((cons k v)) [((cons k v))
(cons/e (const/e k) (map/e (λ (x) (cons k x))
cdr
(f v))]) (f v))])
;; enum (listof (cons k b)) ;; enum (listof (cons k b))
(define assoc/e (define assoc/e
@ -833,7 +875,7 @@
+inf.0)) +inf.0))
(fix/e fix-size (fix/e fix-size
(λ (self) (λ (self)
(disj-sum/e (cons (const/e '()) null?) (disj-sum/e (cons (fin/e '()) null?)
(cons (cons/e e self) pair?))))] (cons (cons/e e self) pair?))))]
[(e n) [(e n)
(apply list/e (build-list n (const e)))])) (apply list/e (build-list n (const e)))]))
@ -977,6 +1019,7 @@
rest rest
(cons (car fins) acc))])]))]) (cons (car fins) acc))])]))])
(define (deconstruct xs) (define (deconstruct xs)
(let loop ([xs xs] (let loop ([xs xs]
[inf-acc '()] [inf-acc '()]
[fin-acc '()] [fin-acc '()]
@ -997,7 +1040,7 @@
rest-inf?s)])]))) rest-inf?s)])])))
(map/e reconstruct (map/e reconstruct
deconstruct deconstruct
(cons/e (apply list/e inf-es) (fin-cons/e (apply list/e inf-es)
(apply list/e fin-es)))])) (apply list/e fin-es)))]))
(define (nested-cons-list/e . es) (define (nested-cons-list/e . es)
@ -1009,7 +1052,7 @@
(λ (lst) (λ (lst)
(define-values (left right) (split-at lst split-point)) (define-values (left right) (split-at lst split-point))
(cons left right)) (cons left right))
(cons/e (apply list/e left) (apply list/e right)))) (fin-cons/e (apply list/e left) (apply list/e right))))
(define (all-infinite? es) (define (all-infinite? es)
@ -1078,7 +1121,7 @@
(define first-not-max/e (define first-not-max/e
(match bound (match bound
[0 empty/e] [0 empty/e]
[_ (cons/e (take/e nat/e bound) [_ (fin-cons/e (take/e nat/e bound)
smallers/e)])) smallers/e)]))
(define (first-max? l) (define (first-max? l)
((first l) . = . bound)) ((first l) . = . bound))

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

@ -5,10 +5,6 @@
redex/private/enumerator redex/private/enumerator
(submod redex/private/enumerator test)) (submod redex/private/enumerator test))
;; basic enums
(define bools/e
(from-list/e (list #t #f)))
;; const/e tests ;; const/e tests
(let ([e (const/e 17)]) (let ([e (const/e 17)])
(test-begin (test-begin
@ -83,14 +79,14 @@
(test-begin (test-begin
(define bool-or-num (define bool-or-num
(disj-sum/e (cons bools/e boolean?) (disj-sum/e (cons bool/e boolean?)
(cons (from-list/e '(0 1 2 3)) number?))) (cons (from-list/e '(0 1 2 3)) number?)))
(define bool-or-nat (define bool-or-nat
(disj-sum/e (cons bools/e boolean?) (disj-sum/e (cons bool/e boolean?)
(cons nat/e number?))) (cons nat/e number?)))
(define nat-or-bool (define nat-or-bool
(disj-sum/e (cons nat/e number?) (disj-sum/e (cons nat/e number?)
(cons bools/e boolean?))) (cons bool/e boolean?)))
(define odd-or-even (define odd-or-even
(disj-sum/e (cons evens/e even?) (disj-sum/e (cons evens/e even?)
(cons odds/e odd?))) (cons odds/e odd?)))
@ -161,10 +157,10 @@
(test-begin (test-begin
(define bool-or-num (define bool-or-num
(disj-append/e (cons bools/e boolean?) (disj-append/e (cons bool/e boolean?)
(cons (from-list/e '(0 1 2 3)) number?))) (cons (from-list/e '(0 1 2 3)) number?)))
(define bool-or-nat (define bool-or-nat
(disj-append/e (cons bools/e boolean?) (disj-append/e (cons bool/e boolean?)
(cons nat/e number?))) (cons nat/e number?)))
(check-equal? (size bool-or-num) 6) (check-equal? (size bool-or-num) 6)
@ -188,11 +184,11 @@
(check-bijection? bool-or-nat)) (check-bijection? bool-or-nat))
;; cons/e tests ;; cons/e tests
(define bool*bool (cons/e bools/e bools/e)) (define bool*bool (cons/e bool/e bool/e))
(define 1*b (cons/e (const/e 1) bools/e)) (define 1*b (cons/e (const/e 1) bool/e))
(define b*1 (cons/e bools/e (const/e 1))) (define b*1 (cons/e bool/e (const/e 1)))
(define bool*nats (cons/e bools/e nat/e)) (define bool*nats (cons/e bool/e nat/e))
(define nats*bool (cons/e nat/e bools/e)) (define nats*bool (cons/e nat/e bool/e))
(define nats*nats (cons/e nat/e nat/e)) (define nats*nats (cons/e nat/e nat/e))
(define ns-equal? (λ (ns ms) (define ns-equal? (λ (ns ms)
(and (= (car ns) (and (= (car ns)
@ -211,55 +207,17 @@
(check-bijection? 1*b) (check-bijection? 1*b)
(check-bijection? b*1) (check-bijection? b*1)
(check-equal? (size bool*bool) 4) (check-equal? (size bool*bool) 4)
(check-equal? (decode bool*bool 0)
(cons #t #t))
(check-equal? (decode bool*bool 1)
(cons #f #t))
(check-equal? (decode bool*bool 2)
(cons #t #f))
(check-equal? (decode bool*bool 3)
(cons #f #f))
(check-bijection? bool*bool) (check-bijection? bool*bool)
(check-equal? (size bool*nats) +inf.0) (check-equal? (size bool*nats) +inf.0)
(check-equal? (decode bool*nats 0)
(cons #t 0))
(check-equal? (decode bool*nats 1)
(cons #f 0))
(check-equal? (decode bool*nats 2)
(cons #t 1))
(check-equal? (decode bool*nats 3)
(cons #f 1))
(check-bijection? bool*nats) (check-bijection? bool*nats)
(check-equal? (size nats*bool) +inf.0) (check-equal? (size nats*bool) +inf.0)
(check-equal? (decode nats*bool 0)
(cons 0 #t))
(check-equal? (decode nats*bool 1)
(cons 0 #f))
(check-equal? (decode nats*bool 2)
(cons 1 #t))
(check-equal? (decode nats*bool 3)
(cons 1 #f))
(check-bijection? nats*bool) (check-bijection? nats*bool)
(check-equal? (size nats*nats) +inf.0) (check-bijection? nats*nats)
(check ns-equal? (check-bijection? (list/e integer/e integer/e)))
(decode nats*nats 0)
(cons 0 0))
(check ns-equal?
(decode nats*nats 1)
(cons 0 1))
(check ns-equal?
(decode nats*nats 2)
(cons 1 0))
(check ns-equal?
(decode nats*nats 3)
(cons 0 2))
(check ns-equal?
(decode nats*nats 4)
(cons 1 1))
(check-bijection? nats*nats))
;; fair product tests ;; fair product tests
(define-simple-check (check-range? e l u approx) (define-simple-check (check-range? e l u approx)
@ -323,9 +281,55 @@
(check-equal? (list->inc-set '(2 0 1 2)) '(2 3 5 8)) (check-equal? (list->inc-set '(2 0 1 2)) '(2 3 5 8))
(check-equal? (inc-set->list '(2 3 5 8)) '(2 0 1 2))) (check-equal? (inc-set->list '(2 3 5 8)) '(2 0 1 2)))
(define (below/e n)
(take/e nat/e n))
;; mixed finite/infinite list/e tests ;; mixed finite/infinite list/e tests
(test-begin (test-begin
(check-equal?
(to-list (list/e (below/e 3) (below/e 3) (below/e 3)))
(to-list (take/e (list/e nat/e nat/e nat/e) 27)))
(define n*2 (list/e nat/e (below/e 2)))
(check-range? n*2 0 1 '((0 0)))
(check-range? n*2 1 3 '((0 1) (1 0) (1 1)))
(check-range? n*2 3 5 '((2 0) (2 1)))
(check-range? n*2 5 7 '((3 0) (3 1)))
(define n*1*2 (list/e nat/e (below/e 1) (below/e 2)))
(check-range? n*1*2 0 1 '((0 0 0)))
(check-range? n*1*2 1 4 '((0 0 1) (1 0 0) (1 0 1)))
(check-range? n*1*2 4 6 '((2 0 0) (2 0 1)))
(check-range? n*1*2 4 6 '((3 0 0) (3 0 1)))
(define n*2*4 (list/e nat/e (below/e 2) (below/e 4)))
(check-range? n*2*4 0 1 '((0 0 0)))
(check-range? n*2*4 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*2*4 8 18 ;; (8 previous . + . (2 magnitude of exhausted enums
;; . * . (9 3^(number left) . - . 4 2^(number left)))
'((0 0 2) (0 1 2)
(1 0 2) (1 1 2)
(2 0 0) (2 1 0)
(2 0 1) (2 1 1)
(2 0 2) (2 1 2)))
(check-range? n*2*4 18 32 ;; 18 + (2 * (4^2 - 3^2))
'((0 0 3) (0 1 3)
(1 0 3) (1 1 3)
(2 0 3) (2 1 3)
(3 0 0) (3 1 0)
(3 0 1) (3 1 1)
(3 0 2) (3 1 2)
(3 0 3) (3 1 3)))
(check-range? n*2*4 32 38
'((4 0 0) (4 0 1) (4 0 2) (4 0 3)
(4 1 0) (4 1 1) (4 1 2) (4 1 3)))
(check-range? n*2*4 38 46
'((5 0 0) (5 0 1) (5 0 2) (5 0 3)
(5 1 0) (5 1 1) (5 1 2) (5 1 3)))
(check-bijection? (list/e bool/e (cons/e bool/e bool/e) (fin/e 'foo 'bar 'baz))) (check-bijection? (list/e bool/e (cons/e bool/e bool/e) (fin/e 'foo 'bar 'baz)))
(check-bijection? (list/e nat/e string/e (many/e bool/e))) (check-bijection? (list/e nat/e string/e (many/e bool/e)))
(check-bijection? (list/e bool/e nat/e int/e string/e (cons/e bool/e bool/e)))) (check-bijection? (list/e bool/e nat/e int/e string/e (cons/e bool/e bool/e))))
@ -344,8 +348,7 @@
;; dep/e tests ;; dep/e tests
(define (up-to n) (define (up-to n)
(take/e nat/e (+ n 1))) (below/e (add1 n)))
(define 3-up (define 3-up
(dep/e (dep/e
(from-list/e '(0 1 2)) (from-list/e '(0 1 2))