diff --git a/flexible-with.hl.rkt b/flexible-with.hl.rkt index db5eb5c..ab1b0f8 100644 --- a/flexible-with.hl.rkt +++ b/flexible-with.hl.rkt @@ -48,33 +48,62 @@ with a new one. [mod (cadr bits)]) (define/with-syntax next-id (vector-ref low-names (sub1 next))) (if mod - #`(delay/pure/stateless - (let ([tree (force tree-thunk)]) - (let ([left-subtree (car tree)] - [right-subtree (cdr tree)]) - (cons left-subtree - (force (next-id (delay/pure/stateless right-subtree) - . replacement?)))))) - #`(delay/pure/stateless - (let ([tree (force tree-thunk)]) - (let ([left-subtree (car tree)] - [right-subtree (cdr tree)]) - (cons (force (next-id (delay/pure/stateless left-subtree) - . replacement?)) - right-subtree)))))))] + #`(replace-right (inst next-id #,@τ*-limited+T-next) + tree-thunk + replacement) + #`(replace-left (inst next-id #,@τ*-limited+T-next) + tree-thunk + replacement))))] @CHUNK[ + (: replace-right (∀ (A B C R) (→ (→ (Promise B) R (Promise C)) + (Promise (Pairof A B)) + R + (Promise (Pairof A C))))) + (define-pure/stateless + #:∀ (A B C R) + (replace-right [next-id : (→ (Promise B) R (Promise C))] + [tree-thunk : (Promise (Pairof A B))] + [replacement : R]) + (delay/pure/stateless + (let ([tree (force tree-thunk)]) + (let ([left-subtree (car tree)] + [right-subtree (cdr tree)]) + (cons left-subtree + (force (next-id (delay/pure/stateless right-subtree) + replacement))))))) + (: replace-left (∀ (A B C R) (→ (→ (Promise A) R (Promise C)) + (Promise (Pairof A B)) + R + (Promise (Pairof C B))))) + (define-pure/stateless + #:∀ (A B C R) + (replace-left [next-id : (→ (Promise A) R (Promise C))] + [tree-thunk : (Promise (Pairof A B))] + [replacement : R]) + (delay/pure/stateless + (let ([tree (force tree-thunk)]) + (let ([left-subtree (car tree)] + [right-subtree (cdr tree)]) + (cons (force (next-id (delay/pure/stateless left-subtree) + replacement)) + right-subtree))))) + (define-for-syntax (define-replace-in-tree low-names names rm-names τ* i depth) (define/with-syntax name (vector-ref names (sub1 i))) (define/with-syntax rm-name (vector-ref rm-names (sub1 i))) (define/with-syntax low-name (vector-ref low-names (sub1 i))) (define/with-syntax tree-type-with-replacement-name (gensym 'tree-type-with-replacement)) - (define/with-syntax replacement? #'(replacement)) + (define/with-syntax tree-replacement-type-name (gensym 'tree-replacement-type)) (define τ*-limited (take τ* depth)) + (define τ*-limited+T-next (if (= depth 0) + (list #'T) + (append (take τ* (sub1 depth)) (list #'T)))) #`(begin (provide name rm-name) (define-type (tree-type-with-replacement-name #,@τ*-limited T) (Promise #,(tree-type-with-replacement i #'T τ*-limited))) + (: low-name (∀ (#,@τ*-limited T) (→ (tree-type-with-replacement-name #,@τ*-limited Any) @@ -94,47 +123,14 @@ with a new one. (tree-type-with-replacement-name #,@τ*-limited (Some T))))) (define (name tree-thunk replacement) (low-name tree-thunk (Some replacement))) - #;(define-pure/stateless - #:∀ (#,@τ*-limited T) - (name [tree-thunk : (tree-type-with-replacement-name #,@τ*-limited Any)] - [replacement : T]) - (low-name tree-thunk (Some replacement))) (: rm-name (∀ (#,@τ*-limited) (→ (tree-type-with-replacement-name #,@τ*-limited (Some Any)) (tree-type-with-replacement-name #,@τ*-limited 'NONE)))) (define (rm-name tree-thunk) - (low-name tree-thunk 'NONE)) - #;(define-pure/stateless - #:∀ (#,@τ*-limited) - (rm-name [tree-thunk : (tree-type-with-replacement-name #,@τ*-limited (Some Any))]) (low-name tree-thunk 'NONE))))] -@subsection{Removing fields} - -TODO: it would be better to factor this out, and simply choose whether to wrap -with Some or use 'NONE on the "front-end" side. - -@CHUNK[ - (define-for-syntax (define-remove-in-tree names τ* i depth) - (define/with-syntax name (vector-ref names (sub1 i))) - (define/with-syntax replacement? #'()) - (define τ*-limited (take τ* depth)) - #`(begin - (provide name) - (: name - (∀ (#,@τ*-limited T) - (→ (Promise #,(tree-type-with-replacement i #'(Some Any) τ*-limited)) - (Promise #,(tree-type-with-replacement i #''NONE τ*-limited))))) - (define-pure/stateless - #:∀ (#,@τ*-limited T) - (name [tree-thunk : (Promise #,(tree-type-with-replacement i #'(Some Any) τ*-limited))]) - : (Promise #,(tree-type-with-replacement i #''NONE τ*-limited)) - - #,(let ([replacement-thunk #'(delay/pure/stateless 'NONE)]) - ))))] - @section{Auxiliary values} The following sections reuse a few values which are derived from the list of diff --git a/test/test-flexible-with.rkt b/test/test-flexible-with.rkt index 2938bb6..9b428e6 100644 --- a/test/test-flexible-with.rkt +++ b/test/test-flexible-with.rkt @@ -22,7 +22,7 @@ [struct struct-field …] …)))])) (gs bt-fields - 512 + 257 (a b c) [sab a b] [sbc b c] diff --git a/times.rkt b/times.rkt index 398f2b0..97f74de 100644 --- a/times.rkt +++ b/times.rkt @@ -7,52 +7,70 @@ (plot #:x-min 1 #:x-max 3000 #:y-min 1 #:y-max 3000 - (points '(#(16 16) - #(17 25) - #(20 26) - #(24 29) - #(28 31) - #(32 35) ;; 20 with shared implementation & type, 22 shrd impl only - #(33 60) - #(40 67) - #(48 77) - #(56 80) - #(64 92) ;; 46 - #(65 168) - #(80 189) - #(96 216) - #(128 276) - #(129 562) - #(256 911) - #(257 2078) - #(512 3000) ;; rough estimation - )))) + (list + (lines #:color 1 + '(#(16 16) + #(17 25) + #(20 26) + #(24 29) + #(28 31) + #(32 35) ; 20 with shared implementation & type, 22 shrd impl only + #(33 60) + #(40 67) + #(48 77) + #(56 80) + #(64 92) ;; 46 + #(65 168) + #(80 189) + #(96 216) + #(128 276) + #(129 562) + #(256 911) + #(257 2078) + #(512 3000) ;; rough estimation + )) + ;; with shared implementation & type: + (lines #:color 2 + '(#(16 11) + ;#(17 25) + ;#(20 26) + ;#(24 29) + ;#(28 31) + #(32 20) + ;#(33 60) + ;#(40 67) + ;#(48 77) + ;#(56 80) + #(64 46) + ;#(65 168) + ;#(80 189) + ;#(96 216) + #(128 120) + ;#(129 562) + #(256 363) + ;#(257 2078) + #(512 1317) + )) + ;; further optimisations + (lines #:color 3 + '(#(16 10) + #(17 12) + #(20 13) + #(24 13) + #(28 14) + #(32 15) + #(33 22) + #(40 24) + #(48 26) + #(56 28) + #(64 30) + #(65 49) + #(80 54) + #(96 57) + #(128 69) + #(129 129) + #(256 186) + #(257 372) + #(512 587) + ))))) -;; with shared implementation & type: -(parameterize ([plot-x-transform log-transform] - [plot-x-ticks (log-ticks #:base 2)] - [plot-y-transform log-transform] - [plot-y-ticks (log-ticks #:base 2)]) - (plot - #:x-min 1 #:x-max 600 - #:y-min 1 #:y-max 600 - (points '(#(16 11) - ;#(17 25) - ;#(20 26) - ;#(24 29) - ;#(28 31) - #(32 20) - ;#(33 60) - ;#(40 67) - ;#(48 77) - ;#(56 80) - #(64 46) - ;#(65 168) - ;#(80 189) - ;#(96 216) - #(128 120) - ;#(129 562) - #(256 363) - ;#(257 2078) - ;#(512 3000) ;; rough estimation - )))) \ No newline at end of file