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

Simplify Redex enumeration combinator names.

Browse Source
This commit is contained in:
Max New 2013-09-05 22:46:31 -07:00
parent e40a601721
commit c9a7b9bd52
2 changed files with 178 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -41,7 +41,7 @@
(λ (nt) (λ (nt)
(hash-set! l-enums (hash-set! l-enums
(nt-name nt) (nt-name nt)
(with-handlers ([exn:fail? fail/enum]) (with-handlers ([exn:fail? fail/e])
(enum-f (nt-rhs nt) (enum-f (nt-rhs nt)
l-enums)))) l-enums))))
cur-lang)) cur-lang))
@ -53,29 +53,29 @@
enumerate-rhss) enumerate-rhss)
(enumerate-lang rec-lang (enumerate-lang rec-lang
(λ (rhs enums) (λ (rhs enums)
(thunk/enum +inf.f (thunk/e +inf.f
(λ () (λ ()
(enumerate-rhss rhs enums))))) (enumerate-rhss rhs enums)))))
(lang-enum l-enums))) (lang-enum l-enums)))
(define (pat-enumerator l-enum pat) (define (pat-enumerator l-enum pat)
(map/enum (map/e
to-term to-term
(λ (_) (λ (_)
(error 'pat-enum "Enumerator is not a bijection")) (error 'pat-enum "Enumerator is not a bijection"))
(pat/enum pat (pat/e pat
(lang-enum-enums l-enum)))) (lang-enum-enums l-enum))))
(define (enumerate-rhss rhss l-enums) (define (enumerate-rhss rhss l-enums)
(apply sum/enum (apply sum/e
(map (map
(λ (rhs) (λ (rhs)
(pat/enum (rhs-pattern rhs) (pat/e (rhs-pattern rhs)
l-enums)) l-enums))
rhss))) rhss)))
(define (pat/enum pat l-enums) (define (pat/e pat l-enums)
(enum-names pat (enum-names pat
(sep-names pat) (sep-names pat)
l-enums)) l-enums))
@ -282,13 +282,13 @@
(let rec ([nps nps] (let rec ([nps nps]
[env (hash)]) [env (hash)])
(cond [(empty-named-pats? nps) (cond [(empty-named-pats? nps)
(pat/enum-with-names pat nt-enums env)] (pat/e-with-names pat nt-enums env)]
[else [else
(let ([cur (next-named-pats nps)]) (let ([cur (next-named-pats nps)])
(cond [(named? cur) (cond [(named? cur)
(let ([name (named-name cur)] (let ([name (named-name cur)]
[pat (named-val cur)]) [pat (named-val cur)])
(map/enum (map/e
(λ (ts) (λ (ts)
(named name (named name
(named-t (car ts) (named-t (car ts)
@ -303,8 +303,8 @@
"expected ~a, got ~a" "expected ~a, got ~a"
name name
(named-name n)))) (named-name n))))
(dep/enum (dep/e
(pat/enum-with-names pat nt-enums env) (pat/e-with-names pat nt-enums env)
(λ (term) (λ (term)
(rec (rest-named-pats nps) (rec (rest-named-pats nps)
(hash-set env (hash-set env
@ -312,7 +312,7 @@
term))))))] term))))))]
[(mismatch? cur) [(mismatch? cur)
(let ([name (mismatch-name cur)]) (let ([name (mismatch-name cur)])
(map/enum (map/e
(λ (ts) (λ (ts)
(mismatch name (mismatch name
(mismatch-t (car ts) (mismatch-t (car ts)
@ -327,11 +327,11 @@
"expected ~a, got ~a" "expected ~a, got ~a"
name name
(named-name n)))) (named-name n))))
(dep/enum (dep/e
(fold-enum (fold-enum
(λ (excepts pat) (λ (excepts pat)
(except/enum (except/e
(pat/enum-with-names pat (pat/e-with-names pat
nt-enums nt-enums
(hash-set env (hash-set env
(mismatch-name cur) (mismatch-name cur)
@ -345,45 +345,45 @@
terms))))))] terms))))))]
[else (error 'unexpected "expected name, mismatch or unimplemented, got: ~a in ~a" cur nps)]))]))) [else (error 'unexpected "expected name, mismatch or unimplemented, got: ~a in ~a" cur nps)]))])))
(define (pat/enum-with-names pat nt-enums named-terms) (define (pat/e-with-names pat nt-enums named-terms)
(let loop ([pat pat]) (let loop ([pat pat])
(match-a-pattern (match-a-pattern
pat pat
[`any [`any
(sum/enum (sum/e
any/enum any/e
(listof/enum any/enum))] (listof/e any/e))]
[`number num/enum] [`number num/e]
[`string string/enum] [`string string/e]
[`natural natural/enum] [`natural natural/e]
[`integer integer/enum] [`integer integer/e]
[`real real/enum] [`real real/e]
[`boolean bool/enum] [`boolean bool/e]
[`variable var/enum] [`variable var/e]
[`(variable-except ,s ...) [`(variable-except ,s ...)
(except/enum var/enum s)] (except/e var/e s)]
[`(variable-prefix ,s) [`(variable-prefix ,s)
;; todo ;; todo
(error 'unimplemented "var-prefix")] (error 'unimplemented "var-prefix")]
[`variable-not-otherwise-mentioned [`variable-not-otherwise-mentioned
(error 'unimplemented "var-not-mentioned")] ;; error (error 'unimplemented "var-not-mentioned")] ;; error
[`hole [`hole
(const/enum the-hole)] (const/e the-hole)]
[`(nt ,id) [`(nt ,id)
(hash-ref nt-enums id)] (hash-ref nt-enums id)]
[`(name ,n ,pat) [`(name ,n ,pat)
(const/enum (name-ref n))] (const/e (name-ref n))]
[`(mismatch-name ,n ,pat) [`(mismatch-name ,n ,pat)
(const/enum (mismatch-ref n))] (const/e (mismatch-ref n))]
[`(in-hole ,p1 ,p2) ;; untested [`(in-hole ,p1 ,p2) ;; untested
(map/enum (map/e
(λ (ts) (λ (ts)
(decomposition (car ts) (decomposition (car ts)
(cdr ts))) (cdr ts)))
(λ (decomp) (λ (decomp)
(cons (decomposition-ctx decomp) (cons (decomposition-ctx decomp)
(decomposition-term decomp))) (decomposition-term decomp)))
(prod/enum (prod/e
(loop p1) (loop p1)
(loop p2)))] (loop p2)))]
[`(hide-hole ,p) [`(hide-hole ,p)
@ -394,22 +394,22 @@
(unsupported pat)] (unsupported pat)]
[`(list ,sub-pats ...) [`(list ,sub-pats ...)
;; enum-list ;; enum-list
(list/enum (list/e
(map (map
(λ (sub-pat) (λ (sub-pat)
(match sub-pat (match sub-pat
[`(repeat ,pat #f #f) [`(repeat ,pat #f #f)
(map/enum (map/e
(λ (n-ts) (λ (n-ts)
(repeat (car n-ts) (repeat (car n-ts)
(cdr n-ts))) (cdr n-ts)))
(λ (rep) (λ (rep)
(cons (repeat-n rep) (cons (repeat-n rep)
(repeat-terms rep))) (repeat-terms rep)))
(dep/enum (dep/e
nats nats
(λ (n) (λ (n)
(list/enum (list/e
(build-list n (const (loop pat)))))))] (build-list n (const (loop pat)))))))]
[`(repeat ,pat ,name #f) [`(repeat ,pat ,name #f)
(error 'unimplemented "named-repeat")] (error 'unimplemented "named-repeat")]
@ -418,7 +418,7 @@
[else (loop sub-pat)])) [else (loop sub-pat)]))
sub-pats))] sub-pats))]
[(? (compose not pair?)) [(? (compose not pair?))
(const/enum pat)]))) (const/e pat)])))
(define (flatten-1 xs) (define (flatten-1 xs)
(append-map (append-map
@ -437,45 +437,45 @@
(nt-rhs (car nts))] (nt-rhs (car nts))]
[else (rec (cdr nts))]))) [else (rec (cdr nts))])))
(define natural/enum nats) (define natural/e nats)
(define char/enum (define char/e
(map/enum (map/e
integer->char integer->char
char->integer char->integer
(range/enum #x61 #x7a))) (range/e #x61 #x7a)))
(define string/enum (define string/e
(map/enum (map/e
list->string list->string
string->list string->list
(listof/enum char/enum))) (listof/e char/e)))
(define integer/enum (define integer/e
(sum/enum nats (sum/e nats
(map/enum (λ (n) (- (+ n 1))) (map/e (λ (n) (- (+ n 1)))
(λ (n) (- (- n) 1)) (λ (n) (- (- n) 1))
nats))) nats)))
(define real/enum (from-list/enum '(0.5 1.5 123.112354))) (define real/e (from-list/e '(0.5 1.5 123.112354)))
(define num/enum (define num/e
(sum/enum integer/enum (sum/e integer/e
real/enum)) real/e))
(define bool/enum (define bool/e
(from-list/enum '(#t #f))) (from-list/e '(#t #f)))
(define var/enum (define var/e
(map/enum (map/e
(compose string->symbol list->string list) (compose string->symbol list->string list)
(compose car string->list symbol->string) (compose car string->list symbol->string)
char/enum)) char/e))
(define any/enum (define any/e
(sum/enum num/enum (sum/e num/e
string/enum string/e
bool/enum bool/e
var/enum)) var/e))
(define (to-term aug) (define (to-term aug)
(cond [(named? aug) (cond [(named? aug)

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

@ -9,30 +9,30 @@
size size
encode encode
decode decode
empty/enum empty/e
const/enum const/e
from-list/enum from-list/e
sum/enum sum/e
prod/enum prod/e
dep/enum dep/e
dep2/enum ;; doesn't require size dep2/e ;; doesn't require size
map/enum map/e
filter/enum ;; very bad, only use for small enums filter/e ;; very bad, only use for small enums
except/enum except/e
thunk/enum thunk/e
listof/enum listof/e
list/enum list/e
fail/enum fail/e
to-list to-list
take/enum take/e
drop/enum drop/e
fold-enum fold-enum
display-enum display-enum
nats nats
range/enum range/e
nats+/enum nats+/e
) )
;; an enum a is a struct of < Nat or +Inf, Nat -> a, a -> Nat > ;; an enum a is a struct of < Nat or +Inf, Nat -> a, a -> Nat >
@ -56,16 +56,16 @@
((enum-to e) a)) ((enum-to e) a))
;; Helper functions ;; Helper functions
;; map/enum : (a -> b), (b -> a), enum a -> enum b ;; map/e : (a -> b), (b -> a), enum a -> enum b
(define (map/enum f inv-f e) (define (map/e f inv-f e)
(enum (size e) (enum (size e)
(compose f (enum-from e)) (compose f (enum-from e))
(compose (enum-to e) inv-f))) (compose (enum-to e) inv-f)))
;; filter/enum : enum a, (a -> bool) -> enum a ;; filter/e : enum a, (a -> bool) -> enum a
;; size won't be accurate! ;; size won't be accurate!
;; encode is not accurate right now! ;; encode is not accurate right now!
(define (filter/enum e p) (define (filter/e e p)
(enum (size e) (enum (size e)
(λ (n) (λ (n)
(let loop ([i 0] (let loop ([i 0]
@ -78,11 +78,11 @@
(loop (+ i 1) seen))))) (loop (+ i 1) seen)))))
(λ (x) (encode e x)))) (λ (x) (encode e x))))
;; except/enum : enum a, a -> enum a ;; except/e : enum a, a -> enum a
(define (except/enum e excepts) (define (except/e e excepts)
(cond [(empty? excepts) e] (cond [(empty? excepts) e]
[else [else
(except/enum (except/e
(begin (begin
(with-handlers ([exn:fail? (λ (_) e)]) (with-handlers ([exn:fail? (λ (_) e)])
(let ([m (encode e (car excepts))]) (let ([m (encode e (car excepts))])
@ -107,10 +107,10 @@
(build-list (size e) (build-list (size e)
identity))) identity)))
;; take/enum : enum a, Nat -> enum a ;; take/e : enum a, Nat -> enum a
;; returns an enum of the first n parts of e ;; returns an enum of the first n parts of e
;; n must be less than or equal to size e ;; n must be less than or equal to size e
(define (take/enum e n) (define (take/e e n)
(unless (or (infinite? (size e)) (unless (or (infinite? (size e))
(<= n (size e))) (<= n (size e)))
(error 'too-big)) (error 'too-big))
@ -125,8 +125,8 @@
(error 'out-of-range)) (error 'out-of-range))
k)))) k))))
;; drop/enum : enum a, Nat -> enum a ;; drop/e : enum a, Nat -> enum a
(define (drop/enum e n) (define (drop/e e n)
(unless (or (infinite? (size e)) (unless (or (infinite? (size e))
(<= n (size e))) (<= n (size e)))
(error 'too-big)) (error 'too-big))
@ -142,14 +142,14 @@
(display (decode e i)) (display (decode e i))
(newline) (newline))) (newline) (newline)))
(define empty/enum (define empty/e
(enum 0 (enum 0
(λ (n) (λ (n)
(error 'empty)) (error 'empty))
(λ (x) (λ (x)
(error 'empty)))) (error 'empty))))
(define (const/enum c) (define (const/e c)
(enum 1 (enum 1
(λ (n) (λ (n)
c) c)
@ -158,11 +158,11 @@
0 0
(error 'bad-val))))) (error 'bad-val)))))
;; from-list/enum :: Listof a -> Gen a ;; from-list/e :: Listof a -> Gen a
;; input list should not contain duplicates ;; input list should not contain duplicates
(define (from-list/enum l) (define (from-list/e l)
(if (empty? l) (if (empty? l)
empty/enum empty/e
(enum (length l) (enum (length l)
(λ (n) (λ (n)
(list-ref l n)) (list-ref l n))
@ -179,7 +179,7 @@
(take-while (cdr l) pred))])) (take-while (cdr l) pred))]))
(define bools (define bools
(from-list/enum (list #t #f))) (from-list/e (list #t #f)))
(define nats (define nats
(enum +inf.f (enum +inf.f
identity identity
@ -199,7 +199,7 @@
(* 2 (abs n)))))) (* 2 (abs n))))))
;; sum :: enum a, enum b -> enum (a or b) ;; sum :: enum a, enum b -> enum (a or b)
(define sum/enum (define sum/e
(case-lambda (case-lambda
[(e) e] [(e) e]
[(e1 e2) [(e1 e2)
@ -219,7 +219,7 @@
((enum-to e2) x)))]) ((enum-to e2) x)))])
((enum-to e1) x))))] ((enum-to e1) x))))]
[(not (infinite? (enum-size e2))) [(not (infinite? (enum-size e2)))
(sum/enum e2 e1)] (sum/e e2 e1)]
[else ;; both infinite, interleave them [else ;; both infinite, interleave them
(enum +inf.f (enum +inf.f
(λ (n) (λ (n)
@ -233,7 +233,7 @@
1))]) 1))])
(* ((enum-to e1) x) 2))))])] (* ((enum-to e1) x) 2))))])]
[(a b c . rest) [(a b c . rest)
(sum/enum a (apply sum/enum b c rest))])) (sum/e a (apply sum/e b c rest))]))
(define odds (define odds
(enum +inf.f (enum +inf.f
@ -275,13 +275,13 @@
l))) ;; (n,m) -> (n+m)(n+m+1)/2 + n l))) ;; (n,m) -> (n+m)(n+m+1)/2 + n
)) ))
;; prod/enum : enum a, enum b -> enum (a,b) ;; prod/e : enum a, enum b -> enum (a,b)
(define prod/enum (define prod/e
(case-lambda (case-lambda
[(e) e] [(e) e]
[(e1 e2) [(e1 e2)
(cond [(or (= 0 (size e1)) (cond [(or (= 0 (size e1))
(= 0 (size e2))) empty/enum] (= 0 (size e2))) empty/e]
[(not (infinite? (enum-size e1))) [(not (infinite? (enum-size e1)))
(cond [(not (infinite? (enum-size e2))) (cond [(not (infinite? (enum-size e2)))
(let ([size (* (enum-size e1) (let ([size (* (enum-size e1)
@ -352,7 +352,12 @@
2) 2)
l))))])] l))))])]
[(a b c . rest) [(a b c . rest)
(prod/enum a (apply prod/enum b c rest))])) (prod/e a (apply prod/e b c rest))]))
;; Traversal (maybe come up with a better name
;; traverse/e : (a -> enum b), (listof a) -> enum (listof b)
(define (traverse/e f xs)
(list/e (map f xs)))
;; the nth triangle number ;; the nth triangle number
(define (tri n) (define (tri n)
@ -370,8 +375,8 @@
1)) 1))
2))) 2)))
;; dep/enum : enum a (a -> enum b) -> enum (a, b) ;; dep/e : enum a (a -> enum b) -> enum (a, b)
(define (dep/enum e f) (define (dep/e e f)
(define (search-size sizes n) (define (search-size sizes n)
(define (loop cur) (define (loop cur)
(let* ([lastSize (gvector-ref sizes (- cur 1))] (let* ([lastSize (gvector-ref sizes (- cur 1))]
@ -394,7 +399,7 @@
s s
(loop (+ cur 1)))))) (loop (+ cur 1))))))
(if (= 0 (size e)) (if (= 0 (size e))
empty/enum empty/e
(let ([first (size (f (decode e 0)))]) (let ([first (size (f (decode e 0)))])
(cond (cond
[(not (infinite? first)) [(not (infinite? first))
@ -451,7 +456,7 @@
(λ (ab) (λ (ab)
(+ (* (size e) (encode (f (car ab)) (cdr ab))) (+ (* (size e) (encode (f (car ab)) (cdr ab)))
(encode e (car ab)))))] (encode e (car ab)))))]
[else ;; both infinite, same as prod/enum [else ;; both infinite, same as prod/e
(enum +inf.f (enum +inf.f
(λ (n) (λ (n)
(let* ([k (floor-untri n)] (let* ([k (floor-untri n)]
@ -496,11 +501,11 @@
[else (bin-search 0 (- size 1))]))) [else (bin-search 0 (- size 1))])))
;; dep2 : enum a (a -> enum b) -> enum (a,b) ;; dep2 : enum a (a -> enum b) -> enum (a,b)
(define (dep2/enum e f) (define (dep2/e e f)
(cond [(= 0 (size e)) empty/enum] (cond [(= 0 (size e)) empty/e]
[(not (infinite? (size (f (decode e 0))))) [(not (infinite? (size (f (decode e 0)))))
;; memoize tab : boxof (hash nat -o> (nat . nat)) ;; memoize tab : boxof (hash nat -o> (nat . nat))
;; maps an index into the dep/enum to the 2 indices that we need ;; maps an index into the dep/e to the 2 indices that we need
(let ([tab (box (hash))]) (let ([tab (box (hash))])
(enum (if (infinite? (size e)) (enum (if (infinite? (size e))
+inf.f +inf.f
@ -560,94 +565,94 @@
(size (f (decode e i))))))) (size (f (decode e i)))))))
(encode (f (car ab)) (encode (f (car ab))
(cdr ab)))))))] (cdr ab)))))))]
[else ;; both infinite, same as prod/enum [else ;; both infinite, same as prod/e
(dep/enum e f)])) (dep/e e f)]))
;; 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)
(map/enum (map/e
reverse reverse
reverse reverse
(let loop ([l l] (let loop ([l l]
[acc (const/enum '())]) [acc (const/e '())])
(cond [(empty? l) acc] (cond [(empty? l) acc]
[else [else
(loop (loop
(cdr l) (cdr l)
(flip-dep/enum (flip-dep/e
acc acc
(λ (xs) (λ (xs)
(f xs (car l)))))])))) (f xs (car l)))))]))))
;; flip-dep/enum : enum a (a -> enum b) -> enum (b,a) ;; flip-dep/e : enum a (a -> enum b) -> enum (b,a)
(define (flip-dep/enum e f) (define (flip-dep/e e f)
(map/enum (map/e
(λ (ab) (λ (ab)
(cons (cdr ab) (cons (cdr ab)
(car ab))) (car ab)))
(λ (ba) (λ (ba)
(cons (cdr ba) (cons (cdr ba)
(car ba))) (car ba)))
(dep/enum e f))) (dep/e e f)))
;; more utility enums ;; more utility enums
;; nats of course ;; nats of course
(define (range/enum low high) (define (range/e low high)
(cond [(> low high) (error 'bad-range)] (cond [(> low high) (error 'bad-range)]
[(infinite? high) [(infinite? high)
(if (infinite? low) (if (infinite? low)
ints ints
(map/enum (map/e
(λ (n) (λ (n)
(+ n low)) (+ n low))
(λ (n) (λ (n)
(- n low)) (- n low))
nats))] nats))]
[(infinite? low) [(infinite? low)
(map/enum (map/e
(λ (n) (λ (n)
(- high n)) (- high n))
(λ (n) (λ (n)
(+ high n)) (+ high n))
nats)] nats)]
[else [else
(map/enum (λ (n) (+ n low)) (map/e (λ (n) (+ n low))
(λ (n) (- n low)) (λ (n) (- n low))
(take/enum nats (+ 1 (- high low))))])) (take/e nats (+ 1 (- high low))))]))
;; thunk/enum : Nat or +-Inf, ( -> enum a) -> enum a ;; thunk/e : Nat or +-Inf, ( -> enum a) -> enum a
(define (thunk/enum s thunk) (define (thunk/e s thunk)
(enum s (enum s
(λ (n) (λ (n)
(decode (thunk) n)) (decode (thunk) n))
(λ (x) (λ (x)
(encode (thunk) x)))) (encode (thunk) x))))
;; listof/enum : enum a -> enum (listof a) ;; listof/e : enum a -> enum (listof a)
(define (listof/enum e) (define (listof/e e)
(thunk/enum (thunk/e
(if (= 0 (size e)) (if (= 0 (size e))
0 0
+inf.f) +inf.f)
(λ () (λ ()
(sum/enum (sum/e
(const/enum '()) (const/e '())
(prod/enum e (listof/enum e)))))) (prod/e e (listof/e e))))))
;; list/enum : listof (enum any) -> enum (listof any) ;; list/e : listof (enum any) -> enum (listof any)
(define (list/enum es) (define (list/e es)
(apply prod/enum (append es `(,(const/enum '()))))) (apply prod/e (append es `(,(const/e '())))))
(define (nats+/enum n) (define (nats+/e n)
(map/enum (λ (k) (map/e (λ (k)
(+ k n)) (+ k n))
(λ (k) (λ (k)
(- k n)) (- k n))
nats)) nats))
;; fail/enum : exn -> enum () ;; fail/e : exn -> enum ()
;; returns an enum that calls a thunk ;; returns an enum that calls a thunk
(define (fail/enum e) (define (fail/e e)
(let ([t (let ([t
(λ (_) (λ (_)
(raise e))]) (raise e))])
@ -672,8 +677,8 @@
(encode e (decode e n))) (encode e (decode e n)))
nums)))) nums))))
;; const/enum tests ;; const/e tests
(let ([e (const/enum 17)]) (let ([e (const/e 17)])
(test-begin (test-begin
(check-eq? (decode e 0) 17) (check-eq? (decode e 0) 17)
(check-exn exn:fail? (check-exn exn:fail?
@ -685,8 +690,8 @@
(encode e 0))) (encode e 0)))
(check-bijection? e))) (check-bijection? e)))
;; from-list/enum tests ;; from-list/e tests
(let ([e (from-list/enum '(5 4 1 8))]) (let ([e (from-list/e '(5 4 1 8))])
(test-begin (test-begin
(check-eq? (decode e 0) 5) (check-eq? (decode e 0) 5)
(check-eq? (decode e 3) 8) (check-eq? (decode e 3) 8)
@ -700,7 +705,7 @@
(check-bijection? e))) (check-bijection? e)))
;; map test ;; map test
(define nats+1 (nats+/enum 1)) (define nats+1 (nats+/e 1))
(test-begin (test-begin
(check-equal? (size nats+1) +inf.f) (check-equal? (size nats+1) +inf.f)
@ -725,13 +730,13 @@
;; sum tests ;; sum tests
(test-begin (test-begin
(let ([bool-or-num (sum/enum bools (let ([bool-or-num (sum/e bools
(from-list/enum '(0 1 2)))] (from-list/e '(0 1 2)))]
[bool-or-nat (sum/enum bools [bool-or-nat (sum/e bools
nats)] nats)]
[nat-or-bool (sum/enum nats [nat-or-bool (sum/e nats
bools)] bools)]
[odd-or-even (sum/enum evens [odd-or-even (sum/e evens
odds)]) odds)])
(check-equal? (enum-size bool-or-num) (check-equal? (enum-size bool-or-num)
5) 5)
@ -768,12 +773,12 @@
(check-equal? (encode odd-or-even 3) 3) (check-equal? (encode odd-or-even 3) 3)
(check-bijection? odd-or-even))) (check-bijection? odd-or-even)))
;; prod/enum tests ;; prod/e tests
(define bool*bool (prod/enum bools bools)) (define bool*bool (prod/e bools bools))
(define 1*b (prod/enum (const/enum 1) bools)) (define 1*b (prod/e (const/e 1) bools))
(define bool*nats (prod/enum bools nats)) (define bool*nats (prod/e bools nats))
(define nats*bool (prod/enum nats bools)) (define nats*bool (prod/e nats bools))
(define nats*nats (prod/enum nats nats)) (define nats*nats (prod/e nats nats))
(define ns-equal? (λ (ns ms) (define ns-equal? (λ (ns ms)
(and (= (car ns) (and (= (car ns)
(car ms)) (car ms))
@ -839,25 +844,25 @@
(check-bijection? nats*nats)) (check-bijection? nats*nats))
;; dep/enum tests ;; dep/e tests
(define (up-to n) (define (up-to n)
(take/enum nats (+ n 1))) (take/e nats (+ n 1)))
(define 3-up (define 3-up
(dep/enum (dep/e
(from-list/enum '(0 1 2)) (from-list/e '(0 1 2))
up-to)) up-to))
(define from-3 (define from-3
(dep/enum (dep/e
(from-list/enum '(0 1 2)) (from-list/e '(0 1 2))
nats+/enum)) nats+/e))
(define nats-to (define nats-to
(dep/enum nats up-to)) (dep/e nats up-to))
(define nats-up (define nats-up
(dep/enum nats nats+/enum)) (dep/e nats nats+/e))
(test-begin (test-begin
(check-equal? (size 3-up) 6) (check-equal? (size 3-up) 6)
@ -911,15 +916,15 @@
(check-equal? (find-size (gvector 1 5 7) 6) 2) (check-equal? (find-size (gvector 1 5 7) 6) 2)
(check-equal? (find-size (gvector 1 5 7) 7) #f) (check-equal? (find-size (gvector 1 5 7) 7) #f)
;; depend/enum tests ;; depend/e tests
;; same as dep unless the right side is finite ;; same as dep unless the right side is finite
(define 3-up-2 (define 3-up-2
(dep/enum (dep/e
(from-list/enum '(0 1 2)) (from-list/e '(0 1 2))
up-to)) up-to))
(define nats-to-2 (define nats-to-2
(dep/enum nats up-to)) (dep/e nats up-to))
(test-begin (test-begin
@ -953,7 +958,7 @@
(check-equal? (decode nats-to-2 5) (cons 2 2)) (check-equal? (decode nats-to-2 5) (cons 2 2))
(check-equal? (decode nats-to-2 6) (cons 3 0))) (check-equal? (decode nats-to-2 6) (cons 3 0)))
;; take/enum test ;; take/e test
(define to-2 (up-to 2)) (define to-2 (up-to 2))
(test-begin (test-begin
(check-equal? (size to-2) 3) (check-equal? (size to-2) 3)
@ -967,13 +972,13 @@
(check-equal? (to-list (up-to 3)) (check-equal? (to-list (up-to 3))
'(0 1 2 3))) '(0 1 2 3)))
;; except/enum test ;; except/e test
(define not-3 (except/enum nats '(3))) (define not-3 (except/e nats '(3)))
(test-begin (test-begin
(check-equal? (decode not-3 0) 0) (check-equal? (decode not-3 0) 0)
(check-equal? (decode not-3 3) 4) (check-equal? (decode not-3 3) 4)
(check-bijection? not-3)) (check-bijection? not-3))
(define not-a (except/enum nats '(a))) (define not-a (except/e nats '(a)))
(test-begin (test-begin
(check-equal? (decode not-a 0) 0) (check-equal? (decode not-a 0) 0)
(check-bijection? not-a)) (check-bijection? not-a))
@ -982,6 +987,6 @@
(define complicated (define complicated
(fold-enum (fold-enum
(λ (excepts n) (λ (excepts n)
(except/enum (up-to n) excepts)) (except/e (up-to n) excepts))
'(2 4 6))) '(2 4 6)))
(check-bijection? complicated)) (check-bijection? complicated))