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

Fix bugs in tuple reconstruction and slice/e

Browse Source
This commit is contained in:
Max New 2014-05-01 22:41:50 -05:00 committed by Robby Findler
parent 91627bc895
commit 91c3a3a6d4
2 changed files with 74 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -62,6 +62,7 @@
nat/e nat/e
range/e range/e
slice/e
nat+/e nat+/e
;; Base type enumerators ;; Base type enumerators
@ -89,7 +90,7 @@
(if (and (< n (enum-size e)) (if (and (< n (enum-size e))
(>= n 0)) (>= n 0))
((enum-from e) n) ((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 ;; encode : enum a, a -> Nat
(define/contract (encode e a) (define/contract (encode e a)
@ -199,8 +200,8 @@
(define n (encode e x)) (define n (encode e x))
(unless (and (n . >= . lo) (unless (and (n . >= . lo)
(n . < . hi)) (n . < . hi))
(redex-error 'slice/e "attempted to encode an element removed by slice/e")) (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))) (n . - . lo))))
;; below/e ;; below/e
(define (below/e n) (define (below/e n)
@ -1029,9 +1030,8 @@
(loop xs -1 '())) (loop xs -1 '()))
(define (tuple-constructors infs fins) (define (tuple-constructors infs fins)
(define (get-size e-x) (size (car e-x))) (define inf?s (inf-slots (map cdr infs)
(define inf?s (inf-slots (map get-size infs) (map cdr fins)))
(map get-size fins)))
(define (decon xs) (define (decon xs)
(let loop ([xs xs] (let loop ([xs xs]
[inf-acc '()] [inf-acc '()]
@ -1105,39 +1105,40 @@
(define layer/es (define layer/es
(for/list ([prev-cur (in-list prev-cur-layers)]) (for/list ([prev-cur (in-list prev-cur-layers)])
(match prev-cur (match-define (cons (list-layer prev-max
[(cons (list-layer prev-max prev-tuple-max
prev-tuple-max prev-exhs
prev-exhs prev-inexhs)
prev-inexhs) (list-layer cur-max
(list-layer cur-max cur-tuple-max
cur-tuple-max cur-exhs
cur-exhs cur-inexhs))
cur-inexhs)) prev-cur)
(define-values (decon recon)
(tuple-constructors cur-inexhs cur-exhs))
(define k (length cur-inexhs)) (define-values (decon recon)
(define inexhs-lo (expt prev-tuple-max k)) (tuple-constructors cur-inexhs cur-exhs))
(define inexhs-hi (expt cur-tuple-max k))
(define inxh-tups (define k (length cur-inexhs))
(for/list ([_ cur-inexhs]) (define inexhs-lo (expt prev-tuple-max k))
nat/e)) (define inexhs-hi (expt cur-tuple-max k))
(define layer/e (define inxh-tups
(map/e (for/list ([_ cur-inexhs])
recon nat/e))
decon
(fin-cons/e (define layer/e
(slice/e (apply box-list/e inxh-tups) (map/e
inexhs-lo recon
(add1 inexhs-hi)) decon
(mixed-box-tuples/e (map car cur-exhs))))) (fin-cons/e
(list layer/e (slice/e (apply box-list/e inxh-tups)
cur-max inexhs-lo
prev-max inexhs-hi)
cur-tuple-max)]))) (mixed-box-tuples/e (map car (sort cur-exhs < #:key cdr))))))
(list layer/e
cur-max
prev-max
cur-tuple-max)))
(define (dec n) (define (dec n)
(let/ec return (let/ec return
@ -1150,7 +1151,6 @@
(when (n . < . max-index) (when (n . < . max-index)
(return (decode e (n . - . min-index))))])))) (return (decode e (n . - . min-index))))]))))
(define (enc tup) (define (enc tup)
(define m (apply max tup)) (define m (apply max tup))
(let/ec return (let/ec return
@ -1160,7 +1160,7 @@
_ _
min-index min-index
max-max) max-max)
(when (m . <= . max-max) (when (m . < . max-max)
(return (+ min-index (encode e tup))))])))) (return (+ min-index (encode e tup))))]))))
(enum (apply * (map size es)) (enum (apply * (map size es))
@ -1171,9 +1171,11 @@
(-> (listof number?) (-> (listof number?)
(listof number?) (listof number?)
any/c) any/c)
(define sorted-infs (sort infs <))
(define sorted-fins (sort fins <))
(reverse (reverse
(let loop ([inf-is infs] (let loop ([inf-is sorted-infs]
[fin-is fins] [fin-is sorted-fins]
[acc '()]) [acc '()])
(match* (inf-is fin-is) (match* (inf-is fin-is)
[('() '()) acc] [('() '()) acc]

51
pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt
View File

@ -142,16 +142,16 @@
(for/list ([i (in-range 31)]) (for/list ([i (in-range 31)])
i) i)
;; Please don't reformat this! ;; Please don't reformat this!
'("" a 0 #t () '("" a 0 #t ()
"a" b 1 #f (#t) "a" b 1 #f (#t)
"b" c 2 (#f) "aa" c 2 (#t #t)
"c" d 3 (#t #t) "b" d 3 (#f)
"d" 4 (#f #t) "ba" 4 (#f #t)
5 (#t #f) 5 (#t #t #t)
6 (#f #f) 6 (#f #t #t)
7 (#t #t #t) 7 (#t #f)
8 (#f #t #t) 8 (#f #f)
9 (#t #f #t))) 9 (#t #f #t)))
(check-bijection? multi-layered)) (check-bijection? multi-layered))
@ -293,15 +293,15 @@
(define n*2 (list/e nat/e (below/e 2))) (define n*2 (list/e nat/e (below/e 2)))
(check-range? n*2 0 1 '((0 0))) (check-range? n*2 0 1 '((0 0)))
(check-range? n*2 1 3 '((0 1) (1 0) (1 1))) (check-range? n*2 1 4 '((0 1) (1 0) (1 1)))
(check-range? n*2 3 5 '((2 0) (2 1))) (check-range? n*2 4 6 '((2 0) (2 1)))
(check-range? n*2 5 7 '((3 0) (3 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))) (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 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 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 '((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))) (define n*2*4 (list/e nat/e (below/e 2) (below/e 4)))
(check-range? n*2*4 0 1 '((0 0 0))) (check-range? n*2*4 0 1 '((0 0 0)))
@ -323,16 +323,17 @@
(3 0 1) (3 1 1) (3 0 1) (3 1 1)
(3 0 2) (3 1 2) (3 0 2) (3 1 2)
(3 0 3) (3 1 3))) (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 0 0) (4 0 1) (4 0 2) (4 0 3)
(4 1 0) (4 1 1) (4 1 2) (4 1 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 0 0) (5 0 1) (5 0 2) (5 0 3)
(5 1 0) (5 1 1) (5 1 2) (5 1 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 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 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 ;; multi-arg map/e test
(define sums/e (define sums/e
@ -467,6 +468,11 @@
(check-equal? (decode to-2 2) 2) (check-equal? (decode to-2 2) 2)
(check-bijection? to-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 ;; to-list test
(test-begin (test-begin
(check-equal? (to-list (up-to 3)) (check-equal? (to-list (up-to 3))
@ -486,14 +492,17 @@
(λ (excepts n) (λ (excepts n)
(apply except/e (up-to n) excepts)) (apply except/e (up-to n) excepts))
'(2 4 6))) '(2 4 6)))
(check-bijection? complicated) (test-begin
(check-bijection? complicated))
;; many/e tests ;; many/e tests
(define natss (define natss
(many/e nat/e)) (many/e nat/e))
(check-bijection? natss) (test-begin
(check-bijection? natss))
(define emptys/e (define emptys/e
(many/e empty/e)) (many/e empty/e))
(check-equal? (decode emptys/e 0) '()) (test-begin
(check-bijection? emptys/e) (check-equal? (decode emptys/e 0) '())
(check-bijection? emptys/e))