More optimisation.
This commit is contained in:
Georges Dupéron
parent
e9255ca439
commit
48bc1ed2f9
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
[struct struct-field …] …)))]))
|
||||
|
||||
(gs bt-fields
|
||||
512
|
||||
257
|
||||
(a b c)
|
||||
[sab a b]
|
||||
[sbc b c]
|
||||
|
|
|
|||
114
times.rkt
114
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
|
||||
))))
|
||||
Loading…
Reference in New Issue
Block a user