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

Redex generator supports mismatched names.

Browse Source 
Also added mismatched name tests.
This commit is contained in:
Max New 2013-05-20 01:11:04 -05:00
parent f67b1ca06c
commit 797f7f7bd2
3 changed files with 567 additions and 361 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

302
collects/redex/private/enum.rkt
View File

@ -19,11 +19,19 @@
[enum? (-> any/c boolean?)])) [enum? (-> any/c boolean?)]))
(struct lang-enum (enums)) (struct lang-enum (enums))
(struct decomposition (ctx term)) (struct repeat (n terms) #:transparent)
(struct named (name val)) (struct decomposition (ctx term) #:transparent)
(struct named-t (val term)) (struct named (name val) #:transparent)
(struct name (name) #:transparent) (struct named-t (val term) #:transparent)
(struct unimplemented (msg)) (struct mismatch (name val) #:transparent)
(struct mismatch-t (vals term) #:transparent)
(struct name-ref (name) #:transparent)
(struct mismatch-ref (name) #:transparent)
(struct unimplemented (msg) #:transparent)
(struct named-pats (names map) #:transparent
) ;; listof symbol and hash symbol -o> (or named, mismatched, named-repeat, mismatch-repeat)
(define enum-ith decode) (define enum-ith decode)
@ -265,10 +273,10 @@
(sep-names pat) (sep-names pat)
l-enums)) l-enums))
;; sep-names : single-pattern lang -> (assoclist symbol pattern) ;; sep-names : single-pattern lang -> named-pats
(define (sep-names pat) (define (sep-names pat)
(let loop ([pat pat] (let loop ([pat pat]
[named-pats '()]) [named-pats empty-named-pats])
(match-a-pattern (match-a-pattern
pat pat
[`any named-pats] [`any named-pats]
@ -285,11 +293,12 @@
[`hole named-pats] [`hole named-pats]
;; names inside nts are separate ;; names inside nts are separate
[`(nt ,id) named-pats] [`(nt ,id) named-pats]
[`(name ,name ,pat) [`(name ,n ,pat)
(loop pat (loop pat
(add-if-new name pat named-pats))] (add-named n pat named-pats))]
[`(mismatch-name ,name ,pat) [`(mismatch-name ,n ,pat)
(loop pat (cons (unimplemented "mismatch") named-pats))] (loop pat
(add-mismatch n pat named-pats))]
[`(in-hole ,p1 ,p2) [`(in-hole ,p1 ,p2)
(loop p2 (loop p2
(loop p1 named-pats))] (loop p1 named-pats))]
@ -304,16 +313,84 @@
[`(repeat ,pat #f #f) [`(repeat ,pat #f #f)
(loop pat named-pats)] (loop pat named-pats)]
[`(repeat ,pat ,name ,mismatch) [`(repeat ,pat ,name ,mismatch)
(loop pat (cons (unimplemented "named/mismatched repeat") named-pats))] (loop pat
(add-unimplemented name "named/mismatched repeat" named-pats))]
[else (loop sub-pat named-pats)])) [else (loop sub-pat named-pats)]))
named-pats named-pats
sub-pats)] sub-pats)]
[(? (compose not pair?)) [(? (compose not pair?))
named-pats]))) named-pats])))
(define (add-if-new k v l) ;; named-pats combinators
(cond [(assoc-named k l) l] (define empty-named-pats
[else (cons (named k v) l)])) (named-pats '() (hash)))
(define (empty-named-pats? nps)
(null? (named-pats-names nps)))
(define (next-named-pats nps)
(hash-ref (named-pats-map nps)
(car (named-pats-names nps))))
(define (rest-named-pats nps)
(named-pats (cdr (named-pats-names nps))
(named-pats-map nps)))
(define (member-named-pats name nps)
(member name (named-pats-names nps)))
(define (add-named name pat nps)
(cond [(member-named-pats name nps)
nps]
[else
(add-named-pats name (named name pat) nps)]))
(define (add-unimplemented name msg nps)
(add-named-pats name
(unimplemented msg)
nps))
(define (add-mismatch n pat nps)
(cond [(member-named-pats n nps)
(named-pats-set n
(mismatch
n
(cons pat
(mismatch-val
(hash-ref (named-pats-map nps)
n))))
nps)]
[else
(add-named-pats n
(mismatch n (list pat))
nps)]))
(define (named-pats-set n val nps)
(named-pats
(named-pats-names nps)
(hash-set (named-pats-map nps)
n val)))
(define (add-named-pats n val nps)
(named-pats (cons n (named-pats-names nps))
(hash-set (named-pats-map nps) n val)))
(define (reverse-named-pats nps)
(named-pats (named-pats-names nps)
(foldl
(λ (kv m)
(let ([key (car kv)]
[val (cdr kv)])
(hash-set m key
(cond [(named? val)
val]
[(mismatch? val)
(mismatch (mismatch-name val)
(reverse
(mismatch-val val)))]
[(unimplemented? val)
val]))))
(hash)
(hash->list (named-pats-map nps)))))
(define (assoc-named n l) (define (assoc-named n l)
(cond [(null? l) #f] (cond [(null? l) #f]
@ -324,14 +401,14 @@
n))) n)))
(assoc-named n (cdr l)))])) (assoc-named n (cdr l)))]))
(define (enum-names pat named-pats nt-enums) (define (enum-names pat nps nt-enums)
(let rec ([named-pats named-pats] (let rec ([nps nps]
[env (hash)]) [env (hash)])
(cond [(null? named-pats) (cond [(empty-named-pats? nps)
(pat/enum-with-names pat nt-enums env)] (pat/enum-with-names pat nt-enums env)]
[else [else
(let ([cur (car named-pats)]) (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/enum
@ -352,12 +429,47 @@
(dep/enum (dep/enum
(pat/enum-with-names pat nt-enums env) (pat/enum-with-names pat nt-enums env)
(λ (term) (λ (term)
(rec (cdr named-pats) (rec (rest-named-pats nps)
(hash-set env (hash-set env
name name
term))))))) term))))))]
[else (error/enum 'unimplemented [(mismatch? cur)
(unimplemented-msg cur))]))]))) (let ([name (mismatch-name cur)])
(map/enum
(λ (ts)
(mismatch name
(mismatch-t (car ts)
(cdr ts))))
(λ (n)
(if (equal? (mismatch-name n)
name)
(let ([val (mismatch-val n)])
(cons (mismatch-t-vals val)
(mismatch-t-term val)))
(error 'wrong-name
"expected ~a, got ~a"
name
(named-name n))))
(dep/enum
(fold-enum
(λ (excepts pat)
(except/enum
(pat/enum-with-names pat
nt-enums
(hash-set env
(mismatch-name cur)
excepts))
excepts))
(mismatch-val cur))
(λ (terms)
(rec (rest-named-pats nps)
(hash-set env
name
terms))))))]
[(unimplemented? cur)
(error/enum 'unimplemented
(unimplemented-msg cur))]
[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/enum-with-names pat nt-enums named-terms)
(let loop ([pat pat]) (let loop ([pat pat])
@ -375,7 +487,7 @@
[`boolean bool/enum] [`boolean bool/enum]
[`variable var/enum] [`variable var/enum]
[`(variable-except ,s ...) [`(variable-except ,s ...)
(apply except/enum var/enum s)] (except/enum var/enum s)]
[`(variable-prefix ,s) [`(variable-prefix ,s)
;; todo ;; todo
(error/enum 'unimplemented "var-prefix")] (error/enum 'unimplemented "var-prefix")]
@ -386,9 +498,9 @@
[`(nt ,id) [`(nt ,id)
(hash-ref nt-enums id)] (hash-ref nt-enums id)]
[`(name ,n ,pat) [`(name ,n ,pat)
(const/enum (name n))] (const/enum (name-ref n))]
[`(mismatch-name ,name ,pat) [`(mismatch-name ,n ,pat)
(error/enum 'unimplemented "mismatch-name")] (const/enum (mismatch-ref n))]
[`(in-hole ,p1 ,p2) ;; untested [`(in-hole ,p1 ,p2) ;; untested
(map/enum (map/enum
(λ (ts) (λ (ts)
@ -408,33 +520,29 @@
(unsupported/enum pat)] (unsupported/enum pat)]
[`(list ,sub-pats ...) [`(list ,sub-pats ...)
;; enum-list ;; enum-list
(map/enum (list/enum
flatten-1 (map
identity (λ (sub-pat)
(list/enum (match sub-pat
(map [`(repeat ,pat #f #f)
(λ (sub-pat) (map/enum
(match sub-pat (λ (n-ts)
[`(repeat ,pat #f #f) (repeat (car n-ts)
(map/enum (cdr n-ts)))
cdr (λ (rep)
(λ (ts) (cons (repeat-n rep)
(cons (length ts) (repeat-terms rep)))
ts)) (dep/enum
(dep/enum nats
nats (λ (n)
(λ (n) (list/enum
(list/enum (build-list n (const (loop pat)))))))]
(build-list n (const (loop pat)))))))] [`(repeat ,pat ,name #f)
[`(repeat ,pat ,name #f) (error/enum 'unimplemented "named-repeat")]
(error/enum 'unimplemented "named-repeat")] [`(repeat ,pat #f ,mismatch)
[`(repeat ,pat #f ,mismatch) (error/enum 'unimplemented "mismatch-repeat")]
(error/enum 'unimplemented "mismatch-repeat")] [else (loop sub-pat)]))
[else (map/enum sub-pats))]
list
car
(loop sub-pat))]))
sub-pats)))]
[(? (compose not pair?)) [(? (compose not pair?))
(const/enum pat)]))) (const/enum pat)])))
@ -475,10 +583,9 @@
(λ (n) (- (- n) 1)) (λ (n) (- (- n) 1))
nats))) nats)))
(define real/enum (from-list/enum '(0.0 1.5 123.112354))) (define real/enum (from-list/enum '(0.5 1.5 123.112354)))
(define num/enum (define num/enum
(sum/enum natural/enum (sum/enum integer/enum
integer/enum
real/enum)) real/enum))
(define bool/enum (define bool/enum
@ -499,10 +606,27 @@
(define (to-term aug) (define (to-term aug)
(cond [(named? aug) (cond [(named? aug)
(rep-name aug)] (rep-name aug)]
[(mismatch? aug)
(rep-mismatches aug)]
[(decomposition? aug) [(decomposition? aug)
(plug-hole aug)] (plug-hole aug)]
[(repeat? aug)
(map-repeat to-term
aug)]
[(list? aug)
(expand-repeats
(map to-term aug))]
[else aug])) [else aug]))
(define (expand-repeats sub-terms)
(append*
(map
(λ (t)
(cond [(repeat? t)
(repeat-terms t)]
[else (list t)]))
sub-terms)))
(define (rep-name s) (define (rep-name s)
(to-term (to-term
(let* ([n (named-name s)] (let* ([n (named-name s)]
@ -510,10 +634,10 @@
[val (named-t-val v)] [val (named-t-val v)]
[term (named-t-term v)]) [term (named-t-term v)])
(let loop ([term term]) (let loop ([term term])
(cond [(and (name? term) (cond [(and (name-ref? term)
(equal? (name-name term) n)) (equal? (name-ref-name term) n))
val] val]
[(cons? term) [(list? term)
(map loop term)] (map loop term)]
[(named? term) [(named? term)
(map-named loop (map-named loop
@ -521,13 +645,48 @@
[(decomposition? term) [(decomposition? term)
(map-decomp loop (map-decomp loop
term)] term)]
[(mismatch? term)
(map-mismatch loop
term)]
[(repeat? term)
(map-repeat loop
term)]
[else term]))))) [else term])))))
(define (rep-mismatches m)
(to-term
(let* ([name (mismatch-name m)]
[v (mismatch-val m)]
[vals (mismatch-t-vals v)]
[term (mismatch-t-term v)])
(let ([vals vals])
(let loop ([term term])
(cond [(and (mismatch-ref? term)
(equal? (mismatch-ref-name term) name))
(begin0
(car vals)
(set! vals (cdr vals)))]
[(list? term)
(map loop term)]
[(named? term)
(map-named loop
term)]
[(decomposition? term)
(map-decomp loop
term)]
[(mismatch? term)
(map-mismatch loop
term)]
[(repeat? term)
(map-repeat loop
term)]
[else term]))))))
(define (plug-hole ctx term) (define (plug-hole ctx term)
(to-term (to-term
(let loop ([ctx ctx]) (let loop ([ctx ctx])
(cond [(hole? ctx) term] (cond [(hole? ctx) term]
[(cons? ctx) (map loop ctx)] [(list? ctx) (map loop ctx)]
[(named? )]) [(named? )])
(match (match
ctx ctx
@ -544,7 +703,18 @@
(define (map-named f n) (define (map-named f n)
(let ([v (named-val n)]) (let ([v (named-val n)])
(named (named-name n) (named (named-name n)
(named-t (named-t
(named-t-val v) (named-t-val v)
(f (named-t-term v)))))) (f (named-t-term v))))))
(define (map-mismatch f m)
(let ([v (mismatch-val m)])
(mismatch (mismatch-name m)
(mismatch-t
(mismatch-t-vals v)
(f (mismatch-t-term v))))))
(define (map-repeat f r)
(repeat (repeat-n r)
(map f (repeat-terms r))))

613
collects/redex/private/enumerator.rkt
View File

@ -26,7 +26,7 @@
to-list to-list
take/enum take/enum
drop/enum drop/enum
foldl-enum fold-enum
display-enum display-enum
nats nats
@ -80,28 +80,24 @@
(λ (x) (encode e x)))) (λ (x) (encode e x))))
;; except/enum : enum a, a -> enum a ;; except/enum : enum a, a -> enum a
(define except/enum (define (except/enum e excepts)
(case-lambda (cond [(empty? excepts) e]
[(e) e] [else
[(e a . rest) (except/enum
(let ([excepted (begin
(begin (with-handlers ([exn:fail? (λ (_) e)])
(unless (> (size e) 0) (let ([m (encode e (car excepts))])
(error 'empty-enum)) (enum (- (size e) 1)
(with-handlers ([exn:fail? (λ (_) (λ (n)
(apply except/enum e rest))]) (if (< n m)
(let ([m (encode e a)]) (decode e n)
(enum (- (size e) 1) (decode e (+ n 1))))
(λ (n) (λ (x)
(if (< n m) (let ([n (encode e x)])
(decode e n) (cond [(< n m) n]
(decode e (+ n 1)))) [(> n m) (- n 1)]
(λ (x) [else (error 'excepted)])))))))
(let ([n (encode e x)]) (cdr excepts))]))
(cond [(< n m) n]
[(> n m) (- n 1)]
[else (error 'excepted)])))))))])
(apply except/enum excepted rest))]))
;; to-list : enum a -> listof a ;; to-list : enum a -> listof a
;; better be finite ;; better be finite
@ -141,11 +137,6 @@
(λ (x) (λ (x)
(- (encode e x) n)))) (- (encode e x) n))))
;; foldl-enum : enum a, b, (a,b -> b) -> b
;; better be a finite enum
(define (foldl-enum f id e)
(foldl f id (to-list e)))
;; display-enum : enum a, Nat -> void ;; display-enum : enum a, Nat -> void
(define (display-enum e n) (define (display-enum e n)
(for ([i (range n)]) (for ([i (range n)])
@ -509,7 +500,32 @@
[else ;; both infinite, same as prod/enum [else ;; both infinite, same as prod/enum
(dep/enum e f)])) (dep/enum e f)]))
;; fold-enum : ((listof a), b -> enum a), (listof b) -> enum (listof a)
(define (fold-enum f l)
(map/enum
reverse
reverse
(let loop ([l l]
[acc (const/enum '())])
(cond [(empty? l) acc]
[else
(loop
(cdr l)
(flip-dep/enum
acc
(λ (xs)
(f xs (car l)))))]))))
;; flip-dep/enum : enum a (a -> enum b) -> enum (b,a)
(define (flip-dep/enum e f)
(map/enum
(λ (ab)
(cons (cdr ab)
(car ab)))
(λ (ba)
(cons (cdr ba)
(car ba)))
(dep/enum e f)))
;; more utility enums ;; more utility enums
;; nats of course ;; nats of course
@ -585,305 +601,312 @@
(module+ (module+
test test
(require rackunit) (require rackunit)
(provide check-bijection?) (provide check-bijection?)
(define confidence 1000) (define confidence 1000)
(define nums (build-list confidence identity)) (define nums (build-list confidence identity))
(define-simple-check (check-bijection? e) (define-simple-check (check-bijection? e)
(let ([nums (build-list (if (<= (enum-size e) confidence) (let ([nums (build-list (if (<= (enum-size e) confidence)
(enum-size e) (enum-size e)
confidence) confidence)
identity)]) identity)])
(andmap = (andmap =
nums nums
(map (λ (n) (map (λ (n)
(encode e (decode e n))) (encode e (decode e n)))
nums)))) nums))))
;; const/enum tests ;; const/enum tests
(let ([e (const/enum 17)]) (let ([e (const/enum 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?
(λ () (λ ()
(decode e 1))) (decode e 1)))
(check-eq? (encode e 17) 0) (check-eq? (encode e 17) 0)
(check-exn exn:fail? (check-exn exn:fail?
(λ () (λ ()
(encode e 0))) (encode e 0)))
(check-bijection? e))) (check-bijection? e)))
;; from-list/enum tests ;; from-list/enum tests
(let ([e (from-list/enum '(5 4 1 8))]) (let ([e (from-list/enum '(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)
(check-exn exn:fail? (check-exn exn:fail?
(λ () (decode e 4))) (λ () (decode e 4)))
(check-eq? (encode e 5) 0) (check-eq? (encode e 5) 0)
(check-eq? (encode e 8) 3) (check-eq? (encode e 8) 3)
(check-exn exn:fail? (check-exn exn:fail?
(λ () (λ ()
(encode e 17))) (encode e 17)))
(check-bijection? e))) (check-bijection? e)))
;; map test ;; map test
(define nats+1 (nats+/enum 1)) (define nats+1 (nats+/enum 1))
(test-begin (test-begin
(check-equal? (size nats+1) +inf.f) (check-equal? (size nats+1) +inf.f)
(check-equal? (decode nats+1 0) 1) (check-equal? (decode nats+1 0) 1)
(check-equal? (decode nats+1 1) 2) (check-equal? (decode nats+1 1) 2)
(check-bijection? nats+1)) (check-bijection? nats+1))
;; encode check ;; encode check
(test-begin (test-begin
(check-exn exn:fail? (check-exn exn:fail?
(λ () (λ ()
(decode nats -1)))) (decode nats -1))))
;; ints checks ;; ints checks
(test-begin (test-begin
(check-eq? (decode ints 0) 0) ; 0 -> 0 (check-eq? (decode ints 0) 0) ; 0 -> 0
(check-eq? (decode ints 1) 1) ; 1 -> 1 (check-eq? (decode ints 1) 1) ; 1 -> 1
(check-eq? (decode ints 2) -1) ; 2 -> 1 (check-eq? (decode ints 2) -1) ; 2 -> 1
(check-eq? (encode ints 0) 0) (check-eq? (encode ints 0) 0)
(check-eq? (encode ints 1) 1) (check-eq? (encode ints 1) 1)
(check-eq? (encode ints -1) 2) (check-eq? (encode ints -1) 2)
(check-bijection? ints)) ; -1 -> 2, -3 -> 4 (check-bijection? ints)) ; -1 -> 2, -3 -> 4
;; sum tests ;; sum tests
(test-begin (test-begin
(let ([bool-or-num (sum/enum bools (let ([bool-or-num (sum/enum bools
(from-list/enum '(0 1 2)))] (from-list/enum '(0 1 2)))]
[bool-or-nat (sum/enum bools [bool-or-nat (sum/enum bools
nats)] nats)]
[nat-or-bool (sum/enum nats [nat-or-bool (sum/enum nats
bools)] bools)]
[odd-or-even (sum/enum evens [odd-or-even (sum/enum evens
odds)]) odds)])
(check-equal? (enum-size bool-or-num) (check-equal? (enum-size bool-or-num)
5) 5)
(check-equal? (decode bool-or-num 0) #t) (check-equal? (decode bool-or-num 0) #t)
(check-equal? (decode bool-or-num 1) #f) (check-equal? (decode bool-or-num 1) #f)
(check-equal? (decode bool-or-num 2) 0) (check-equal? (decode bool-or-num 2) 0)
(check-exn exn:fail? (check-exn exn:fail?
(λ () (λ ()
(decode bool-or-num 5))) (decode bool-or-num 5)))
(check-equal? (encode bool-or-num #f) 1) (check-equal? (encode bool-or-num #f) 1)
(check-equal? (encode bool-or-num 2) 4) (check-equal? (encode bool-or-num 2) 4)
(check-bijection? bool-or-num) (check-bijection? bool-or-num)
(check-equal? (enum-size bool-or-nat) (check-equal? (enum-size bool-or-nat)
+inf.f) +inf.f)
(check-equal? (decode bool-or-nat 0) #t) (check-equal? (decode bool-or-nat 0) #t)
(check-equal? (decode bool-or-nat 2) 0) (check-equal? (decode bool-or-nat 2) 0)
(check-bijection? bool-or-nat) (check-bijection? bool-or-nat)
(check-equal? (encode bool-or-num #f) 1) (check-equal? (encode bool-or-num #f) 1)
(check-equal? (encode bool-or-num 2) 4) (check-equal? (encode bool-or-num 2) 4)
(check-equal? (enum-size odd-or-even) (check-equal? (enum-size odd-or-even)
+inf.f) +inf.f)
(check-equal? (decode odd-or-even 0) 0) (check-equal? (decode odd-or-even 0) 0)
(check-equal? (decode odd-or-even 1) 1) (check-equal? (decode odd-or-even 1) 1)
(check-equal? (decode odd-or-even 2) 2) (check-equal? (decode odd-or-even 2) 2)
(check-exn exn:fail? (check-exn exn:fail?
(λ () (λ ()
(decode odd-or-even -1))) (decode odd-or-even -1)))
(check-equal? (encode odd-or-even 0) 0) (check-equal? (encode odd-or-even 0) 0)
(check-equal? (encode odd-or-even 1) 1) (check-equal? (encode odd-or-even 1) 1)
(check-equal? (encode odd-or-even 2) 2) (check-equal? (encode odd-or-even 2) 2)
(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/enum tests
(define bool*bool (prod/enum bools bools)) (define bool*bool (prod/enum bools bools))
(define 1*b (prod/enum (const/enum 1) bools)) (define 1*b (prod/enum (const/enum 1) bools))
(define bool*nats (prod/enum bools nats)) (define bool*nats (prod/enum bools nats))
(define nats*bool (prod/enum nats bools)) (define nats*bool (prod/enum nats bools))
(define nats*nats (prod/enum nats nats)) (define nats*nats (prod/enum nats nats))
(define ns-equal? (λ (ns ms) (define ns-equal? (λ (ns ms)
(and (= (car ns) (and (= (car ns)
(car ms)) (car ms))
(= (cdr ns) (= (cdr ns)
(cdr ms))))) (cdr ms)))))
;; prod tests ;; prod tests
(test-begin (test-begin
(check-equal? (size 1*b) 2) (check-equal? (size 1*b) 2)
(check-equal? (decode 1*b 0) (cons 1 #t)) (check-equal? (decode 1*b 0) (cons 1 #t))
(check-equal? (decode 1*b 1) (cons 1 #f)) (check-equal? (decode 1*b 1) (cons 1 #f))
(check-bijection? 1*b) (check-bijection? 1*b)
(check-equal? (enum-size bool*bool) 4) (check-equal? (enum-size bool*bool) 4)
(check-equal? (decode bool*bool 0) (check-equal? (decode bool*bool 0)
(cons #t #t)) (cons #t #t))
(check-equal? (decode bool*bool 1) (check-equal? (decode bool*bool 1)
(cons #t #f)) (cons #t #f))
(check-equal? (decode bool*bool 2) (check-equal? (decode bool*bool 2)
(cons #f #t)) (cons #f #t))
(check-equal? (decode bool*bool 3) (check-equal? (decode bool*bool 3)
(cons #f #f)) (cons #f #f))
(check-bijection? bool*bool) (check-bijection? bool*bool)
(check-equal? (enum-size bool*nats) +inf.f) (check-equal? (enum-size bool*nats) +inf.f)
(check-equal? (decode bool*nats 0) (check-equal? (decode bool*nats 0)
(cons #t 0)) (cons #t 0))
(check-equal? (decode bool*nats 1) (check-equal? (decode bool*nats 1)
(cons #f 0)) (cons #f 0))
(check-equal? (decode bool*nats 2) (check-equal? (decode bool*nats 2)
(cons #t 1)) (cons #t 1))
(check-equal? (decode bool*nats 3) (check-equal? (decode bool*nats 3)
(cons #f 1)) (cons #f 1))
(check-bijection? bool*nats) (check-bijection? bool*nats)
(check-equal? (enum-size nats*bool) +inf.f) (check-equal? (enum-size nats*bool) +inf.f)
(check-equal? (decode nats*bool 0) (check-equal? (decode nats*bool 0)
(cons 0 #t)) (cons 0 #t))
(check-equal? (decode nats*bool 1) (check-equal? (decode nats*bool 1)
(cons 0 #f)) (cons 0 #f))
(check-equal? (decode nats*bool 2) (check-equal? (decode nats*bool 2)
(cons 1 #t)) (cons 1 #t))
(check-equal? (decode nats*bool 3) (check-equal? (decode nats*bool 3)
(cons 1 #f)) (cons 1 #f))
(check-bijection? nats*bool) (check-bijection? nats*bool)
(check-equal? (enum-size nats*nats) +inf.f) (check-equal? (enum-size nats*nats) +inf.f)
(check ns-equal? (check ns-equal?
(decode nats*nats 0) (decode nats*nats 0)
(cons 0 0)) (cons 0 0))
(check ns-equal? (check ns-equal?
(decode nats*nats 1) (decode nats*nats 1)
(cons 0 1)) (cons 0 1))
(check ns-equal? (check ns-equal?
(decode nats*nats 2) (decode nats*nats 2)
(cons 1 0)) (cons 1 0))
(check ns-equal? (check ns-equal?
(decode nats*nats 3) (decode nats*nats 3)
(cons 0 2)) (cons 0 2))
(check ns-equal? (check ns-equal?
(decode nats*nats 4) (decode nats*nats 4)
(cons 1 1)) (cons 1 1))
(check-bijection? nats*nats)) (check-bijection? nats*nats))
;; dep/enum tests ;; dep/enum tests
(define (up-to n) (define (up-to n)
(take/enum nats (+ n 1))) (take/enum nats (+ n 1)))
(define 3-up (define 3-up
(dep/enum (dep/enum
(from-list/enum '(0 1 2)) (from-list/enum '(0 1 2))
up-to)) up-to))
(define from-3 (define from-3
(dep/enum (dep/enum
(from-list/enum '(0 1 2)) (from-list/enum '(0 1 2))
nats+/enum)) nats+/enum))
(define nats-to (define nats-to
(dep/enum nats up-to)) (dep/enum nats up-to))
(define nats-up (define nats-up
(dep/enum nats nats+/enum)) (dep/enum nats nats+/enum))
(test-begin (test-begin
(check-equal? (size 3-up) 6) (check-equal? (size 3-up) 6)
(check-equal? (decode 3-up 0) (cons 0 0)) (check-equal? (decode 3-up 0) (cons 0 0))
(check-equal? (decode 3-up 1) (cons 1 0)) (check-equal? (decode 3-up 1) (cons 1 0))
(check-equal? (decode 3-up 2) (cons 1 1)) (check-equal? (decode 3-up 2) (cons 1 1))
(check-equal? (decode 3-up 3) (cons 2 0)) (check-equal? (decode 3-up 3) (cons 2 0))
(check-equal? (decode 3-up 4) (cons 2 1)) (check-equal? (decode 3-up 4) (cons 2 1))
(check-equal? (decode 3-up 5) (cons 2 2)) (check-equal? (decode 3-up 5) (cons 2 2))
(check-bijection? 3-up) (check-bijection? 3-up)
(check-equal? (size from-3) +inf.f) (check-equal? (size from-3) +inf.f)
(check-equal? (decode from-3 0) (cons 0 0)) (check-equal? (decode from-3 0) (cons 0 0))
(check-equal? (decode from-3 1) (cons 1 1)) (check-equal? (decode from-3 1) (cons 1 1))
(check-equal? (decode from-3 2) (cons 2 2)) (check-equal? (decode from-3 2) (cons 2 2))
(check-equal? (decode from-3 3) (cons 0 1)) (check-equal? (decode from-3 3) (cons 0 1))
(check-equal? (decode from-3 4) (cons 1 2)) (check-equal? (decode from-3 4) (cons 1 2))
(check-equal? (decode from-3 5) (cons 2 3)) (check-equal? (decode from-3 5) (cons 2 3))
(check-equal? (decode from-3 6) (cons 0 2)) (check-equal? (decode from-3 6) (cons 0 2))
(check-bijection? from-3) (check-bijection? from-3)
(check-equal? (size nats-to) +inf.f) (check-equal? (size nats-to) +inf.f)
(check-equal? (decode nats-to 0) (cons 0 0)) (check-equal? (decode nats-to 0) (cons 0 0))
(check-equal? (decode nats-to 1) (cons 1 0)) (check-equal? (decode nats-to 1) (cons 1 0))
(check-equal? (decode nats-to 2) (cons 1 1)) (check-equal? (decode nats-to 2) (cons 1 1))
(check-equal? (decode nats-to 3) (cons 2 0)) (check-equal? (decode nats-to 3) (cons 2 0))
(check-equal? (decode nats-to 4) (cons 2 1)) (check-equal? (decode nats-to 4) (cons 2 1))
(check-equal? (decode nats-to 5) (cons 2 2)) (check-equal? (decode nats-to 5) (cons 2 2))
(check-equal? (decode nats-to 6) (cons 3 0)) (check-equal? (decode nats-to 6) (cons 3 0))
(check-bijection? nats-to) (check-bijection? nats-to)
(check-equal? (size nats-up) +inf.f) (check-equal? (size nats-up) +inf.f)
(check-equal? (decode nats-up 0) (cons 0 0)) (check-equal? (decode nats-up 0) (cons 0 0))
(check-equal? (decode nats-up 1) (cons 0 1)) (check-equal? (decode nats-up 1) (cons 0 1))
(check-equal? (decode nats-up 2) (cons 1 1)) (check-equal? (decode nats-up 2) (cons 1 1))
(check-equal? (decode nats-up 3) (cons 0 2)) (check-equal? (decode nats-up 3) (cons 0 2))
(check-equal? (decode nats-up 4) (cons 1 2)) (check-equal? (decode nats-up 4) (cons 1 2))
(check-equal? (decode nats-up 5) (cons 2 2)) (check-equal? (decode nats-up 5) (cons 2 2))
(check-equal? (decode nats-up 6) (cons 0 3)) (check-equal? (decode nats-up 6) (cons 0 3))
(check-equal? (decode nats-up 7) (cons 1 3)) (check-equal? (decode nats-up 7) (cons 1 3))
(check-bijection? nats-up)) (check-bijection? nats-up))
;; dep2/enum tests ;; dep2/enum 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
(dep2/enum (dep2/enum
(from-list/enum '(0 1 2)) (from-list/enum '(0 1 2))
up-to)) up-to))
(define nats-to-2 (define nats-to-2
(dep2/enum nats up-to)) (dep2/enum nats up-to))
(test-begin (test-begin
(check-equal? (size 3-up-2) 6) (check-equal? (size 3-up-2) 6)
(check-equal? (decode 3-up-2 0) (cons 0 0)) (check-equal? (decode 3-up-2 0) (cons 0 0))
(check-equal? (decode 3-up-2 1) (cons 1 0)) (check-equal? (decode 3-up-2 1) (cons 1 0))
(check-equal? (decode 3-up-2 2) (cons 1 1)) (check-equal? (decode 3-up-2 2) (cons 1 1))
(check-equal? (decode 3-up-2 3) (cons 2 0)) (check-equal? (decode 3-up-2 3) (cons 2 0))
(check-equal? (decode 3-up-2 4) (cons 2 1)) (check-equal? (decode 3-up-2 4) (cons 2 1))
(check-equal? (decode 3-up-2 5) (cons 2 2)) (check-equal? (decode 3-up-2 5) (cons 2 2))
(check-bijection? 3-up-2) (check-bijection? 3-up-2)
(check-equal? (size nats-to-2) +inf.f) (check-equal? (size nats-to-2) +inf.f)
(check-equal? (decode nats-to-2 0) (cons 0 0)) (check-equal? (decode nats-to-2 0) (cons 0 0))
(check-equal? (decode nats-to-2 1) (cons 1 0)) (check-equal? (decode nats-to-2 1) (cons 1 0))
(check-equal? (decode nats-to-2 2) (cons 1 1)) (check-equal? (decode nats-to-2 2) (cons 1 1))
(check-equal? (decode nats-to-2 3) (cons 2 0)) (check-equal? (decode nats-to-2 3) (cons 2 0))
(check-equal? (decode nats-to-2 4) (cons 2 1)) (check-equal? (decode nats-to-2 4) (cons 2 1))
(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))
(check-bijection? nats-to-2) (check-bijection? nats-to-2)
) )
;; take/enum test
(define to-2 (up-to 2))
(test-begin
(check-equal? (size to-2) 3)
(check-equal? (decode to-2 0) 0)
(check-equal? (decode to-2 1) 1)
(check-equal? (decode to-2 2) 2)
(check-bijection? to-2))
;; take/enum test ;; to-list test
(define to-2 (up-to 2)) (test-begin
(test-begin (check-equal? (to-list (up-to 3))
(check-equal? (size to-2) 3) '(0 1 2 3)))
(check-equal? (decode to-2 0) 0)
(check-equal? (decode to-2 1) 1)
(check-equal? (decode to-2 2) 2)
(check-bijection? to-2))
;; to-list, foldl test ;; except/enum test
(test-begin (define not-3 (except/enum nats '(3)))
(check-equal? (to-list (up-to 3)) (test-begin
'(0 1 2 3)) (check-equal? (decode not-3 0) 0)
(check-equal? (foldl-enum cons '() (up-to 3)) (check-equal? (decode not-3 3) 4)
'(3 2 1 0))) (check-bijection? not-3))
(define not-a (except/enum nats '(a)))
(test-begin
(check-equal? (decode not-a 0) 0)
(check-bijection? not-a))
;; except/enum test ;; fold-enum tests
(define not-3 (except/enum nats 3)) (define complicated
(test-begin (fold-enum
(check-equal? (decode not-3 0) 0) (λ (excepts n)
(check-equal? (decode not-3 3) 4)) (except/enum (up-to n) excepts))
(define not-a (except/enum nats 'a)) '(2 4 6)))
(test-begin (check-bijection? complicated))
(check-equal? (decode not-a 0) 0)))

13
collects/redex/tests/enum-test.rkt
View File

@ -63,4 +63,17 @@
hole) hole)
(x (variable-except λ + if0))) (x (variable-except λ + if0)))
(try-it 100 λv e)
(try-it 100 λv v)
(try-it 100 λv E) (try-it 100 λv E)
(try-it 25 λv x)
(define-language M
(m (x_!_1 x_!_1))
(p (number_!_1 number_!_1))
(n (p_!_1 p_!_1))
(x number))
(try-it 100 M m)
(try-it 100 M n)
(try-it 100 M p)