diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/enum.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/enum.rkt index 0ba943e85d..80f5c02244 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/enum.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/enum.rkt @@ -41,7 +41,7 @@ (λ (nt) (hash-set! l-enums (nt-name nt) - (with-handlers ([exn:fail? fail/enum]) + (with-handlers ([exn:fail? fail/e]) (enum-f (nt-rhs nt) l-enums)))) cur-lang)) @@ -53,29 +53,29 @@ enumerate-rhss) (enumerate-lang rec-lang (λ (rhs enums) - (thunk/enum +inf.f + (thunk/e +inf.f (λ () (enumerate-rhss rhs enums))))) (lang-enum l-enums))) (define (pat-enumerator l-enum pat) - (map/enum + (map/e to-term (λ (_) (error 'pat-enum "Enumerator is not a bijection")) - (pat/enum pat + (pat/e pat (lang-enum-enums l-enum)))) (define (enumerate-rhss rhss l-enums) - (apply sum/enum + (apply sum/e (map (λ (rhs) - (pat/enum (rhs-pattern rhs) + (pat/e (rhs-pattern rhs) l-enums)) rhss))) -(define (pat/enum pat l-enums) +(define (pat/e pat l-enums) (enum-names pat (sep-names pat) l-enums)) @@ -282,13 +282,13 @@ (let rec ([nps nps] [env (hash)]) (cond [(empty-named-pats? nps) - (pat/enum-with-names pat nt-enums env)] + (pat/e-with-names pat nt-enums env)] [else (let ([cur (next-named-pats nps)]) (cond [(named? cur) (let ([name (named-name cur)] [pat (named-val cur)]) - (map/enum + (map/e (λ (ts) (named name (named-t (car ts) @@ -303,8 +303,8 @@ "expected ~a, got ~a" name (named-name n)))) - (dep/enum - (pat/enum-with-names pat nt-enums env) + (dep/e + (pat/e-with-names pat nt-enums env) (λ (term) (rec (rest-named-pats nps) (hash-set env @@ -312,7 +312,7 @@ term))))))] [(mismatch? cur) (let ([name (mismatch-name cur)]) - (map/enum + (map/e (λ (ts) (mismatch name (mismatch-t (car ts) @@ -327,11 +327,11 @@ "expected ~a, got ~a" name (named-name n)))) - (dep/enum + (dep/e (fold-enum (λ (excepts pat) - (except/enum - (pat/enum-with-names pat + (except/e + (pat/e-with-names pat nt-enums (hash-set env (mismatch-name cur) @@ -345,45 +345,45 @@ terms))))))] [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]) (match-a-pattern pat [`any - (sum/enum - any/enum - (listof/enum any/enum))] - [`number num/enum] - [`string string/enum] - [`natural natural/enum] - [`integer integer/enum] - [`real real/enum] - [`boolean bool/enum] - [`variable var/enum] + (sum/e + any/e + (listof/e any/e))] + [`number num/e] + [`string string/e] + [`natural natural/e] + [`integer integer/e] + [`real real/e] + [`boolean bool/e] + [`variable var/e] [`(variable-except ,s ...) - (except/enum var/enum s)] + (except/e var/e s)] [`(variable-prefix ,s) ;; todo (error 'unimplemented "var-prefix")] [`variable-not-otherwise-mentioned (error 'unimplemented "var-not-mentioned")] ;; error [`hole - (const/enum the-hole)] + (const/e the-hole)] [`(nt ,id) (hash-ref nt-enums id)] [`(name ,n ,pat) - (const/enum (name-ref n))] + (const/e (name-ref n))] [`(mismatch-name ,n ,pat) - (const/enum (mismatch-ref n))] + (const/e (mismatch-ref n))] [`(in-hole ,p1 ,p2) ;; untested - (map/enum + (map/e (λ (ts) (decomposition (car ts) (cdr ts))) (λ (decomp) (cons (decomposition-ctx decomp) (decomposition-term decomp))) - (prod/enum + (prod/e (loop p1) (loop p2)))] [`(hide-hole ,p) @@ -394,22 +394,22 @@ (unsupported pat)] [`(list ,sub-pats ...) ;; enum-list - (list/enum + (list/e (map (λ (sub-pat) (match sub-pat [`(repeat ,pat #f #f) - (map/enum + (map/e (λ (n-ts) (repeat (car n-ts) (cdr n-ts))) (λ (rep) (cons (repeat-n rep) (repeat-terms rep))) - (dep/enum + (dep/e nats (λ (n) - (list/enum + (list/e (build-list n (const (loop pat)))))))] [`(repeat ,pat ,name #f) (error 'unimplemented "named-repeat")] @@ -418,7 +418,7 @@ [else (loop sub-pat)])) sub-pats))] [(? (compose not pair?)) - (const/enum pat)]))) + (const/e pat)]))) (define (flatten-1 xs) (append-map @@ -437,45 +437,45 @@ (nt-rhs (car nts))] [else (rec (cdr nts))]))) -(define natural/enum nats) +(define natural/e nats) -(define char/enum - (map/enum +(define char/e + (map/e integer->char char->integer - (range/enum #x61 #x7a))) + (range/e #x61 #x7a))) -(define string/enum - (map/enum +(define string/e + (map/e list->string string->list - (listof/enum char/enum))) + (listof/e char/e))) -(define integer/enum - (sum/enum nats - (map/enum (λ (n) (- (+ n 1))) +(define integer/e + (sum/e nats + (map/e (λ (n) (- (+ n 1))) (λ (n) (- (- n) 1)) nats))) -(define real/enum (from-list/enum '(0.5 1.5 123.112354))) -(define num/enum - (sum/enum integer/enum - real/enum)) +(define real/e (from-list/e '(0.5 1.5 123.112354))) +(define num/e + (sum/e integer/e + real/e)) -(define bool/enum - (from-list/enum '(#t #f))) +(define bool/e + (from-list/e '(#t #f))) -(define var/enum - (map/enum +(define var/e + (map/e (compose string->symbol list->string list) (compose car string->list symbol->string) - char/enum)) + char/e)) -(define any/enum - (sum/enum num/enum - string/enum - bool/enum - var/enum)) +(define any/e + (sum/e num/e + string/e + bool/e + var/e)) (define (to-term aug) (cond [(named? aug) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt index ac544c6954..e50e46fed6 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt @@ -9,30 +9,30 @@ size encode decode - empty/enum - const/enum - from-list/enum - sum/enum - prod/enum - dep/enum - dep2/enum ;; doesn't require size - map/enum - filter/enum ;; very bad, only use for small enums - except/enum - thunk/enum - listof/enum - list/enum - fail/enum + empty/e + const/e + from-list/e + sum/e + prod/e + dep/e + dep2/e ;; doesn't require size + map/e + filter/e ;; very bad, only use for small enums + except/e + thunk/e + listof/e + list/e + fail/e to-list - take/enum - drop/enum + take/e + drop/e fold-enum display-enum nats - range/enum - nats+/enum + range/e + nats+/e ) ;; an enum a is a struct of < Nat or +Inf, Nat -> a, a -> Nat > @@ -56,16 +56,16 @@ ((enum-to e) a)) ;; Helper functions -;; map/enum : (a -> b), (b -> a), enum a -> enum b -(define (map/enum f inv-f e) +;; map/e : (a -> b), (b -> a), enum a -> enum b +(define (map/e f inv-f e) (enum (size e) (compose f (enum-from e)) (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! ;; encode is not accurate right now! -(define (filter/enum e p) +(define (filter/e e p) (enum (size e) (λ (n) (let loop ([i 0] @@ -78,11 +78,11 @@ (loop (+ i 1) seen))))) (λ (x) (encode e x)))) -;; except/enum : enum a, a -> enum a -(define (except/enum e excepts) +;; except/e : enum a, a -> enum a +(define (except/e e excepts) (cond [(empty? excepts) e] [else - (except/enum + (except/e (begin (with-handlers ([exn:fail? (λ (_) e)]) (let ([m (encode e (car excepts))]) @@ -107,10 +107,10 @@ (build-list (size e) 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 ;; 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)) (<= n (size e))) (error 'too-big)) @@ -125,8 +125,8 @@ (error 'out-of-range)) k)))) -;; drop/enum : enum a, Nat -> enum a -(define (drop/enum e n) +;; drop/e : enum a, Nat -> enum a +(define (drop/e e n) (unless (or (infinite? (size e)) (<= n (size e))) (error 'too-big)) @@ -142,14 +142,14 @@ (display (decode e i)) (newline) (newline))) -(define empty/enum +(define empty/e (enum 0 (λ (n) (error 'empty)) (λ (x) (error 'empty)))) -(define (const/enum c) +(define (const/e c) (enum 1 (λ (n) c) @@ -158,11 +158,11 @@ 0 (error 'bad-val))))) -;; from-list/enum :: Listof a -> Gen a +;; from-list/e :: Listof a -> Gen a ;; input list should not contain duplicates -(define (from-list/enum l) +(define (from-list/e l) (if (empty? l) - empty/enum + empty/e (enum (length l) (λ (n) (list-ref l n)) @@ -179,7 +179,7 @@ (take-while (cdr l) pred))])) (define bools - (from-list/enum (list #t #f))) + (from-list/e (list #t #f))) (define nats (enum +inf.f identity @@ -199,7 +199,7 @@ (* 2 (abs n)))))) ;; sum :: enum a, enum b -> enum (a or b) -(define sum/enum +(define sum/e (case-lambda [(e) e] [(e1 e2) @@ -219,7 +219,7 @@ ((enum-to e2) x)))]) ((enum-to e1) x))))] [(not (infinite? (enum-size e2))) - (sum/enum e2 e1)] + (sum/e e2 e1)] [else ;; both infinite, interleave them (enum +inf.f (λ (n) @@ -233,7 +233,7 @@ 1))]) (* ((enum-to e1) x) 2))))])] [(a b c . rest) - (sum/enum a (apply sum/enum b c rest))])) + (sum/e a (apply sum/e b c rest))])) (define odds (enum +inf.f @@ -275,13 +275,13 @@ l))) ;; (n,m) -> (n+m)(n+m+1)/2 + n )) -;; prod/enum : enum a, enum b -> enum (a,b) -(define prod/enum +;; prod/e : enum a, enum b -> enum (a,b) +(define prod/e (case-lambda [(e) e] [(e1 e2) (cond [(or (= 0 (size e1)) - (= 0 (size e2))) empty/enum] + (= 0 (size e2))) empty/e] [(not (infinite? (enum-size e1))) (cond [(not (infinite? (enum-size e2))) (let ([size (* (enum-size e1) @@ -352,7 +352,12 @@ 2) l))))])] [(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 (define (tri n) @@ -370,8 +375,8 @@ 1)) 2))) -;; dep/enum : enum a (a -> enum b) -> enum (a, b) -(define (dep/enum e f) +;; dep/e : enum a (a -> enum b) -> enum (a, b) +(define (dep/e e f) (define (search-size sizes n) (define (loop cur) (let* ([lastSize (gvector-ref sizes (- cur 1))] @@ -394,7 +399,7 @@ s (loop (+ cur 1)))))) (if (= 0 (size e)) - empty/enum + empty/e (let ([first (size (f (decode e 0)))]) (cond [(not (infinite? first)) @@ -451,7 +456,7 @@ (λ (ab) (+ (* (size e) (encode (f (car ab)) (cdr ab))) (encode e (car ab)))))] - [else ;; both infinite, same as prod/enum + [else ;; both infinite, same as prod/e (enum +inf.f (λ (n) (let* ([k (floor-untri n)] @@ -496,11 +501,11 @@ [else (bin-search 0 (- size 1))]))) ;; dep2 : enum a (a -> enum b) -> enum (a,b) -(define (dep2/enum e f) - (cond [(= 0 (size e)) empty/enum] +(define (dep2/e e f) + (cond [(= 0 (size e)) empty/e] [(not (infinite? (size (f (decode e 0))))) ;; 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))]) (enum (if (infinite? (size e)) +inf.f @@ -560,94 +565,94 @@ (size (f (decode e i))))))) (encode (f (car ab)) (cdr ab)))))))] - [else ;; both infinite, same as prod/enum - (dep/enum e f)])) + [else ;; both infinite, same as prod/e + (dep/e e f)])) ;; fold-enum : ((listof a), b -> enum a), (listof b) -> enum (listof a) (define (fold-enum f l) - (map/enum + (map/e reverse reverse (let loop ([l l] - [acc (const/enum '())]) + [acc (const/e '())]) (cond [(empty? l) acc] [else (loop (cdr l) - (flip-dep/enum + (flip-dep/e 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 +;; flip-dep/e : enum a (a -> enum b) -> enum (b,a) +(define (flip-dep/e e f) + (map/e (λ (ab) (cons (cdr ab) (car ab))) (λ (ba) (cons (cdr ba) (car ba))) - (dep/enum e f))) + (dep/e e f))) ;; more utility enums ;; nats of course -(define (range/enum low high) +(define (range/e low high) (cond [(> low high) (error 'bad-range)] [(infinite? high) (if (infinite? low) ints - (map/enum + (map/e (λ (n) (+ n low)) (λ (n) (- n low)) nats))] [(infinite? low) - (map/enum + (map/e (λ (n) (- high n)) (λ (n) (+ high n)) nats)] [else - (map/enum (λ (n) (+ n low)) + (map/e (λ (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 -(define (thunk/enum s thunk) +;; thunk/e : Nat or +-Inf, ( -> enum a) -> enum a +(define (thunk/e s thunk) (enum s (λ (n) (decode (thunk) n)) (λ (x) (encode (thunk) x)))) -;; listof/enum : enum a -> enum (listof a) -(define (listof/enum e) - (thunk/enum +;; listof/e : enum a -> enum (listof a) +(define (listof/e e) + (thunk/e (if (= 0 (size e)) 0 +inf.f) (λ () - (sum/enum - (const/enum '()) - (prod/enum e (listof/enum e)))))) + (sum/e + (const/e '()) + (prod/e e (listof/e e)))))) -;; list/enum : listof (enum any) -> enum (listof any) -(define (list/enum es) - (apply prod/enum (append es `(,(const/enum '()))))) +;; list/e : listof (enum any) -> enum (listof any) +(define (list/e es) + (apply prod/e (append es `(,(const/e '()))))) -(define (nats+/enum n) - (map/enum (λ (k) +(define (nats+/e n) + (map/e (λ (k) (+ k n)) (λ (k) (- k n)) nats)) -;; fail/enum : exn -> enum () +;; fail/e : exn -> enum () ;; returns an enum that calls a thunk -(define (fail/enum e) +(define (fail/e e) (let ([t (λ (_) (raise e))]) @@ -672,8 +677,8 @@ (encode e (decode e n))) nums)))) - ;; const/enum tests - (let ([e (const/enum 17)]) + ;; const/e tests + (let ([e (const/e 17)]) (test-begin (check-eq? (decode e 0) 17) (check-exn exn:fail? @@ -685,8 +690,8 @@ (encode e 0))) (check-bijection? e))) - ;; from-list/enum tests - (let ([e (from-list/enum '(5 4 1 8))]) + ;; from-list/e tests + (let ([e (from-list/e '(5 4 1 8))]) (test-begin (check-eq? (decode e 0) 5) (check-eq? (decode e 3) 8) @@ -700,7 +705,7 @@ (check-bijection? e))) ;; map test - (define nats+1 (nats+/enum 1)) + (define nats+1 (nats+/e 1)) (test-begin (check-equal? (size nats+1) +inf.f) @@ -725,13 +730,13 @@ ;; sum tests (test-begin - (let ([bool-or-num (sum/enum bools - (from-list/enum '(0 1 2)))] - [bool-or-nat (sum/enum bools + (let ([bool-or-num (sum/e bools + (from-list/e '(0 1 2)))] + [bool-or-nat (sum/e bools nats)] - [nat-or-bool (sum/enum nats + [nat-or-bool (sum/e nats bools)] - [odd-or-even (sum/enum evens + [odd-or-even (sum/e evens odds)]) (check-equal? (enum-size bool-or-num) 5) @@ -768,12 +773,12 @@ (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)) + ;; prod/e tests + (define bool*bool (prod/e bools bools)) + (define 1*b (prod/e (const/e 1) bools)) + (define bool*nats (prod/e bools nats)) + (define nats*bool (prod/e nats bools)) + (define nats*nats (prod/e nats nats)) (define ns-equal? (λ (ns ms) (and (= (car ns) (car ms)) @@ -839,25 +844,25 @@ (check-bijection? nats*nats)) - ;; dep/enum tests + ;; dep/e tests (define (up-to n) - (take/enum nats (+ n 1))) + (take/e nats (+ n 1))) (define 3-up - (dep/enum - (from-list/enum '(0 1 2)) + (dep/e + (from-list/e '(0 1 2)) up-to)) (define from-3 - (dep/enum - (from-list/enum '(0 1 2)) - nats+/enum)) + (dep/e + (from-list/e '(0 1 2)) + nats+/e)) (define nats-to - (dep/enum nats up-to)) + (dep/e nats up-to)) (define nats-up - (dep/enum nats nats+/enum)) + (dep/e nats nats+/e)) (test-begin (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) 7) #f) - ;; depend/enum tests + ;; depend/e tests ;; same as dep unless the right side is finite (define 3-up-2 - (dep/enum - (from-list/enum '(0 1 2)) + (dep/e + (from-list/e '(0 1 2)) up-to)) (define nats-to-2 - (dep/enum nats up-to)) + (dep/e nats up-to)) (test-begin @@ -953,7 +958,7 @@ (check-equal? (decode nats-to-2 5) (cons 2 2)) (check-equal? (decode nats-to-2 6) (cons 3 0))) - ;; take/enum test + ;; take/e test (define to-2 (up-to 2)) (test-begin (check-equal? (size to-2) 3) @@ -967,13 +972,13 @@ (check-equal? (to-list (up-to 3)) '(0 1 2 3))) - ;; except/enum test - (define not-3 (except/enum nats '(3))) + ;; except/e test + (define not-3 (except/e 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))) + (define not-a (except/e nats '(a))) (test-begin (check-equal? (decode not-a 0) 0) (check-bijection? not-a)) @@ -982,6 +987,6 @@ (define complicated (fold-enum (λ (excepts n) - (except/enum (up-to n) excepts)) + (except/e (up-to n) excepts)) '(2 4 6))) (check-bijection? complicated))