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

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

@ -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]

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

@ -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))