From 1e2c92bf86d94d10f0440d525a4d9d0ccb3872e7 Mon Sep 17 00:00:00 2001 From: Max New Date: Fri, 10 Oct 2014 17:08:55 -0400 Subject: [PATCH] Move back to old finite, infinite list/e (significantly faster) --- .../redex-lib/redex/private/enumerator.rkt | 113 +++++++++++++++++- .../redex/tests/enumerator-test.rkt | 65 ++-------- 2 files changed, 117 insertions(+), 61 deletions(-) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt index 07da877ab7..daf972bdbf 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/enumerator.rkt @@ -1059,8 +1059,9 @@ (cons (car fins) acc))])]))) (values decon recon)) -;; list/e : listof (enum any) -> enum (listof any) -(define (list/e . es) +;; Attempt at mixing finite and infinite pairing in a more principled way +;; Slower than using inf-fin-cons/e as in list/e +(define (inf-fin-fair-list/e . es) (define nat/es (for/list ([e (in-list es)]) (take/e nat/e (size e)))) @@ -1177,6 +1178,113 @@ rest-fis (cons #f acc))])])))) +(define (inf-fin-cons/e e1 e2) + (define s1 (size e1)) + (define s2 (size e2)) + (define fst-finite? (not (infinite? s1))) + (define fin-size + (cond [fst-finite? s1] + [else s2])) + (define (dec n) + (define-values (q r) + (quotient/remainder n fin-size)) + (define x1 (decode e1 (if fst-finite? r q))) + (define x2 (decode e2 (if fst-finite? q r))) + (cons x1 x2)) + (define/match (enc p) + [((cons x1 x2)) + (define n1 (encode e1 x1)) + (define n2 (encode e2 x2)) + (define q (if fst-finite? n2 n1)) + (define r (if fst-finite? n1 n2)) + (+ (* fin-size q) + r)]) + (enum (* s1 s2) dec enc)) + +(define (list/e . es) + (define l (length es)) + (cond + [(= l 0) (const/e '())] + [(= l 1) (map/e list car (car es))] + [(all-infinite? es) (apply box-list/e es)] + [(all-finite? es) (apply nested-cons-list/e es)] + [else + (define tagged-es + (for/list ([i (in-naturals)] + [e (in-list es)]) + (cons e i))) + (define-values (inf-eis fin-eis) + (partition (compose infinite? + size + car) + tagged-es)) + (define inf-es (map car inf-eis)) + (define inf-is (map cdr inf-eis)) + (define fin-es (map car fin-eis)) + (define fin-is (map cdr fin-eis)) + (define inf-slots + (reverse + (let loop ([inf-is inf-is] + [fin-is fin-is] + [acc '()]) + (match* (inf-is fin-is) + [('() '()) acc] + [((cons _ _) '()) + (append (for/list ([_ (in-list inf-is)]) #t) acc)] + [('() (cons _ _)) + (append (for/list ([_ (in-list fin-is)]) #f) acc)] + [((cons ii rest-iis) (cons fi rest-fis)) + (cond [(ii . < . fi) + (loop rest-iis + fin-is + (cons #t acc))] + [else + (loop inf-is + rest-fis + (cons #f acc))])])))) + (define/match (reconstruct infs-fins) + [((cons infs fins)) + (let loop ([infs infs] + [fins fins] + [inf?s inf-slots] + [acc '()]) + (match inf?s + ['() (reverse acc)] + [(cons inf? rest) + (cond [inf? + (loop (cdr infs) + fins + rest + (cons (car infs) acc))] + [else + (loop infs + (cdr fins) + rest + (cons (car fins) acc))])]))]) + (define (deconstruct xs) + (let loop ([xs xs] + [inf-acc '()] + [fin-acc '()] + [inf?s inf-slots]) + (match* (xs inf?s) + [('() '()) (cons (reverse inf-acc) + (reverse fin-acc))] + [((cons x rest-xs) (cons inf? rest-inf?s)) + (cond [inf? + (loop rest-xs + (cons x inf-acc) + fin-acc + rest-inf?s)] + [else + (loop rest-xs + inf-acc + (cons x fin-acc) + rest-inf?s)])]))) + (map/e reconstruct + deconstruct + (inf-fin-cons/e (apply list/e inf-es) + (apply list/e fin-es)))])) + (define (nested-cons-list/e . es) (define l (length es)) (define split-point (quotient l 2)) @@ -1188,7 +1296,6 @@ (cons left right)) (fin-cons/e (apply list/e left) (apply list/e right)))) - (define (all-infinite? es) (all-sizes-something? infinite? es)) 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 55fdee4aaf..69c9fb38df 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt +++ b/pkgs/redex-pkgs/redex-test/redex/tests/enumerator-test.rkt @@ -144,13 +144,13 @@ ;; Please don't reformat this! '("" 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) + "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))) (check-bijection? multi-layered)) @@ -284,57 +284,6 @@ (define (below/e n) (take/e nat/e n)) -;; mixed finite/infinite list/e tests -(test-begin - - (check-equal? - (to-list (list/e (below/e 3) (below/e 3) (below/e 3))) - (to-list (take/e (list/e nat/e nat/e nat/e) 27))) - - (define n*2 (list/e nat/e (below/e 2))) - (check-range? n*2 0 1 '((0 0))) - (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 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))) - (check-range? n*2*4 1 8 '((0 0 1) (0 1 1) (0 1 0) - (1 0 0) (1 0 1) (1 1 0) (1 1 1))) - (check-range? n*2*4 8 18 ;; (8 previous . + . (2 magnitude of exhausted enums - ;; . * . (9 3^(number left) . - . 4 2^(number left))) - - '((0 0 2) (0 1 2) - (1 0 2) (1 1 2) - (2 0 0) (2 1 0) - (2 0 1) (2 1 1) - (2 0 2) (2 1 2))) - (check-range? n*2*4 18 32 ;; 18 + (2 * (4^2 - 3^2)) - '((0 0 3) (0 1 3) - (1 0 3) (1 1 3) - (2 0 3) (2 1 3) - (3 0 0) (3 1 0) - (3 0 1) (3 1 1) - (3 0 2) (3 1 2) - (3 0 3) (3 1 3))) - (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 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))) - ) - ;; multi-arg map/e test (define sums/e (map/e