commit 48bc1ed2f926c45f01eb781c97e4fd94682908cd
parent e9255ca439636f2a5c6e48a22c79a5cb7b207369
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 30 Dec 2016 04:12:52 +0100
More optimisation.
Diffstat:
3 files changed, 111 insertions(+), 98 deletions(-)
diff --git 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[<define-replace-in-tree>
+ (: 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-remove-in-tree>
- (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)])
- <make-replace-in-tree-body>))))]
-
@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
@@ -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
@@ -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
