diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt index 00a134138d..48e6146c8c 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt @@ -62,6 +62,7 @@ nat/e range/e + slice/e nat+/e ;; Base type enumerators @@ -89,7 +90,7 @@ (if (and (< n (enum-size e)) (>= n 0)) ((enum-from e) n) - (redex-error 'decode "Index into enumerator out of range"))) + (redex-error 'decode "Index into enumerator out of range. Tried to decode ~s in an enum of size ~s" n (size e)))) ;; encode : enum a, a -> Nat (define/contract (encode e a) @@ -199,8 +200,8 @@ (define n (encode e x)) (unless (and (n . >= . lo) (n . < . hi)) - (redex-error 'slice/e "attempted to encode an element removed by slice/e")) - n))) + (redex-error 'slice/e "attempted to encode an element removed by slice/e: ~s was excepted, originally ~s, but sliced between ~s and ~s" x n lo hi)) + (n . - . lo)))) ;; below/e (define (below/e n) @@ -1029,9 +1030,8 @@ (loop xs -1 '())) (define (tuple-constructors infs fins) - (define (get-size e-x) (size (car e-x))) - (define inf?s (inf-slots (map get-size infs) - (map get-size fins))) + (define inf?s (inf-slots (map cdr infs) + (map cdr fins))) (define (decon xs) (let loop ([xs xs] [inf-acc '()] @@ -1105,40 +1105,41 @@ (define layer/es (for/list ([prev-cur (in-list prev-cur-layers)]) - (match prev-cur - [(cons (list-layer prev-max - prev-tuple-max - prev-exhs - prev-inexhs) - (list-layer cur-max - cur-tuple-max - cur-exhs - cur-inexhs)) - (define-values (decon recon) - (tuple-constructors cur-inexhs cur-exhs)) + (match-define (cons (list-layer prev-max + prev-tuple-max + prev-exhs + prev-inexhs) + (list-layer cur-max + cur-tuple-max + cur-exhs + cur-inexhs)) + prev-cur) - (define k (length cur-inexhs)) - (define inexhs-lo (expt prev-tuple-max k)) - (define inexhs-hi (expt cur-tuple-max k)) + (define-values (decon recon) + (tuple-constructors cur-inexhs cur-exhs)) + + (define k (length cur-inexhs)) + (define inexhs-lo (expt prev-tuple-max k)) + (define inexhs-hi (expt cur-tuple-max k)) + + (define inxh-tups + (for/list ([_ cur-inexhs]) + nat/e)) + + (define layer/e + (map/e + recon + decon + (fin-cons/e + (slice/e (apply box-list/e inxh-tups) + inexhs-lo + inexhs-hi) + (mixed-box-tuples/e (map car (sort cur-exhs < #:key cdr)))))) + (list layer/e + cur-max + prev-max + cur-tuple-max))) - (define inxh-tups - (for/list ([_ cur-inexhs]) - nat/e)) - - (define layer/e - (map/e - recon - decon - (fin-cons/e - (slice/e (apply box-list/e inxh-tups) - inexhs-lo - (add1 inexhs-hi)) - (mixed-box-tuples/e (map car cur-exhs))))) - (list layer/e - cur-max - prev-max - cur-tuple-max)]))) - (define (dec n) (let/ec return (for ([layer (in-list layer/es)]) @@ -1149,7 +1150,6 @@ _) (when (n . < . max-index) (return (decode e (n . - . min-index))))])))) - (define (enc tup) (define m (apply max tup)) @@ -1160,7 +1160,7 @@ _ min-index max-max) - (when (m . <= . max-max) + (when (m . < . max-max) (return (+ min-index (encode e tup))))])))) (enum (apply * (map size es)) @@ -1171,9 +1171,11 @@ (-> (listof number?) (listof number?) any/c) + (define sorted-infs (sort infs <)) + (define sorted-fins (sort fins <)) (reverse - (let loop ([inf-is infs] - [fin-is fins] + (let loop ([inf-is sorted-infs] + [fin-is sorted-fins] [acc '()]) (match* (inf-is fin-is) [('() '()) acc] diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt b/pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt index 69d777dadc..55fdee4aaf 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt +++ b/pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt @@ -142,16 +142,16 @@ (for/list ([i (in-range 31)]) i) ;; Please don't reformat this! - '("" a 0 #t () - "a" b 1 #f (#t) - "b" c 2 (#f) - "c" d 3 (#t #t) - "d" 4 (#f #t) - 5 (#t #f) - 6 (#f #f) - 7 (#t #t #t) - 8 (#f #t #t) - 9 (#t #f #t))) + '("" a 0 #t () + "a" b 1 #f (#t) + "aa" c 2 (#t #t) + "b" d 3 (#f) + "ba" 4 (#f #t) + 5 (#t #t #t) + 6 (#f #t #t) + 7 (#t #f) + 8 (#f #f) + 9 (#t #f #t))) (check-bijection? multi-layered)) @@ -293,15 +293,15 @@ (define n*2 (list/e nat/e (below/e 2))) (check-range? n*2 0 1 '((0 0))) - (check-range? n*2 1 3 '((0 1) (1 0) (1 1))) - (check-range? n*2 3 5 '((2 0) (2 1))) - (check-range? n*2 5 7 '((3 0) (3 1))) + (check-range? n*2 1 4 '((0 1) (1 0) (1 1))) + (check-range? n*2 4 6 '((2 0) (2 1))) + (check-range? n*2 6 8 '((3 0) (3 1))) (define n*1*2 (list/e nat/e (below/e 1) (below/e 2))) (check-range? n*1*2 0 1 '((0 0 0))) (check-range? n*1*2 1 4 '((0 0 1) (1 0 0) (1 0 1))) (check-range? n*1*2 4 6 '((2 0 0) (2 0 1))) - (check-range? n*1*2 4 6 '((3 0 0) (3 0 1))) + (check-range? n*1*2 6 8 '((3 0 0) (3 0 1))) (define n*2*4 (list/e nat/e (below/e 2) (below/e 4))) (check-range? n*2*4 0 1 '((0 0 0))) @@ -323,16 +323,17 @@ (3 0 1) (3 1 1) (3 0 2) (3 1 2) (3 0 3) (3 1 3))) - (check-range? n*2*4 32 38 + (check-range? n*2*4 32 40 '((4 0 0) (4 0 1) (4 0 2) (4 0 3) (4 1 0) (4 1 1) (4 1 2) (4 1 3))) - (check-range? n*2*4 38 46 + (check-range? n*2*4 40 48 '((5 0 0) (5 0 1) (5 0 2) (5 0 3) (5 1 0) (5 1 1) (5 1 2) (5 1 3))) (check-bijection? (list/e bool/e (cons/e bool/e bool/e) (fin/e 'foo 'bar 'baz))) (check-bijection? (list/e nat/e string/e (many/e bool/e))) - (check-bijection? (list/e bool/e nat/e int/e string/e (cons/e bool/e bool/e)))) + (check-bijection? (list/e bool/e nat/e int/e string/e (cons/e bool/e bool/e))) + ) ;; multi-arg map/e test (define sums/e @@ -467,6 +468,11 @@ (check-equal? (decode to-2 2) 2) (check-bijection? to-2)) +;; slic/e test +(test-begin + (check-equal? (to-list (slice/e nat/e 3 5)) '(3 4)) + (check-bijection? (slice/e nat/e 3 5))) + ;; to-list test (test-begin (check-equal? (to-list (up-to 3)) @@ -486,14 +492,17 @@ (λ (excepts n) (apply except/e (up-to n) excepts)) '(2 4 6))) -(check-bijection? complicated) +(test-begin + (check-bijection? complicated)) ;; many/e tests (define natss (many/e nat/e)) -(check-bijection? natss) +(test-begin + (check-bijection? natss)) (define emptys/e (many/e empty/e)) -(check-equal? (decode emptys/e 0) '()) -(check-bijection? emptys/e) +(test-begin + (check-equal? (decode emptys/e 0) '()) + (check-bijection? emptys/e))