Redex generator supports mismatched names.
Also added mismatched name tests.
This commit is contained in:
Max New
parent
f67b1ca06c
commit
797f7f7bd2
|
|
@ -19,11 +19,19 @@
|
|||
[enum? (-> any/c boolean?)]))
|
||||
|
||||
(struct lang-enum (enums))
|
||||
(struct decomposition (ctx term))
|
||||
(struct named (name val))
|
||||
(struct named-t (val term))
|
||||
(struct name (name) #:transparent)
|
||||
(struct unimplemented (msg))
|
||||
(struct repeat (n terms) #:transparent)
|
||||
(struct decomposition (ctx term) #:transparent)
|
||||
(struct named (name val) #:transparent)
|
||||
(struct named-t (val term) #:transparent)
|
||||
(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)
|
||||
|
||||
|
|
@ -265,10 +273,10 @@
|
|||
(sep-names pat)
|
||||
l-enums))
|
||||
|
||||
;; sep-names : single-pattern lang -> (assoclist symbol pattern)
|
||||
;; sep-names : single-pattern lang -> named-pats
|
||||
(define (sep-names pat)
|
||||
(let loop ([pat pat]
|
||||
[named-pats '()])
|
||||
[named-pats empty-named-pats])
|
||||
(match-a-pattern
|
||||
pat
|
||||
[`any named-pats]
|
||||
|
|
@ -285,11 +293,12 @@
|
|||
[`hole named-pats]
|
||||
;; names inside nts are separate
|
||||
[`(nt ,id) named-pats]
|
||||
[`(name ,name ,pat)
|
||||
[`(name ,n ,pat)
|
||||
(loop pat
|
||||
(add-if-new name pat named-pats))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(loop pat (cons (unimplemented "mismatch") named-pats))]
|
||||
(add-named n pat named-pats))]
|
||||
[`(mismatch-name ,n ,pat)
|
||||
(loop pat
|
||||
(add-mismatch n pat named-pats))]
|
||||
[`(in-hole ,p1 ,p2)
|
||||
(loop p2
|
||||
(loop p1 named-pats))]
|
||||
|
|
@ -304,16 +313,84 @@
|
|||
[`(repeat ,pat #f #f)
|
||||
(loop pat named-pats)]
|
||||
[`(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)]))
|
||||
named-pats
|
||||
sub-pats)]
|
||||
[(? (compose not pair?))
|
||||
named-pats])))
|
||||
|
||||
(define (add-if-new k v l)
|
||||
(cond [(assoc-named k l) l]
|
||||
[else (cons (named k v) l)]))
|
||||
;; named-pats combinators
|
||||
(define empty-named-pats
|
||||
(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)
|
||||
(cond [(null? l) #f]
|
||||
|
|
@ -324,14 +401,14 @@
|
|||
n)))
|
||||
(assoc-named n (cdr l)))]))
|
||||
|
||||
(define (enum-names pat named-pats nt-enums)
|
||||
(let rec ([named-pats named-pats]
|
||||
(define (enum-names pat nps nt-enums)
|
||||
(let rec ([nps nps]
|
||||
[env (hash)])
|
||||
(cond [(null? named-pats)
|
||||
(cond [(empty-named-pats? nps)
|
||||
(pat/enum-with-names pat nt-enums env)]
|
||||
[else
|
||||
(let ([cur (car named-pats)])
|
||||
(cond ([named? cur]
|
||||
(let ([cur (next-named-pats nps)])
|
||||
(cond [(named? cur)
|
||||
(let ([name (named-name cur)]
|
||||
[pat (named-val cur)])
|
||||
(map/enum
|
||||
|
|
@ -352,12 +429,47 @@
|
|||
(dep/enum
|
||||
(pat/enum-with-names pat nt-enums env)
|
||||
(λ (term)
|
||||
(rec (cdr named-pats)
|
||||
(rec (rest-named-pats nps)
|
||||
(hash-set env
|
||||
name
|
||||
term)))))))
|
||||
[else (error/enum 'unimplemented
|
||||
(unimplemented-msg cur))]))])))
|
||||
term))))))]
|
||||
[(mismatch? 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)
|
||||
(let loop ([pat pat])
|
||||
|
|
@ -375,7 +487,7 @@
|
|||
[`boolean bool/enum]
|
||||
[`variable var/enum]
|
||||
[`(variable-except ,s ...)
|
||||
(apply except/enum var/enum s)]
|
||||
(except/enum var/enum s)]
|
||||
[`(variable-prefix ,s)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var-prefix")]
|
||||
|
|
@ -386,9 +498,9 @@
|
|||
[`(nt ,id)
|
||||
(hash-ref nt-enums id)]
|
||||
[`(name ,n ,pat)
|
||||
(const/enum (name n))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(error/enum 'unimplemented "mismatch-name")]
|
||||
(const/enum (name-ref n))]
|
||||
[`(mismatch-name ,n ,pat)
|
||||
(const/enum (mismatch-ref n))]
|
||||
[`(in-hole ,p1 ,p2) ;; untested
|
||||
(map/enum
|
||||
(λ (ts)
|
||||
|
|
@ -408,33 +520,29 @@
|
|||
(unsupported/enum pat)]
|
||||
[`(list ,sub-pats ...)
|
||||
;; enum-list
|
||||
(map/enum
|
||||
flatten-1
|
||||
identity
|
||||
(list/enum
|
||||
(map
|
||||
(λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat #f #f)
|
||||
(map/enum
|
||||
cdr
|
||||
(λ (ts)
|
||||
(cons (length ts)
|
||||
ts))
|
||||
(dep/enum
|
||||
nats
|
||||
(λ (n)
|
||||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[else (map/enum
|
||||
list
|
||||
car
|
||||
(loop sub-pat))]))
|
||||
sub-pats)))]
|
||||
(list/enum
|
||||
(map
|
||||
(λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat #f #f)
|
||||
(map/enum
|
||||
(λ (n-ts)
|
||||
(repeat (car n-ts)
|
||||
(cdr n-ts)))
|
||||
(λ (rep)
|
||||
(cons (repeat-n rep)
|
||||
(repeat-terms rep)))
|
||||
(dep/enum
|
||||
nats
|
||||
(λ (n)
|
||||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[else (loop sub-pat)]))
|
||||
sub-pats))]
|
||||
[(? (compose not pair?))
|
||||
(const/enum pat)])))
|
||||
|
||||
|
|
@ -475,10 +583,9 @@
|
|||
(λ (n) (- (- n) 1))
|
||||
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
|
||||
(sum/enum natural/enum
|
||||
integer/enum
|
||||
(sum/enum integer/enum
|
||||
real/enum))
|
||||
|
||||
(define bool/enum
|
||||
|
|
@ -499,10 +606,27 @@
|
|||
(define (to-term aug)
|
||||
(cond [(named? aug)
|
||||
(rep-name aug)]
|
||||
[(mismatch? aug)
|
||||
(rep-mismatches aug)]
|
||||
[(decomposition? aug)
|
||||
(plug-hole aug)]
|
||||
[(repeat? aug)
|
||||
(map-repeat to-term
|
||||
aug)]
|
||||
[(list? aug)
|
||||
(expand-repeats
|
||||
(map to-term 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)
|
||||
(to-term
|
||||
(let* ([n (named-name s)]
|
||||
|
|
@ -510,10 +634,10 @@
|
|||
[val (named-t-val v)]
|
||||
[term (named-t-term v)])
|
||||
(let loop ([term term])
|
||||
(cond [(and (name? term)
|
||||
(equal? (name-name term) n))
|
||||
(cond [(and (name-ref? term)
|
||||
(equal? (name-ref-name term) n))
|
||||
val]
|
||||
[(cons? term)
|
||||
[(list? term)
|
||||
(map loop term)]
|
||||
[(named? term)
|
||||
(map-named loop
|
||||
|
|
@ -521,13 +645,48 @@
|
|||
[(decomposition? term)
|
||||
(map-decomp loop
|
||||
term)]
|
||||
[(mismatch? term)
|
||||
(map-mismatch loop
|
||||
term)]
|
||||
[(repeat? term)
|
||||
(map-repeat loop
|
||||
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)
|
||||
(to-term
|
||||
(let loop ([ctx ctx])
|
||||
(cond [(hole? ctx) term]
|
||||
[(cons? ctx) (map loop ctx)]
|
||||
[(list? ctx) (map loop ctx)]
|
||||
[(named? )])
|
||||
(match
|
||||
ctx
|
||||
|
|
@ -544,7 +703,18 @@
|
|||
|
||||
(define (map-named f n)
|
||||
(let ([v (named-val n)])
|
||||
(named (named-name n)
|
||||
(named-t
|
||||
(named-t-val v)
|
||||
(f (named-t-term v))))))
|
||||
(named (named-name n)
|
||||
(named-t
|
||||
(named-t-val 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))))
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@
|
|||
to-list
|
||||
take/enum
|
||||
drop/enum
|
||||
foldl-enum
|
||||
fold-enum
|
||||
display-enum
|
||||
|
||||
nats
|
||||
|
|
@ -80,28 +80,24 @@
|
|||
(λ (x) (encode e x))))
|
||||
|
||||
;; except/enum : enum a, a -> enum a
|
||||
(define except/enum
|
||||
(case-lambda
|
||||
[(e) e]
|
||||
[(e a . rest)
|
||||
(let ([excepted
|
||||
(begin
|
||||
(unless (> (size e) 0)
|
||||
(error 'empty-enum))
|
||||
(with-handlers ([exn:fail? (λ (_)
|
||||
(apply except/enum e rest))])
|
||||
(let ([m (encode e a)])
|
||||
(enum (- (size e) 1)
|
||||
(λ (n)
|
||||
(if (< n m)
|
||||
(decode e n)
|
||||
(decode e (+ n 1))))
|
||||
(λ (x)
|
||||
(let ([n (encode e x)])
|
||||
(cond [(< n m) n]
|
||||
[(> n m) (- n 1)]
|
||||
[else (error 'excepted)])))))))])
|
||||
(apply except/enum excepted rest))]))
|
||||
(define (except/enum e excepts)
|
||||
(cond [(empty? excepts) e]
|
||||
[else
|
||||
(except/enum
|
||||
(begin
|
||||
(with-handlers ([exn:fail? (λ (_) e)])
|
||||
(let ([m (encode e (car excepts))])
|
||||
(enum (- (size e) 1)
|
||||
(λ (n)
|
||||
(if (< n m)
|
||||
(decode e n)
|
||||
(decode e (+ n 1))))
|
||||
(λ (x)
|
||||
(let ([n (encode e x)])
|
||||
(cond [(< n m) n]
|
||||
[(> n m) (- n 1)]
|
||||
[else (error 'excepted)])))))))
|
||||
(cdr excepts))]))
|
||||
|
||||
;; to-list : enum a -> listof a
|
||||
;; better be finite
|
||||
|
|
@ -141,11 +137,6 @@
|
|||
(λ (x)
|
||||
(- (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
|
||||
(define (display-enum e n)
|
||||
(for ([i (range n)])
|
||||
|
|
@ -509,7 +500,32 @@
|
|||
[else ;; both infinite, same as prod/enum
|
||||
(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
|
||||
;; nats of course
|
||||
|
|
@ -585,305 +601,312 @@
|
|||
|
||||
|
||||
(module+
|
||||
test
|
||||
(require rackunit)
|
||||
(provide check-bijection?)
|
||||
(define confidence 1000)
|
||||
(define nums (build-list confidence identity))
|
||||
(define-simple-check (check-bijection? e)
|
||||
(let ([nums (build-list (if (<= (enum-size e) confidence)
|
||||
(enum-size e)
|
||||
confidence)
|
||||
identity)])
|
||||
(andmap =
|
||||
nums
|
||||
(map (λ (n)
|
||||
(encode e (decode e n)))
|
||||
nums))))
|
||||
test
|
||||
(require rackunit)
|
||||
(provide check-bijection?)
|
||||
(define confidence 1000)
|
||||
(define nums (build-list confidence identity))
|
||||
(define-simple-check (check-bijection? e)
|
||||
(let ([nums (build-list (if (<= (enum-size e) confidence)
|
||||
(enum-size e)
|
||||
confidence)
|
||||
identity)])
|
||||
(andmap =
|
||||
nums
|
||||
(map (λ (n)
|
||||
(encode e (decode e n)))
|
||||
nums))))
|
||||
|
||||
;; const/enum tests
|
||||
(let ([e (const/enum 17)])
|
||||
(test-begin
|
||||
(check-eq? (decode e 0) 17)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode e 1)))
|
||||
(check-eq? (encode e 17) 0)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(encode e 0)))
|
||||
(check-bijection? e)))
|
||||
;; const/enum tests
|
||||
(let ([e (const/enum 17)])
|
||||
(test-begin
|
||||
(check-eq? (decode e 0) 17)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode e 1)))
|
||||
(check-eq? (encode e 17) 0)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(encode e 0)))
|
||||
(check-bijection? e)))
|
||||
|
||||
;; from-list/enum tests
|
||||
(let ([e (from-list/enum '(5 4 1 8))])
|
||||
(test-begin
|
||||
(check-eq? (decode e 0) 5)
|
||||
(check-eq? (decode e 3) 8)
|
||||
(check-exn exn:fail?
|
||||
(λ () (decode e 4)))
|
||||
(check-eq? (encode e 5) 0)
|
||||
(check-eq? (encode e 8) 3)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(encode e 17)))
|
||||
(check-bijection? e)))
|
||||
;; from-list/enum tests
|
||||
(let ([e (from-list/enum '(5 4 1 8))])
|
||||
(test-begin
|
||||
(check-eq? (decode e 0) 5)
|
||||
(check-eq? (decode e 3) 8)
|
||||
(check-exn exn:fail?
|
||||
(λ () (decode e 4)))
|
||||
(check-eq? (encode e 5) 0)
|
||||
(check-eq? (encode e 8) 3)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(encode e 17)))
|
||||
(check-bijection? e)))
|
||||
|
||||
;; map test
|
||||
(define nats+1 (nats+/enum 1))
|
||||
;; map test
|
||||
(define nats+1 (nats+/enum 1))
|
||||
|
||||
(test-begin
|
||||
(check-equal? (size nats+1) +inf.f)
|
||||
(check-equal? (decode nats+1 0) 1)
|
||||
(check-equal? (decode nats+1 1) 2)
|
||||
(check-bijection? nats+1))
|
||||
;; encode check
|
||||
(test-begin
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode nats -1))))
|
||||
(test-begin
|
||||
(check-equal? (size nats+1) +inf.f)
|
||||
(check-equal? (decode nats+1 0) 1)
|
||||
(check-equal? (decode nats+1 1) 2)
|
||||
(check-bijection? nats+1))
|
||||
;; encode check
|
||||
(test-begin
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode nats -1))))
|
||||
|
||||
;; ints checks
|
||||
(test-begin
|
||||
(check-eq? (decode ints 0) 0) ; 0 -> 0
|
||||
(check-eq? (decode ints 1) 1) ; 1 -> 1
|
||||
(check-eq? (decode ints 2) -1) ; 2 -> 1
|
||||
(check-eq? (encode ints 0) 0)
|
||||
(check-eq? (encode ints 1) 1)
|
||||
(check-eq? (encode ints -1) 2)
|
||||
(check-bijection? ints)) ; -1 -> 2, -3 -> 4
|
||||
;; ints checks
|
||||
(test-begin
|
||||
(check-eq? (decode ints 0) 0) ; 0 -> 0
|
||||
(check-eq? (decode ints 1) 1) ; 1 -> 1
|
||||
(check-eq? (decode ints 2) -1) ; 2 -> 1
|
||||
(check-eq? (encode ints 0) 0)
|
||||
(check-eq? (encode ints 1) 1)
|
||||
(check-eq? (encode ints -1) 2)
|
||||
(check-bijection? ints)) ; -1 -> 2, -3 -> 4
|
||||
|
||||
;; sum tests
|
||||
(test-begin
|
||||
(let ([bool-or-num (sum/enum bools
|
||||
(from-list/enum '(0 1 2)))]
|
||||
[bool-or-nat (sum/enum bools
|
||||
nats)]
|
||||
[nat-or-bool (sum/enum nats
|
||||
bools)]
|
||||
[odd-or-even (sum/enum evens
|
||||
odds)])
|
||||
(check-equal? (enum-size bool-or-num)
|
||||
5)
|
||||
(check-equal? (decode bool-or-num 0) #t)
|
||||
(check-equal? (decode bool-or-num 1) #f)
|
||||
(check-equal? (decode bool-or-num 2) 0)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode bool-or-num 5)))
|
||||
(check-equal? (encode bool-or-num #f) 1)
|
||||
(check-equal? (encode bool-or-num 2) 4)
|
||||
(check-bijection? bool-or-num)
|
||||
;; sum tests
|
||||
(test-begin
|
||||
(let ([bool-or-num (sum/enum bools
|
||||
(from-list/enum '(0 1 2)))]
|
||||
[bool-or-nat (sum/enum bools
|
||||
nats)]
|
||||
[nat-or-bool (sum/enum nats
|
||||
bools)]
|
||||
[odd-or-even (sum/enum evens
|
||||
odds)])
|
||||
(check-equal? (enum-size bool-or-num)
|
||||
5)
|
||||
(check-equal? (decode bool-or-num 0) #t)
|
||||
(check-equal? (decode bool-or-num 1) #f)
|
||||
(check-equal? (decode bool-or-num 2) 0)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode bool-or-num 5)))
|
||||
(check-equal? (encode bool-or-num #f) 1)
|
||||
(check-equal? (encode bool-or-num 2) 4)
|
||||
(check-bijection? bool-or-num)
|
||||
|
||||
(check-equal? (enum-size bool-or-nat)
|
||||
+inf.f)
|
||||
(check-equal? (decode bool-or-nat 0) #t)
|
||||
(check-equal? (decode bool-or-nat 2) 0)
|
||||
(check-bijection? bool-or-nat)
|
||||
(check-equal? (enum-size bool-or-nat)
|
||||
+inf.f)
|
||||
(check-equal? (decode bool-or-nat 0) #t)
|
||||
(check-equal? (decode bool-or-nat 2) 0)
|
||||
(check-bijection? bool-or-nat)
|
||||
|
||||
(check-equal? (encode bool-or-num #f) 1)
|
||||
(check-equal? (encode bool-or-num 2) 4)
|
||||
(check-equal? (encode bool-or-num #f) 1)
|
||||
(check-equal? (encode bool-or-num 2) 4)
|
||||
|
||||
(check-equal? (enum-size odd-or-even)
|
||||
+inf.f)
|
||||
(check-equal? (decode odd-or-even 0) 0)
|
||||
(check-equal? (decode odd-or-even 1) 1)
|
||||
(check-equal? (decode odd-or-even 2) 2)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode odd-or-even -1)))
|
||||
(check-equal? (encode odd-or-even 0) 0)
|
||||
(check-equal? (encode odd-or-even 1) 1)
|
||||
(check-equal? (encode odd-or-even 2) 2)
|
||||
(check-equal? (encode odd-or-even 3) 3)
|
||||
(check-bijection? odd-or-even)))
|
||||
(check-equal? (enum-size odd-or-even)
|
||||
+inf.f)
|
||||
(check-equal? (decode odd-or-even 0) 0)
|
||||
(check-equal? (decode odd-or-even 1) 1)
|
||||
(check-equal? (decode odd-or-even 2) 2)
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(decode odd-or-even -1)))
|
||||
(check-equal? (encode odd-or-even 0) 0)
|
||||
(check-equal? (encode odd-or-even 1) 1)
|
||||
(check-equal? (encode odd-or-even 2) 2)
|
||||
(check-equal? (encode odd-or-even 3) 3)
|
||||
(check-bijection? odd-or-even)))
|
||||
|
||||
;; prod/enum tests
|
||||
(define bool*bool (prod/enum bools bools))
|
||||
(define 1*b (prod/enum (const/enum 1) bools))
|
||||
(define bool*nats (prod/enum bools nats))
|
||||
(define nats*bool (prod/enum nats bools))
|
||||
(define nats*nats (prod/enum nats nats))
|
||||
(define ns-equal? (λ (ns ms)
|
||||
(and (= (car ns)
|
||||
(car ms))
|
||||
(= (cdr ns)
|
||||
(cdr ms)))))
|
||||
;; prod/enum tests
|
||||
(define bool*bool (prod/enum bools bools))
|
||||
(define 1*b (prod/enum (const/enum 1) bools))
|
||||
(define bool*nats (prod/enum bools nats))
|
||||
(define nats*bool (prod/enum nats bools))
|
||||
(define nats*nats (prod/enum nats nats))
|
||||
(define ns-equal? (λ (ns ms)
|
||||
(and (= (car ns)
|
||||
(car ms))
|
||||
(= (cdr ns)
|
||||
(cdr ms)))))
|
||||
|
||||
;; prod tests
|
||||
(test-begin
|
||||
;; prod tests
|
||||
(test-begin
|
||||
|
||||
(check-equal? (size 1*b) 2)
|
||||
(check-equal? (decode 1*b 0) (cons 1 #t))
|
||||
(check-equal? (decode 1*b 1) (cons 1 #f))
|
||||
(check-bijection? 1*b)
|
||||
(check-equal? (enum-size bool*bool) 4)
|
||||
(check-equal? (decode bool*bool 0)
|
||||
(cons #t #t))
|
||||
(check-equal? (decode bool*bool 1)
|
||||
(cons #t #f))
|
||||
(check-equal? (decode bool*bool 2)
|
||||
(cons #f #t))
|
||||
(check-equal? (decode bool*bool 3)
|
||||
(cons #f #f))
|
||||
(check-bijection? bool*bool)
|
||||
(check-equal? (size 1*b) 2)
|
||||
(check-equal? (decode 1*b 0) (cons 1 #t))
|
||||
(check-equal? (decode 1*b 1) (cons 1 #f))
|
||||
(check-bijection? 1*b)
|
||||
(check-equal? (enum-size bool*bool) 4)
|
||||
(check-equal? (decode bool*bool 0)
|
||||
(cons #t #t))
|
||||
(check-equal? (decode bool*bool 1)
|
||||
(cons #t #f))
|
||||
(check-equal? (decode bool*bool 2)
|
||||
(cons #f #t))
|
||||
(check-equal? (decode bool*bool 3)
|
||||
(cons #f #f))
|
||||
(check-bijection? bool*bool)
|
||||
|
||||
(check-equal? (enum-size bool*nats) +inf.f)
|
||||
(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-equal? (enum-size bool*nats) +inf.f)
|
||||
(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-equal? (enum-size nats*bool) +inf.f)
|
||||
(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-equal? (enum-size nats*bool) +inf.f)
|
||||
(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-equal? (enum-size nats*nats) +inf.f)
|
||||
(check ns-equal?
|
||||
(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))
|
||||
(check-equal? (enum-size nats*nats) +inf.f)
|
||||
(check ns-equal?
|
||||
(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))
|
||||
|
||||
|
||||
;; dep/enum tests
|
||||
(define (up-to n)
|
||||
(take/enum nats (+ n 1)))
|
||||
;; dep/enum tests
|
||||
(define (up-to n)
|
||||
(take/enum nats (+ n 1)))
|
||||
|
||||
(define 3-up
|
||||
(dep/enum
|
||||
(from-list/enum '(0 1 2))
|
||||
up-to))
|
||||
(define 3-up
|
||||
(dep/enum
|
||||
(from-list/enum '(0 1 2))
|
||||
up-to))
|
||||
|
||||
(define from-3
|
||||
(dep/enum
|
||||
(from-list/enum '(0 1 2))
|
||||
nats+/enum))
|
||||
(define from-3
|
||||
(dep/enum
|
||||
(from-list/enum '(0 1 2))
|
||||
nats+/enum))
|
||||
|
||||
(define nats-to
|
||||
(dep/enum nats up-to))
|
||||
(define nats-to
|
||||
(dep/enum nats up-to))
|
||||
|
||||
(define nats-up
|
||||
(dep/enum nats nats+/enum))
|
||||
(define nats-up
|
||||
(dep/enum nats nats+/enum))
|
||||
|
||||
(test-begin
|
||||
(check-equal? (size 3-up) 6)
|
||||
(check-equal? (decode 3-up 0) (cons 0 0))
|
||||
(check-equal? (decode 3-up 1) (cons 1 0))
|
||||
(check-equal? (decode 3-up 2) (cons 1 1))
|
||||
(check-equal? (decode 3-up 3) (cons 2 0))
|
||||
(check-equal? (decode 3-up 4) (cons 2 1))
|
||||
(check-equal? (decode 3-up 5) (cons 2 2))
|
||||
(check-bijection? 3-up)
|
||||
(test-begin
|
||||
(check-equal? (size 3-up) 6)
|
||||
(check-equal? (decode 3-up 0) (cons 0 0))
|
||||
(check-equal? (decode 3-up 1) (cons 1 0))
|
||||
(check-equal? (decode 3-up 2) (cons 1 1))
|
||||
(check-equal? (decode 3-up 3) (cons 2 0))
|
||||
(check-equal? (decode 3-up 4) (cons 2 1))
|
||||
(check-equal? (decode 3-up 5) (cons 2 2))
|
||||
(check-bijection? 3-up)
|
||||
|
||||
(check-equal? (size from-3) +inf.f)
|
||||
(check-equal? (decode from-3 0) (cons 0 0))
|
||||
(check-equal? (decode from-3 1) (cons 1 1))
|
||||
(check-equal? (decode from-3 2) (cons 2 2))
|
||||
(check-equal? (decode from-3 3) (cons 0 1))
|
||||
(check-equal? (decode from-3 4) (cons 1 2))
|
||||
(check-equal? (decode from-3 5) (cons 2 3))
|
||||
(check-equal? (decode from-3 6) (cons 0 2))
|
||||
(check-bijection? from-3)
|
||||
(check-equal? (size from-3) +inf.f)
|
||||
(check-equal? (decode from-3 0) (cons 0 0))
|
||||
(check-equal? (decode from-3 1) (cons 1 1))
|
||||
(check-equal? (decode from-3 2) (cons 2 2))
|
||||
(check-equal? (decode from-3 3) (cons 0 1))
|
||||
(check-equal? (decode from-3 4) (cons 1 2))
|
||||
(check-equal? (decode from-3 5) (cons 2 3))
|
||||
(check-equal? (decode from-3 6) (cons 0 2))
|
||||
(check-bijection? from-3)
|
||||
|
||||
(check-equal? (size nats-to) +inf.f)
|
||||
(check-equal? (decode nats-to 0) (cons 0 0))
|
||||
(check-equal? (decode nats-to 1) (cons 1 0))
|
||||
(check-equal? (decode nats-to 2) (cons 1 1))
|
||||
(check-equal? (decode nats-to 3) (cons 2 0))
|
||||
(check-equal? (decode nats-to 4) (cons 2 1))
|
||||
(check-equal? (decode nats-to 5) (cons 2 2))
|
||||
(check-equal? (decode nats-to 6) (cons 3 0))
|
||||
(check-bijection? nats-to)
|
||||
(check-equal? (size nats-to) +inf.f)
|
||||
(check-equal? (decode nats-to 0) (cons 0 0))
|
||||
(check-equal? (decode nats-to 1) (cons 1 0))
|
||||
(check-equal? (decode nats-to 2) (cons 1 1))
|
||||
(check-equal? (decode nats-to 3) (cons 2 0))
|
||||
(check-equal? (decode nats-to 4) (cons 2 1))
|
||||
(check-equal? (decode nats-to 5) (cons 2 2))
|
||||
(check-equal? (decode nats-to 6) (cons 3 0))
|
||||
(check-bijection? nats-to)
|
||||
|
||||
(check-equal? (size nats-up) +inf.f)
|
||||
(check-equal? (decode nats-up 0) (cons 0 0))
|
||||
(check-equal? (decode nats-up 1) (cons 0 1))
|
||||
(check-equal? (decode nats-up 2) (cons 1 1))
|
||||
(check-equal? (decode nats-up 3) (cons 0 2))
|
||||
(check-equal? (decode nats-up 4) (cons 1 2))
|
||||
(check-equal? (decode nats-up 5) (cons 2 2))
|
||||
(check-equal? (decode nats-up 6) (cons 0 3))
|
||||
(check-equal? (decode nats-up 7) (cons 1 3))
|
||||
(check-equal? (size nats-up) +inf.f)
|
||||
(check-equal? (decode nats-up 0) (cons 0 0))
|
||||
(check-equal? (decode nats-up 1) (cons 0 1))
|
||||
(check-equal? (decode nats-up 2) (cons 1 1))
|
||||
(check-equal? (decode nats-up 3) (cons 0 2))
|
||||
(check-equal? (decode nats-up 4) (cons 1 2))
|
||||
(check-equal? (decode nats-up 5) (cons 2 2))
|
||||
(check-equal? (decode nats-up 6) (cons 0 3))
|
||||
(check-equal? (decode nats-up 7) (cons 1 3))
|
||||
|
||||
(check-bijection? nats-up))
|
||||
(check-bijection? nats-up))
|
||||
|
||||
;; dep2/enum tests
|
||||
;; same as dep unless the right side is finite
|
||||
(define 3-up-2
|
||||
(dep2/enum
|
||||
(from-list/enum '(0 1 2))
|
||||
up-to))
|
||||
;; dep2/enum tests
|
||||
;; same as dep unless the right side is finite
|
||||
(define 3-up-2
|
||||
(dep2/enum
|
||||
(from-list/enum '(0 1 2))
|
||||
up-to))
|
||||
|
||||
(define nats-to-2
|
||||
(dep2/enum nats up-to))
|
||||
(define nats-to-2
|
||||
(dep2/enum nats up-to))
|
||||
|
||||
|
||||
(test-begin
|
||||
(check-equal? (size 3-up-2) 6)
|
||||
(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 2) (cons 1 1))
|
||||
(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 5) (cons 2 2))
|
||||
(check-bijection? 3-up-2)
|
||||
(test-begin
|
||||
(check-equal? (size 3-up-2) 6)
|
||||
(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 2) (cons 1 1))
|
||||
(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 5) (cons 2 2))
|
||||
(check-bijection? 3-up-2)
|
||||
|
||||
(check-equal? (size nats-to-2) +inf.f)
|
||||
(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 2) (cons 1 1))
|
||||
(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 5) (cons 2 2))
|
||||
(check-equal? (decode nats-to-2 6) (cons 3 0))
|
||||
(check-bijection? nats-to-2)
|
||||
)
|
||||
(check-equal? (size nats-to-2) +inf.f)
|
||||
(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 2) (cons 1 1))
|
||||
(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 5) (cons 2 2))
|
||||
(check-equal? (decode nats-to-2 6) (cons 3 0))
|
||||
(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
|
||||
(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))
|
||||
;; to-list test
|
||||
(test-begin
|
||||
(check-equal? (to-list (up-to 3))
|
||||
'(0 1 2 3)))
|
||||
|
||||
;; to-list, foldl test
|
||||
(test-begin
|
||||
(check-equal? (to-list (up-to 3))
|
||||
'(0 1 2 3))
|
||||
(check-equal? (foldl-enum cons '() (up-to 3))
|
||||
'(3 2 1 0)))
|
||||
;; except/enum test
|
||||
(define not-3 (except/enum nats '(3)))
|
||||
(test-begin
|
||||
(check-equal? (decode not-3 0) 0)
|
||||
(check-equal? (decode not-3 3) 4)
|
||||
(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
|
||||
(define not-3 (except/enum nats 3))
|
||||
(test-begin
|
||||
(check-equal? (decode not-3 0) 0)
|
||||
(check-equal? (decode not-3 3) 4))
|
||||
(define not-a (except/enum nats 'a))
|
||||
(test-begin
|
||||
(check-equal? (decode not-a 0) 0)))
|
||||
;; fold-enum tests
|
||||
(define complicated
|
||||
(fold-enum
|
||||
(λ (excepts n)
|
||||
(except/enum (up-to n) excepts))
|
||||
'(2 4 6)))
|
||||
(check-bijection? complicated))
|
||||
|
|
|
|||
|
|
@ -63,4 +63,17 @@
|
|||
hole)
|
||||
(x (variable-except λ + if0)))
|
||||
|
||||
(try-it 100 λv e)
|
||||
(try-it 100 λv v)
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user