suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

More optimisation.

Browse Source
This commit is contained in:
Georges Dupéron 2016-12-30 04:12:52 +01:00
parent e9255ca439
commit 48bc1ed2f9
3 changed files with 111 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
flexible-with.hl.rkt
View File

@ -48,33 +48,62 @@ with a new one.
[mod (cadr bits)]) [mod (cadr bits)])
(define/with-syntax next-id (vector-ref low-names (sub1 next))) (define/with-syntax next-id (vector-ref low-names (sub1 next)))
(if mod (if mod
#`(delay/pure/stateless #`(replace-right (inst next-id #,@τ*-limited+T-next)
(let ([tree (force tree-thunk)]) tree-thunk
(let ([left-subtree (car tree)] replacement)
[right-subtree (cdr tree)]) #`(replace-left (inst next-id #,@τ*-limited+T-next)
(cons left-subtree tree-thunk
(force (next-id (delay/pure/stateless right-subtree) replacement))))]
. 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)))))))]
@CHUNK[<define-replace-in-tree> @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-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 name (vector-ref names (sub1 i)))
(define/with-syntax rm-name (vector-ref rm-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 low-name (vector-ref low-names (sub1 i)))
(define/with-syntax tree-type-with-replacement-name (gensym 'tree-type-with-replacement)) (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 (take τ* depth))
(define τ*-limited+T-next (if (= depth 0)
(list #'T)
(append (take τ* (sub1 depth)) (list #'T))))
#`(begin #`(begin
(provide name rm-name) (provide name rm-name)
(define-type (tree-type-with-replacement-name #,@τ*-limited T) (define-type (tree-type-with-replacement-name #,@τ*-limited T)
(Promise #,(tree-type-with-replacement i #'T τ*-limited))) (Promise #,(tree-type-with-replacement i #'T τ*-limited)))
(: low-name (: low-name
(∀ (#,@τ*-limited T) (∀ (#,@τ*-limited T)
(→ (tree-type-with-replacement-name #,@τ*-limited Any) (→ (tree-type-with-replacement-name #,@τ*-limited Any)
@ -94,47 +123,14 @@ with a new one.
(tree-type-with-replacement-name #,@τ*-limited (Some T))))) (tree-type-with-replacement-name #,@τ*-limited (Some T)))))
(define (name tree-thunk replacement) (define (name tree-thunk replacement)
(low-name tree-thunk (Some 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 (: rm-name
(∀ (#,@τ*-limited) (∀ (#,@τ*-limited)
(→ (tree-type-with-replacement-name #,@τ*-limited (Some Any)) (→ (tree-type-with-replacement-name #,@τ*-limited (Some Any))
(tree-type-with-replacement-name #,@τ*-limited 'NONE)))) (tree-type-with-replacement-name #,@τ*-limited 'NONE))))
(define (rm-name tree-thunk) (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))))] (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} @section{Auxiliary values}
The following sections reuse a few values which are derived from the list of The following sections reuse a few values which are derived from the list of

2
test/test-flexible-with.rkt
View File

@ -22,7 +22,7 @@
[struct struct-field …] …)))])) [struct struct-field …] …)))]))
(gs bt-fields (gs bt-fields
512 257
(a b c) (a b c)
[sab a b] [sab a b]
[sbc b c] [sbc b c]

114
times.rkt
View File

@ -7,52 +7,70 @@
(plot (plot
#:x-min 1 #:x-max 3000 #:x-min 1 #:x-max 3000
#:y-min 1 #:y-max 3000 #:y-min 1 #:y-max 3000
(points '(#(16 16) (list
#(17 25) (lines #:color 1
#(20 26) '(#(16 16)
#(24 29) #(17 25)
#(28 31) #(20 26)
#(32 35) ;; 20 with shared implementation & type, 22 shrd impl only #(24 29)
#(33 60) #(28 31)
#(40 67) #(32 35) ; 20 with shared implementation & type, 22 shrd impl only
#(48 77) #(33 60)
#(56 80) #(40 67)
#(64 92) ;; 46 #(48 77)
#(65 168) #(56 80)
#(80 189) #(64 92) ;; 46
#(96 216) #(65 168)
#(128 276) #(80 189)
#(129 562) #(96 216)
#(256 911) #(128 276)
#(257 2078) #(129 562)
#(512 3000) ;; rough estimation #(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
))))