diff --git a/plot-gui-lib/plot/private/gui/plot3d.rkt b/plot-gui-lib/plot/private/gui/plot3d.rkt index 9b9c2d96..1f8c7c14 100644 --- a/plot-gui-lib/plot/private/gui/plot3d.rkt +++ b/plot-gui-lib/plot/private/gui/plot3d.rkt @@ -112,11 +112,14 @@ legend-entries-hash (plot-animating?) (flatten-legend-entries (for/list : (Listof (Treeof legend-entry)) ([rend (in-list renderer-list)]) - (match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend) + (match-define (renderer3d rend-bounds-rect _bf _tf label-proc render-proc) rend) (send area start-renderer (if rend-bounds-rect (rect-inexact->exact rend-bounds-rect) (unknown-rect 3))) - (if render-proc (render-proc area) empty)))) + (when render-proc (render-proc area)) + (if label-proc + (label-proc (send area get-bounds-rect)) + empty)))) (hash-set! render-tasks-hash (plot-animating?) (send area get-render-tasks))] [else diff --git a/plot-lib/plot/private/no-gui/plot2d-utils.rkt b/plot-lib/plot/private/no-gui/plot2d-utils.rkt index b129ac88..52431e6d 100644 --- a/plot-lib/plot/private/no-gui/plot2d-utils.rkt +++ b/plot-lib/plot/private/no-gui/plot2d-utils.rkt @@ -20,7 +20,7 @@ (cond [(list? renderer-tree) (append* (map get-renderer-list renderer-tree))] [(nonrenderer? renderer-tree) (match-define (nonrenderer bounds-rect bounds-fun ticks-fun) renderer-tree) - (list (renderer2d bounds-rect bounds-fun ticks-fun #f))] + (list (renderer2d bounds-rect bounds-fun ticks-fun #f #f))] [(renderer2d? renderer-tree) (list renderer-tree)] [else @@ -71,11 +71,16 @@ (define legend-entries (flatten-legend-entries (for/list : (Listof (Treeof legend-entry)) ([rend (in-list renderer-list)]) - (match-define (renderer2d rend-bounds-rect _bf _tf render-proc) rend) + (match-define (renderer2d rend-bounds-rect _bf _tf label-proc render-proc) rend) (send area start-renderer (if rend-bounds-rect (rect-inexact->exact rend-bounds-rect) (unknown-rect 2))) - (if render-proc (render-proc area) empty)))) + (when render-proc (render-proc area)) + (cond + [(and render-proc label-proc) + (define rect (send area get-bounds-rect)) + (label-proc rect)] + [else empty])))) (send area end-renderers) diff --git a/plot-lib/plot/private/no-gui/plot3d-utils.rkt b/plot-lib/plot/private/no-gui/plot3d-utils.rkt index 2dc86107..8b89b4de 100644 --- a/plot-lib/plot/private/no-gui/plot3d-utils.rkt +++ b/plot-lib/plot/private/no-gui/plot3d-utils.rkt @@ -20,7 +20,7 @@ (cond [(list? renderer-tree) (append* (map get-renderer-list renderer-tree))] [(nonrenderer? renderer-tree) (match-define (nonrenderer bounds-rect bounds-fun ticks-fun) renderer-tree) - (list (renderer3d bounds-rect bounds-fun ticks-fun #f))] + (list (renderer3d bounds-rect bounds-fun ticks-fun #f #f))] [(renderer3d? renderer-tree) (list renderer-tree)] [else @@ -81,11 +81,14 @@ (define legend-entries (flatten-legend-entries (for/list : (Listof (Treeof legend-entry)) ([rend (in-list renderer-list)]) - (match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend) + (match-define (renderer3d rend-bounds-rect _bf _tf label-proc render-proc) rend) (send area start-renderer (if rend-bounds-rect (rect-inexact->exact rend-bounds-rect) (unknown-rect 3))) - (if render-proc (render-proc area) empty)))) + (when render-proc (render-proc area)) + (if label-proc + (label-proc (send area get-bounds-rect)) + empty)))) (send area end-renderers) diff --git a/plot-lib/plot/private/plot2d/arrows.rkt b/plot-lib/plot/private/plot2d/arrows.rkt index bff43360..71c21b43 100644 --- a/plot-lib/plot/private/plot2d/arrows.rkt +++ b/plot-lib/plot/private/plot2d/arrows.rkt @@ -3,7 +3,6 @@ (require typed/racket/class racket/match racket/math racket/list racket/sequence plot/utils (only-in typed/pict pict) - (only-in math/statistics stddev) "../common/type-doc.rkt" "../common/utils.rkt") @@ -18,26 +17,22 @@ Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real (U (List '= Nonnegative-Real) Nonnegative-Real) Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) (define ((arrows-render-fun vs color line-width line-style alpha - arrow-head-size-or-scale arrow-head-angle - label) area) + arrow-head-size-or-scale arrow-head-angle) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect)) - - (cond - [(and x-min x-max y-min y-max) - (send area put-alpha alpha) - (send area put-pen color line-width line-style) - (send area put-arrow-head arrow-head-size-or-scale arrow-head-angle) - (for ([x (in-list vs)]) - (match-define (cons (vector v1x v1y) (vector v2x v2y)) x) - (define (f [x : Real][y : Real]) - (- (* (- v2x v1x) (- y v1y)) - (* (- v2y v1y) (- x v1x)))) - (cond + (when (and x-min x-max y-min y-max) + (send area put-alpha alpha) + (send area put-pen color line-width line-style) + (send area put-arrow-head arrow-head-size-or-scale arrow-head-angle) + (for ([x (in-list vs)]) + (match-define (cons (vector v1x v1y) (vector v2x v2y)) x) + (define (f [x : Real][y : Real]) + (- (* (- v2x v1x) (- y v1y)) + (* (- v2y v1y) (- x v1x)))) + (cond ;only draw the arrow head if the endpoint is visible ;other option makes little sense since size and angle can be/is plot units-absolute [(and (<= x-min v2x x-max) (<= y-min v2y y-max)) @@ -45,11 +40,7 @@ ;only draw the vector line if it is visible [(or (<= (* (f x-min y-min) (f x-max y-max)) 0) (<= (* (f x-min y-max) (f x-max y-min)) 0)) - (send area put-lines (list (car x) (cdr x)))])) - (cond [label (arrow-legend-entry label color line-width line-style)] - [else empty])] - [else empty]) - ) + (send area put-lines (list (car x) (cdr x)))])))) ;(Sequenceof (Sequence (Sequenceof Real))) does not work because (sequence? 5) = #t ;and so the contract can not know if '((2 2)) is three or two nested sequences @@ -132,14 +123,14 @@ (filter vrational? (append p1 p2)))) (cond - [(empty? rvs) (renderer2d #f #f #f #f)] + [(empty? rvs) empty-renderer2d] [else (define-values (x- x+ y- y+) (get-bounds x-min x-max y-min y-max rvs)) (renderer2d (vector (ivl x- x+) (ivl y- y+)) #f default-ticks-fun + (and label (λ (_) (arrow-legend-entry label color width style))) (arrows-render-fun vs* color width style alpha - arrow-head-size-or-scale arrow-head-angle - label))])])) + arrow-head-size-or-scale arrow-head-angle))])])) (define (get-bounds [x-min : (Option Real)][x-max : (Option Real)] [y-min : (Option Real)][y-max : (Option Real)] diff --git a/plot-lib/plot/private/plot2d/color-field.rkt b/plot-lib/plot/private/plot2d/color-field.rkt index d1c64bf7..03d28709 100644 --- a/plot-lib/plot/private/plot2d/color-field.rkt +++ b/plot-lib/plot/private/plot2d/color-field.rkt @@ -29,25 +29,22 @@ (define ((color-field-render-fun f samples alpha) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect)) - (cond - [(and x-min x-max y-min y-max) - (define xs (linear-seq x-min x-max (+ samples 1) #:start? #t #:end? #t)) - (define ys (linear-seq y-min y-max (+ samples 1) #:start? #t #:end? #t)) + (when (and x-min x-max y-min y-max) + (define xs (linear-seq x-min x-max (+ samples 1) #:start? #t #:end? #t)) + (define ys (linear-seq y-min y-max (+ samples 1) #:start? #t #:end? #t)) - (send area put-alpha alpha) - (send area put-pen 'black 0 'transparent) - (for ([x- (in-list xs)] - [x+ (in-list (cdr xs))]) - (define x (/ (+ x- x+) 2)) - (for ([y- (in-list ys)] - [y+ (in-list (cdr ys))]) - (define y (/ (+ y- y+) 2)) - (define c (f x y)) - (send area put-brush c 'solid) - (send area put-rect (vector (ivl x- x+) - (ivl y- y+))))) - empty] - [else empty])) + (send area put-alpha alpha) + (send area put-pen 'black 0 'transparent) + (for ([x- (in-list xs)] + [x+ (in-list (cdr xs))]) + (define x (/ (+ x- x+) 2)) + (for ([y- (in-list ys)] + [y+ (in-list (cdr ys))]) + (define y (/ (+ y- y+) 2)) + (define c (f x y)) + (send area put-brush c 'solid) + (send area put-rect (vector (ivl x- x+) + (ivl y- y+))))))) (:: color-field (->* [(U (-> Real Real Plot-Color) @@ -70,7 +67,7 @@ [(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)] [else (let ([f ((inst fix-a-field-fun Plot-Color) 'color-field f)]) - (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun #f (color-field-render-fun f samples alpha)))])) diff --git a/plot-lib/plot/private/plot2d/contour.rkt b/plot-lib/plot/private/plot2d/contour.rkt index d0a4ef1e..6c685352 100644 --- a/plot-lib/plot/private/plot2d/contour.rkt +++ b/plot-lib/plot/private/plot2d/contour.rkt @@ -16,12 +16,9 @@ (: isoline-render-proc (-> 2D-Sampler Real Positive-Integer Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((isoline-render-proc g z samples color width style alpha label) area) +(define ((isoline-render-proc g z samples color width style alpha) area) (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) - (match-define (ivl x-min x-max) x-ivl) - (match-define (ivl y-min y-max) y-ivl) (define num (animated-samples samples)) (define sample (g (vector x-ivl y-ivl) (vector num num))) (match-define (2d-sample xs ys zss z-min z-max) sample) @@ -34,9 +31,7 @@ (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) (match-define (list v1 v2) (map (λ ([v : (Vectorof Real)]) (vector-take v 2)) line)) (send area put-line v1 v2)))) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + (void)) (:: isoline (->* [(-> Real Real Real) Real] @@ -72,54 +67,67 @@ (define y-ivl (ivl y-min y-max)) (define g (2d-function->sampler f (vector x-ivl y-ivl))) (renderer2d (vector x-ivl y-ivl) #f default-ticks-fun - (isoline-render-proc g z samples color width style alpha label))])) + (and label (λ (_) (line-legend-entry label color width style))) + (isoline-render-proc g z samples color width style alpha))])) ;; =================================================================================================== ;; Contour lines -(: contours-render-proc (-> 2D-Sampler Contour-Levels Positive-Integer - (Plot-Colors (Listof Real)) - (Pen-Widths (Listof Real)) - (Plot-Pen-Styles (Listof Real)) - (Alphas (Listof Real)) - (U String pict #f) - 2D-Render-Proc)) -(define ((contours-render-proc g levels samples colors widths styles alphas label) area) - (let/ec return : (Treeof legend-entry) - (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) - (match-define (ivl x-min x-max) x-ivl) - (match-define (ivl y-min y-max) y-ivl) +(: make-contour-labels-and-renderer (-> 2D-Sampler Contour-Levels Positive-Integer + (Plot-Colors (Listof Real)) + (Pen-Widths (Listof Real)) + (Plot-Pen-Styles (Listof Real)) + (Alphas (Listof Real)) + (U String pict #f) + (Values (U #f (-> Rect (Treeof legend-entry))) + 2D-Render-Proc))) +(define (make-contour-labels-and-renderer g levels samples colors widths styles alphas label) + ;; g is a 2D-sampler, which is a memoized proc. Recalculation here should be cheap + (define (calculate-zs/labels [rect : Rect]) : (Values 2d-sample (Listof Real) (Listof String)) + (match-define (vector x-ivl y-ivl) rect) (define num (animated-samples samples)) (define sample (g (vector x-ivl y-ivl) (vector num num))) (match-define (2d-sample xs ys zss z-min z-max) sample) - - (unless (and z-min z-max) (return empty)) - - (match-define (list (tick #{zs : (Listof Real)} - #{_ : (Listof Boolean)} - #{labels : (Listof String)}) - ...) - (contour-ticks (plot-z-ticks) (assert z-min values) (assert z-max values) levels #f)) - - (let* ([colors (generate-list colors zs)] - [widths (generate-list widths zs)] - [styles (generate-list styles zs)] - [alphas (generate-list alphas zs)]) - (for ([z (in-list zs)] - [color (in-cycle* colors)] - [width : Nonnegative-Real (in-cycle* widths)] - [style (in-cycle* styles)] - [alpha : Nonnegative-Real (in-cycle* alphas)]) - (send area put-alpha alpha) - (send area put-pen color width style) - (for-2d-sample - (xa xb ya yb z1 z2 z3 z4) sample - (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) - (match-define (list v1 v2) (map (λ ([v : (Vectorof Real)]) (vector-take v 2)) line)) - (send area put-line v1 v2))))) - - (cond [(and label (not (empty? zs))) (line-legend-entries label zs labels colors widths styles)] - [else empty]))) + (cond + [(and z-min z-max) + (match-define (list (tick #{zs : (Listof Real)} + #{_ : (Listof Boolean)} + #{labels : (Listof String)}) + ...) + (contour-ticks (plot-z-ticks) (assert z-min values) (assert z-max values) levels #f)) + (values sample zs labels)] + [else + (values (2d-sample '() '() #() #f #f) empty empty)])) + + (define label-proc + (and label (λ ([rect : Rect]) + (define-values (_ zs labels) (calculate-zs/labels rect)) + (if (empty? zs) + '() + (line-legend-entries label zs labels colors widths styles))))) + + (: render-proc 2D-Render-Proc) + (define (render-proc area) + (define-values (sample zs _) (calculate-zs/labels (send area get-bounds-rect))) + (unless (empty? zs) + (let* ([colors (generate-list colors zs)] + [widths (generate-list widths zs)] + [styles (generate-list styles zs)] + [alphas (generate-list alphas zs)]) + (for ([z (in-list zs)] + [color (in-cycle* colors)] + [width : Nonnegative-Real (in-cycle* widths)] + [style (in-cycle* styles)] + [alpha : Nonnegative-Real (in-cycle* alphas)]) + (send area put-alpha alpha) + (send area put-pen color width style) + (for-2d-sample + (xa xb ya yb z1 z2 z3 z4) sample + (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) + (match-define (list v1 v2) (map (λ ([v : (Vectorof Real)]) (vector-take v 2)) line)) + (send area put-line v1 v2))))))) + + (values label-proc render-proc)) (:: contours (->* [(-> Real Real Real)] @@ -153,81 +161,107 @@ (define x-ivl (ivl x-min x-max)) (define y-ivl (ivl y-min y-max)) (define g (2d-function->sampler f (vector x-ivl y-ivl))) + (define-values (label-proc render-proc) + (make-contour-labels-and-renderer + g levels samples colors widths styles alphas label)) (renderer2d (vector x-ivl y-ivl) #f default-ticks-fun - (contours-render-proc g levels samples colors widths styles alphas label))])) + label-proc render-proc)])) ;; =================================================================================================== ;; Contour intervals -(: contour-intervals-render-proc +(: make-contour-intervals-labels-and-renderer (-> 2D-Sampler Contour-Levels Positive-Integer (Plot-Colors (Listof ivl)) (Plot-Brush-Styles (Listof ivl)) (Plot-Colors (Listof Real)) (Pen-Widths (Listof Real)) (Plot-Pen-Styles (Listof Real)) (Alphas (Listof ivl)) (U String pict #f) - 2D-Render-Proc)) -(define ((contour-intervals-render-proc - g levels samples colors styles contour-colors contour-widths contour-styles alphas label) - area) - (let/ec return : (Treeof legend-entry) - (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) - (match-define (ivl x-min x-max) x-ivl) - (match-define (ivl y-min y-max) y-ivl) + (Values (U #f (-> Rect (Treeof legend-entry))) + 2D-Render-Proc))) +(define (make-contour-intervals-labels-and-renderer + g levels samples colors styles contour-colors contour-widths contour-styles alphas label) + ;; g is a 2D-sampler, which is a memoized proc. Recalculation here should be cheap + (define (calculate-zivls/labels [rect : Rect]) : (Values 2d-sample (Listof ivl) (Listof Real) (Listof String)) + (match-define (vector x-ivl y-ivl) rect) (define num (animated-samples samples)) (define sample (g (vector x-ivl y-ivl) (vector num num))) (match-define (2d-sample xs ys zss z-min z-max) sample) - - (unless (and z-min z-max) (return empty)) - - (match-define (list (tick #{zs : (Listof Real)} - #{_ : (Listof Boolean)} - #{labels : (Listof String)}) - ...) - (contour-ticks (plot-z-ticks) (assert z-min values) (assert z-max values) levels #t)) - - (define-values (z-ivls ivl-labels) - (for/lists ([z-ivls : (Listof ivl)] - [ivl-labels : (Listof String)] - ) ([za (in-list zs)] - [zb (in-list (rest zs))] - [la (in-list labels)] - [lb (in-list (rest labels))]) - (values (ivl za zb) (format "[~a,~a]" la lb)))) - - (send area put-pen 0 1 'transparent) - (let* ([colors (map ->brush-color (generate-list colors z-ivls))] - [styles (map ->brush-style (generate-list styles z-ivls))] - [alphas (generate-list alphas z-ivls)]) - (for ([za (in-list zs)] - [zb (in-list (rest zs))] - [color : (List Real Real Real) (in-cycle* colors)] - [style : Plot-Brush-Style (in-cycle* styles)] - [alpha : Nonnegative-Real (in-cycle* alphas)]) - (send area put-brush color style) - (send area put-alpha alpha) - (for-2d-sample - (xa xb ya yb z1 z2 z3 z4) sample - (for ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) - (send area put-polygon (map (λ ([v : (Vectorof Real)]) (vector-take v 2)) poly))))) - - ((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f) - area) - - (define n (- (length zs) 2)) - (define contour-colors* - (append (list 0) (sequence-take (in-cycle* (generate-list contour-colors zs)) 0 n) (list 0))) - (define contour-widths* - (append (list 0) (sequence-take (in-cycle* (generate-list contour-widths zs)) 0 n) (list 0))) - (define contour-styles* - (append '(transparent) (sequence-take (in-cycle* (generate-list contour-styles zs)) 0 n) - '(transparent))) - - (cond [label (interval-legend-entries - label z-ivls ivl-labels - colors styles colors '(1) '(transparent) - contour-colors* contour-widths* contour-styles* - (rest contour-colors*) (rest contour-widths*) (rest contour-styles*))] - [else empty])))) + (cond + [(and z-min z-max) + (match-define (list (tick #{zs : (Listof Real)} + #{_ : (Listof Boolean)} + #{labels : (Listof String)}) + ...) + (contour-ticks (plot-z-ticks) (assert z-min values) (assert z-max values) levels #t)) + + (define-values (z-ivls ivl-labels) + (for/lists ([z-ivls : (Listof ivl)] + [ivl-labels : (Listof String)] + ) ([za (in-list zs)] + [zb (in-list (rest zs))] + [la (in-list labels)] + [lb (in-list (rest labels))]) + (values (ivl za zb) (format "[~a,~a]" la lb)))) + + (values sample z-ivls zs ivl-labels)] + [else + (values (2d-sample '() '() #() #f #f) empty empty empty)])) + + (define label-proc + (and label + (λ ([rect : Rect]) + (define-values (_ z-ivls zs ivl-labels) + (calculate-zivls/labels rect)) + + (cond + [(empty? zs) empty] + [else + (let* ([colors (map ->brush-color (generate-list colors z-ivls))] + [styles (map ->brush-style (generate-list styles z-ivls))]) + (define n (- (length zs) 2)) + (define contour-colors* + (append (list 0) (sequence-take (in-cycle* (generate-list contour-colors zs)) 0 n) (list 0))) + (define contour-widths* + (append (list 0) (sequence-take (in-cycle* (generate-list contour-widths zs)) 0 n) (list 0))) + (define contour-styles* + (append '(transparent) (sequence-take (in-cycle* (generate-list contour-styles zs)) 0 n) + '(transparent))) + + (interval-legend-entries + label z-ivls ivl-labels + colors styles colors '(1) '(transparent) + contour-colors* contour-widths* contour-styles* + (rest contour-colors*) (rest contour-widths*) (rest contour-styles*)))])))) + + (: render-proc 2D-Render-Proc) + (define (render-proc area) + (define-values (sample z-ivls zs _) + (calculate-zivls/labels (send area get-bounds-rect))) + (unless (empty? zs) + (let* ([colors (map ->brush-color (generate-list colors z-ivls))] + [styles (map ->brush-style (generate-list styles z-ivls))] + [alphas (generate-list alphas z-ivls)]) + + (send area put-pen 0 1 'transparent) + (for ([za (in-list zs)] + [zb (in-list (rest zs))] + [color : (List Real Real Real) (in-cycle* colors)] + [style : Plot-Brush-Style (in-cycle* styles)] + [alpha : Nonnegative-Real (in-cycle* alphas)]) + (send area put-brush color style) + (send area put-alpha alpha) + (for-2d-sample + (xa xb ya yb z1 z2 z3 z4) sample + (for ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) + (send area put-polygon (map (λ ([v : (Vectorof Real)]) (vector-take v 2)) poly))))) + + (define-values (_ contour-render-proc) + (make-contour-labels-and-renderer + g levels samples contour-colors contour-widths contour-styles alphas #f)) + + (contour-render-proc area)))) + + (values label-proc render-proc)) (:: contour-intervals (->* [(-> Real Real Real)] @@ -266,7 +300,9 @@ (define x-ivl (ivl x-min x-max)) (define y-ivl (ivl y-min y-max)) (define g (2d-function->sampler f (vector x-ivl y-ivl))) + (define-values (label-proc render-proc) + (make-contour-intervals-labels-and-renderer + g levels samples colors styles + contour-colors contour-widths contour-styles alphas label)) (renderer2d (vector x-ivl y-ivl) #f default-ticks-fun - (contour-intervals-render-proc g levels samples colors styles - contour-colors contour-widths contour-styles - alphas label))])) + label-proc render-proc)])) diff --git a/plot-lib/plot/private/plot2d/decoration.rkt b/plot-lib/plot/private/plot2d/decoration.rkt index c9b3d87b..be8a4e95 100644 --- a/plot-lib/plot/private/plot2d/decoration.rkt +++ b/plot-lib/plot/private/plot2d/decoration.rkt @@ -35,9 +35,7 @@ (define dist (+ radius (pen-gap))) (for ([t (in-list x-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (send area put-text label (vector x y) (if far? 'bottom 'top) 0 dist))) - - empty) + (send area put-text label (vector x y) (if far? 'bottom 'top) 0 dist)))) (:: x-axis (->* [] [Real #:ticks? Boolean #:labels? Boolean #:far? Boolean #:alpha Nonnegative-Real] @@ -52,7 +50,7 @@ [(or (> alpha 1) (not (rational? alpha))) (raise-keyword-error 'x-axis "real in [0,1]" '#:alpha alpha)] [else - (renderer2d #f #f #f (x-axis-render-proc y ticks? labels? far? alpha))])) + (renderer2d #f #f #f #f (x-axis-render-proc y ticks? labels? far? alpha))])) ;; --------------------------------------------------------------------------------------------------- @@ -77,9 +75,7 @@ (define dist (+ radius (pen-gap))) (for ([t (in-list y-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (send area put-text label (vector x y) (if far? 'left 'right) 0 dist))) - - empty) + (send area put-text label (vector x y) (if far? 'left 'right) 0 dist)))) (:: y-axis (->* [] [Real #:ticks? Boolean #:labels? Boolean #:far? Boolean #:alpha Nonnegative-Real] @@ -94,7 +90,7 @@ [(or (> alpha 1) (not (rational? alpha))) (raise-keyword-error 'y-axis "real in [0,1]" '#:alpha alpha)] [else - (renderer2d #f #f #f (y-axis-render-proc x ticks? labels? far? alpha))])) + (renderer2d #f #f #f #f (y-axis-render-proc x ticks? labels? far? alpha))])) (:: axes (->* [] @@ -195,8 +191,7 @@ (define ((polar-axes-render-proc num ticks? labels? alpha) area) (send area put-alpha alpha) (when (num . > . 0) (draw-polar-axis-lines num area)) - (when ticks? (draw-polar-axis-ticks (if (num . > . 0) num 12) labels? area)) - empty) + (when ticks? (draw-polar-axis-ticks (if (num . > . 0) num 12) labels? area))) (:: polar-axes (->* [] [#:number Natural #:ticks? Boolean #:labels? Boolean #:alpha Nonnegative-Real] @@ -209,7 +204,7 @@ [(or (> alpha 1) (not (rational? alpha))) (raise-keyword-error 'polar-axes "real in [0,1]" '#:alpha alpha)] [else - (renderer2d #f #f #f (polar-axes-render-proc num ticks? labels? alpha))])) + (renderer2d #f #f #f #f (polar-axes-render-proc num ticks? labels? alpha))])) ;; =================================================================================================== ;; Grid @@ -223,8 +218,7 @@ (for ([t (in-list x-ticks)]) (match-define (tick x major? _) t) (if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash)) - (send area put-line (vector x y-min) (vector x y-max)))) - empty) + (send area put-line (vector x y-min) (vector x y-max))))) (: y-tick-lines-render-proc (-> 2D-Render-Proc)) (define ((y-tick-lines-render-proc) area) @@ -235,16 +229,15 @@ (for ([t (in-list y-ticks)]) (match-define (tick y major? _) t) (if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash)) - (send area put-line (vector x-min y) (vector x-max y)))) - empty) + (send area put-line (vector x-min y) (vector x-max y))))) (:: x-tick-lines (-> renderer2d)) (define (x-tick-lines) - (renderer2d #f #f #f (x-tick-lines-render-proc))) + (renderer2d #f #f #f #f (x-tick-lines-render-proc))) (:: y-tick-lines (-> renderer2d)) (define (y-tick-lines) - (renderer2d #f #f #f (y-tick-lines-render-proc))) + (renderer2d #f #f #f #f (y-tick-lines-render-proc))) (:: tick-grid (-> (Listof renderer2d))) (define (tick-grid) @@ -284,9 +277,7 @@ ; point (send area put-pen point-color point-line-width 'solid) (send area put-brush point-fill-color 'solid) - (send area put-glyphs (list v) point-sym point-size)) - - empty) + (send area put-glyphs (list v) point-sym point-size))) (: pict-render-proc (-> pict (Vectorof Real) Anchor @@ -303,8 +294,7 @@ ; point (send area put-pen point-color point-line-width 'solid) (send area put-brush point-fill-color 'solid) - (send area put-glyphs (list v) point-sym point-size) - empty) + (send area put-glyphs (list v) point-sym point-size)) (:: point-label (->* [(Sequenceof Real)] @@ -345,7 +335,7 @@ [else (let ([v (sequence-head-vector 'point-label v 2)]) (match-define (vector x y) v) - (renderer2d (vector (ivl x x) (ivl y y)) #f #f + (renderer2d (vector (ivl x x) (ivl y y)) #f #f #f (label-render-proc label v color size face family anchor angle point-color (cond [(eq? point-fill-color 'auto) (->pen-color point-color)] @@ -379,7 +369,7 @@ [else (let ([v (sequence-head-vector 'point-pict v 2)]) (match-define (vector x y) v) - (renderer2d (vector (ivl x x) (ivl y y)) #f #f + (renderer2d (vector (ivl x x) (ivl y y)) #f #f #f (pict-render-proc pict v anchor point-color (cond [(eq? point-fill-color 'auto) (->pen-color point-color)] [else point-fill-color]) diff --git a/plot-lib/plot/private/plot2d/interval.rkt b/plot-lib/plot/private/plot2d/interval.rkt index 19993525..9fdb06cc 100644 --- a/plot-lib/plot/private/plot2d/interval.rkt +++ b/plot-lib/plot/private/plot2d/interval.rkt @@ -18,12 +18,11 @@ Plot-Color Nonnegative-Real Plot-Pen-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) (define ((lines-interval-render-proc v1s v2s color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) + alpha) area) (send area put-alpha alpha) (send area put-pen 0 0 'transparent) @@ -34,12 +33,7 @@ (send area put-lines v1s) (send area put-pen line2-color line2-width line2-style) - (send area put-lines v2s) - - (cond [label (interval-legend-entry label color style 0 0 'transparent - line1-color line1-width line1-style - line2-color line2-width line2-style)] - [else empty])) + (send area put-lines v2s)) (:: lines-interval (->* [(Sequenceof (Sequenceof Real)) @@ -84,7 +78,7 @@ [v2s (sequence->listof-vector 'lines-interval v2s 2)]) (define rvs (filter vrational? (append v1s v2s))) (cond - [(empty? rvs) (renderer2d #f #f #f #f)] + [(empty? rvs) empty-renderer2d] [else (match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)}) ...) rvs) (let ([x-min (if x-min x-min (apply min* rxs))] @@ -92,10 +86,14 @@ [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (and label (λ (_) + (interval-legend-entry label color style 0 0 'transparent + line1-color line1-width line1-style + line2-color line2-width line2-style))) (lines-interval-render-proc v1s v2s color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label)))]))])) + alpha)))]))])) (:: parametric-interval (->* [(-> Real (Sequenceof Real)) (-> Real (Sequenceof Real)) Real Real] @@ -217,12 +215,11 @@ Plot-Color Nonnegative-Real Plot-Pen-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) (define ((function-interval-render-proc f1 f2 samples color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) + alpha) area) (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) (match-define (sample x1s y1s _ _) (f1 x-ivl samples)) @@ -233,7 +230,7 @@ ((lines-interval-render-proc v1s v2s color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) + alpha) area)) (:: function-interval @@ -285,10 +282,14 @@ (renderer2d (vector x-ivl y-ivl) (function-interval-bounds-fun g1 g2 samples) default-ticks-fun + (and label (λ (_) + (interval-legend-entry label color style 0 0 'transparent + line1-color line1-width line1-style + line2-color line2-width line2-style))) (function-interval-render-proc g1 g2 samples color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label))])) + alpha))])) ;; =================================================================================================== ;; Inverse function @@ -298,12 +299,11 @@ Plot-Color Nonnegative-Real Plot-Pen-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) (define ((inverse-interval-render-proc f1 f2 samples color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) + alpha) area) (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) (match-define (sample y1s x1s _ _) (f1 y-ivl samples)) @@ -314,7 +314,7 @@ ((lines-interval-render-proc v1s v2s color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) + alpha) area)) (:: inverse-interval @@ -366,7 +366,11 @@ (renderer2d (vector x-ivl y-ivl) (inverse-interval-bounds-fun g1 g2 samples) default-ticks-fun + (and label (λ (_) + (interval-legend-entry label color style 0 0 'transparent + line1-color line1-width line1-style + line2-color line2-width line2-style))) (inverse-interval-render-proc g1 g2 samples color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label))])) + alpha))])) diff --git a/plot-lib/plot/private/plot2d/line.rkt b/plot-lib/plot/private/plot2d/line.rkt index 7bcb2251..1337492e 100644 --- a/plot-lib/plot/private/plot2d/line.rkt +++ b/plot-lib/plot/private/plot2d/line.rkt @@ -17,15 +17,11 @@ (: lines-render-proc (-> (Listof (Vectorof Real)) Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((lines-render-proc vs color width style alpha label) area) +(define ((lines-render-proc vs color width style alpha) area) (send area put-alpha alpha) (send area put-pen color width style) - (send area put-lines vs) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + (send area put-lines vs)) (:: lines (->* [(Sequenceof (Sequenceof Real))] @@ -56,7 +52,7 @@ [else (let ([vs (sequence->listof-vector 'lines vs 2)]) (define rvs (filter vrational? vs)) - (cond [(empty? rvs) (renderer2d #f #f #f #f)] + (cond [(empty? rvs) empty-renderer2d] [else (match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)}) ...) rvs) (let ([x-min (if x-min x-min (apply min* rxs))] @@ -64,7 +60,8 @@ [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun - (lines-render-proc vs color width style alpha label)))]))])) + (and label (λ (_) (line-legend-entry label color width style))) + (lines-render-proc vs color width style alpha)))]))])) (:: parametric (->* [(-> Real (Sequenceof Real)) Real Real] @@ -154,9 +151,8 @@ Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((rule-render-proc v v-min v-max h/v color width style alpha label) area) +(define ((rule-render-proc v v-min v-max h/v color width style alpha) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect)) ;; This is the error that `get-bounds-rect` should raise (unless (and x-min x-max y-min y-max) @@ -167,10 +163,7 @@ (send area put-pen color width style 'butt) (case h/v [(h) (send area put-line (vector (or v-min x-min) v) (vector (or v-max x-max) v))] - [(v) (send area put-line (vector v (or v-min y-min)) (vector v (or v-max y-max)))]) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + [(v) (send area put-line (vector v (or v-min y-min)) (vector v (or v-max y-max)))])) (:: vrule (->* [Real] @@ -196,7 +189,8 @@ [(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)] [else (renderer2d #f #f default-ticks-fun - (rule-render-proc x y-min y-max 'v color width style alpha label))])) + (and label (λ (_) (line-legend-entry label color width style))) + (rule-render-proc x y-min y-max 'v color width style alpha))])) (:: hrule (->* [Real] @@ -222,7 +216,8 @@ [(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)] [else (renderer2d #f #f default-ticks-fun - (rule-render-proc y x-min x-max 'h color width style alpha label))])) + (and label (λ (_) (line-legend-entry label color width style))) + (rule-render-proc y x-min x-max 'h color width style alpha))])) ;; =================================================================================================== ;; Function @@ -230,18 +225,14 @@ (: function-render-proc (-> Sampler Positive-Integer Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((function-render-proc f samples color width style alpha label) area) +(define ((function-render-proc f samples color width style alpha) area) (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) (match-define (sample xs ys y-min y-max) (f x-ivl samples)) (send area put-alpha alpha) (send area put-pen color width style) - (send area put-lines (map (λ ([x : Real] [y : Real]) (vector x y)) xs ys)) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + (send area put-lines (map (λ ([x : Real] [y : Real]) (vector x y)) xs ys))) (:: function (->* [(-> Real Real)] @@ -279,7 +270,8 @@ (renderer2d (vector x-ivl y-ivl) (function-bounds-fun f samples) default-ticks-fun - (function-render-proc f samples color width style alpha label)))])) + (and label (λ (_) (line-legend-entry label color width style))) + (function-render-proc f samples color width style alpha)))])) ;; =================================================================================================== ;; Inverse function @@ -287,18 +279,14 @@ (: inverse-render-proc (-> Sampler Positive-Integer Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((inverse-render-proc f samples color width style alpha label) area) +(define ((inverse-render-proc f samples color width style alpha) area) (match-define (vector x-ivl y-ivl) (send area get-bounds-rect)) (match-define (sample ys xs x-min x-max) (f y-ivl samples)) (send area put-alpha alpha) (send area put-pen color width style) - (send area put-lines (map (λ ([x : Real] [y : Real]) (vector x y)) xs ys)) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + (send area put-lines (map (λ ([x : Real] [y : Real]) (vector x y)) xs ys))) (: inverse (->* [(-> Real Real)] @@ -336,7 +324,8 @@ (renderer2d (vector x-ivl y-ivl) (inverse-bounds-fun g samples) default-ticks-fun - (inverse-render-proc g samples color width style alpha label))])) + (and label (λ (_) (line-legend-entry label color width style))) + (inverse-render-proc g samples color width style alpha))])) ;; =================================================================================================== ;; Kernel density estimation diff --git a/plot-lib/plot/private/plot2d/point.rkt b/plot-lib/plot/private/plot2d/point.rkt index 6f9aeaee..4e7f434d 100644 --- a/plot-lib/plot/private/plot2d/point.rkt +++ b/plot-lib/plot/private/plot2d/point.rkt @@ -23,15 +23,12 @@ (: points-render-fun (-> (Listof (Vectorof Real)) Point-Sym Plot-Color Plot-Color Nonnegative-Real Nonnegative-Real Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((points-render-fun vs sym color fill-color size line-width alpha label) area) +(define ((points-render-fun vs sym color fill-color size line-width alpha) area) (send area put-alpha alpha) (send area put-pen color line-width 'solid) (send area put-brush fill-color 'solid) - (send area put-glyphs vs sym size) - - (if label (point-legend-entry label sym color fill-color size line-width) empty)) + (send area put-glyphs vs sym size)) (:: points (->* [(Sequenceof (Sequenceof Real))] @@ -71,7 +68,7 @@ (let* ([vs (sequence->listof-vector 'points vs 2)] [vs (filter vrational? vs)]) (cond - [(empty? vs) (renderer2d #f #f #f #f)] + [(empty? vs) empty-renderer2d] [else (unless (= 0 x-jitter y-jitter) (points-apply-jitters vs (vector x-jitter y-jitter) #:ivls (vector (ivl x-min x-max) (ivl y-min y-max)))) @@ -83,8 +80,9 @@ [fill-color (if (eq? fill-color 'auto) (->pen-color color) fill-color)]) (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (and label (λ (_) (point-legend-entry label sym color fill-color size line-width))) (points-render-fun vs sym color fill-color - size line-width alpha label)))]))])) + size line-width alpha)))]))])) ;; =================================================================================================== ;; Vector fields @@ -94,62 +92,56 @@ Positive-Integer (U Real 'auto 'normalized) Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((vector-field-render-fun f samples scale color line-width line-style alpha label) area) +(define ((vector-field-render-fun f samples scale color line-width line-style alpha) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect)) - (cond - [(and x-min x-max y-min y-max) - (define xs0 (linear-seq x-min x-max samples #:start? #t #:end? #t)) - (define ys0 (linear-seq y-min y-max samples #:start? #t #:end? #t)) + (when (and x-min x-max y-min y-max) + (define xs0 (linear-seq x-min x-max samples #:start? #t #:end? #t)) + (define ys0 (linear-seq y-min y-max samples #:start? #t #:end? #t)) - (define-values (xs ys dxs dys angles mags) - (for*/lists ([xs : (Listof Real)] - [ys : (Listof Real)] - [dxs : (Listof Real)] - [dys : (Listof Real)] - [angles : (Listof Real)] - [mags : (Listof Nonnegative-Real)] - ) ([x (in-list xs0)] - [y (in-list ys0)] - [dv (in-value (f x y))] #:when (vrational? dv)) - (match-define (vector dx dy) dv) - (values x y dx dy (atan2 dy dx) (sqrt (+ (sqr dx) (sqr dy)))))) + (define-values (xs ys dxs dys angles mags) + (for*/lists ([xs : (Listof Real)] + [ys : (Listof Real)] + [dxs : (Listof Real)] + [dys : (Listof Real)] + [angles : (Listof Real)] + [mags : (Listof Nonnegative-Real)] + ) ([x (in-list xs0)] + [y (in-list ys0)] + [dv (in-value (f x y))] #:when (vrational? dv)) + (match-define (vector dx dy) dv) + (values x y dx dy (atan2 dy dx) (sqrt (+ (sqr dx) (sqr dy)))))) - (cond [(empty? xs) empty] - [else (define box-x-size (/ (- x-max x-min) samples)) - (define box-y-size (/ (- y-max y-min) samples)) + (unless (empty? xs) + (define box-x-size (/ (- x-max x-min) samples)) + (define box-y-size (/ (- y-max y-min) samples)) - (define new-mags - (match scale - [(? real?) (map (λ ([mag : Real]) (* scale mag)) mags)] - ['normalized (define box-size (min box-x-size box-y-size)) - (build-list (length dxs) (λ _ box-size))] - ['auto - ;; When all dxs or dys are (exact) zero, the calculation of scale - ;; will raise a 'division by zero' error. If we convert the values - ;; to flonums, the partial result will be +inf.0, and the correct - ;; scale can be calculated. - (define dx-max (real->double-flonum (apply max (map abs dxs)))) - (define dy-max (real->double-flonum (apply max (map abs dys)))) - (define scale (min (/ box-x-size dx-max) - (/ box-y-size dy-max))) - (map (λ ([mag : Real]) (* scale mag)) mags)])) + (define new-mags + (match scale + [(? real?) (map (λ ([mag : Real]) (* scale mag)) mags)] + ['normalized (define box-size (min box-x-size box-y-size)) + (build-list (length dxs) (λ _ box-size))] + ['auto + ;; When all dxs or dys are (exact) zero, the calculation of scale + ;; will raise a 'division by zero' error. If we convert the values + ;; to flonums, the partial result will be +inf.0, and the correct + ;; scale can be calculated. + (define dx-max (real->double-flonum (apply max (map abs dxs)))) + (define dy-max (real->double-flonum (apply max (map abs dys)))) + (define scale (min (/ box-x-size dx-max) + (/ box-y-size dy-max))) + (map (λ ([mag : Real]) (* scale mag)) mags)])) - (send area put-alpha alpha) - (send area put-pen color line-width line-style) - (for ([x (in-list xs)] - [y (in-list ys)] - [angle (in-list angles)] - [mag (in-list new-mags)]) - (send area put-arrow - (vector x y) - (vector (+ x (* mag (cos angle))) (+ y (* mag (sin angle)))))) - - (cond [label (arrow-legend-entry label color line-width line-style)] - [else empty])])] - [else empty])) + (send area put-alpha alpha) + (send area put-pen color line-width line-style) + (for ([x (in-list xs)] + [y (in-list ys)] + [angle (in-list angles)] + [mag (in-list new-mags)]) + (send area put-arrow + (vector x y) + (vector (+ x (* mag (cos angle))) (+ y (* mag (sin angle))))))))) (:: vector-field (->* [(U (-> Real Real (Sequenceof Real)) @@ -186,8 +178,9 @@ [else (let ([f (fix-vector-field-fun 'vector-field f)]) (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (and label (λ (_) (arrow-legend-entry label color line-width line-style))) (vector-field-render-fun - f samples scale color line-width line-style alpha label)))])) + f samples scale color line-width line-style alpha)))])) ;; =================================================================================================== ;; Error bars @@ -212,9 +205,7 @@ (define v2 (maybe-invert x (+ y h))) (send area put-line v1 v2) (send area put-tick v1 radius angle) - (send area put-tick v2 radius angle))) - - empty) + (send area put-tick v2 radius angle)))) (:: error-bars (->* [(Sequenceof (Sequenceof Real))] @@ -247,7 +238,7 @@ [else (let* ([bars (sequence->listof-vector 'error-bars bars 3)] [bars (filter vrational? bars)]) - (cond [(empty? bars) (renderer2d #f #f #f #f)] + (cond [(empty? bars) empty-renderer2d] [else (match-define (list (vector #{xs : (Listof Real)} #{ys : (Listof Real)} @@ -262,8 +253,7 @@ (define maybe-invert (if invert? (λ (x y) (vector y x)) vector)) (renderer2d (maybe-invert (ivl x-min x-max) (ivl y-min y-max)) - #f - default-ticks-fun + #f default-ticks-fun #f (error-bars-render-fun xs ys hs color line-width line-style width alpha invert?)))]))])) @@ -295,8 +285,7 @@ (send area put-line v2 v4) (send area put-line v1 v3) (send area put-brush up-color 'solid) - (send area put-rect r1)])) - empty) + (send area put-rect r1)]))) (:: candlesticks (->* [(Sequenceof (Sequenceof Real))] @@ -329,7 +318,7 @@ [else (let* ([candles (sequence->listof-vector 'candlesticks candles 5)] [candles (filter vrational? candles)]) - (cond [(empty? candles) (renderer2d #f #f #f #f)] + (cond [(empty? candles) empty-renderer2d] [else (match-define (list (vector #{xs : (Listof Real)} #{opens : (Listof Real)} @@ -342,6 +331,6 @@ [x-max (if x-max x-max (+ (apply max* xs) width))] [y-min (if y-min y-min (apply min* lows))] [y-max (if y-max y-max (apply max* highs))]) - (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun #f (candlesticks-render-fun xs opens highs lows closes up-color down-color line-width line-style width alpha)))]))])) diff --git a/plot-lib/plot/private/plot2d/rectangle.rkt b/plot-lib/plot/private/plot2d/rectangle.rkt index 7e235a7b..dc54e5c9 100644 --- a/plot-lib/plot/private/plot2d/rectangle.rkt +++ b/plot-lib/plot/private/plot2d/rectangle.rkt @@ -16,9 +16,8 @@ Plot-Color Plot-Brush-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 2D-Render-Proc)) -(define ((rectangles-render-proc rects color style line-color line-width line-style alpha label) +(define ((rectangles-render-proc rects color style line-color line-width line-style alpha) area) (match-define (vector (ivl bx-min bx-max) (ivl by-min by-max)) (send area get-bounds-rect)) (send area put-pen line-color line-width line-style) @@ -30,10 +29,7 @@ (define x-max (if (and vx-max (infinite? vx-max)) bx-max vx-max)) (define y-min (if (and vy-min (infinite? vy-min)) by-min vy-min)) (define y-max (if (and vy-max (infinite? vy-max)) by-max vy-max)) - (send area put-rect (vector (ivl x-min x-max) (ivl y-min y-max)))) - - (cond [label (rectangle-legend-entry label color style line-color line-width line-style)] - [else empty])) + (send area put-rect (vector (ivl x-min x-max) (ivl y-min y-max))))) (:: rectangles (->* [(Sequenceof (Sequenceof ivl))] @@ -78,7 +74,7 @@ (define rxs (filter valid? (append x1s x2s))) (define rys (filter valid? (append y1s y2s))) (cond - [(or (empty? rxs) (empty? rys)) (renderer2d #f #f #f #f)] + [(or (empty? rxs) (empty? rys)) empty-renderer2d] [else (let ([x-min (if x-min x-min (apply min* rxs))] [x-max (if x-max x-max (apply max* rxs))] @@ -95,8 +91,10 @@ (rational? y-min) (rational? y-max) (vector (ivl x-min x-max) (ivl y-min y-max)))) (renderer2d bounds #f default-ticks-fun + (and label (λ (_) (rectangle-legend-entry label color style + line-color line-width line-style))) (rectangles-render-proc rects color style line-color line-width line-style - alpha label)))]))])) + alpha)))]))])) ;; =================================================================================================== ;; Real histograms (or histograms on the real line) @@ -139,7 +137,7 @@ [bin-bounds (filter rational? bin-bounds)] [bin-bounds (sort bin-bounds <)]) (cond - [((length bin-bounds) . < . 2) (renderer2d #f #f #f #f)] + [((length bin-bounds) . < . 2) empty-renderer2d] [else (define xs (linear-seq (apply min* bin-bounds) (apply max* bin-bounds) samples #:start? #f #:end? #f)) @@ -248,7 +246,7 @@ (list y1 y2)] [else (list y)]))))) (cond - [(empty? rys) (renderer2d #f #f #f #f)] + [(empty? rys) empty-renderer2d] [else (define n (length cats)) (let* ([x-min (if x-min x-min 0)] @@ -265,10 +263,12 @@ (renderer2d (maybe-invert (ivl x-min x-max) (ivl y-min y-max)) #f (discrete-histogram-ticks-fun cats tick-xs add-ticks? far-ticks? maybe-invert) + (and label (λ (_) (rectangle-legend-entry label color style + line-color line-width line-style))) (rectangles-render-proc (map (λ ([x-ivl : ivl] [y-ivl : ivl]) (maybe-invert x-ivl y-ivl)) x-ivls y-ivls) - color style line-color line-width line-style alpha label)))]))])) + color style line-color line-width line-style alpha)))]))])) (:: stacked-histogram (->* [(Sequenceof (U (Vector Any (Sequenceof Real)) diff --git a/plot-lib/plot/private/plot2d/renderer.rkt b/plot-lib/plot/private/plot2d/renderer.rkt index a438a3a9..65a2029b 100644 --- a/plot-lib/plot/private/plot2d/renderer.rkt +++ b/plot-lib/plot/private/plot2d/renderer.rkt @@ -3,10 +3,15 @@ (require "../common/plot-element.rkt" "../common/types.rkt" "../common/type-doc.rkt" + "../common/math.rkt" "plot-area.rkt") (provide (all-defined-out)) -(deftype 2D-Render-Proc (-> (Instance 2D-Plot-Area%) (Treeof legend-entry))) +(deftype 2D-Render-Proc (-> (Instance 2D-Plot-Area%) Void)) -(struct renderer2d plot-element ([render-proc : (U #f 2D-Render-Proc)]) #:transparent) +(struct renderer2d plot-element ([label : (U #f (-> Rect (Treeof legend-entry)))] + [render-proc : (U #f 2D-Render-Proc)]) + #:transparent) + +(define empty-renderer2d (renderer2d #f #f #f #f #f)) diff --git a/plot-lib/plot/private/plot3d/arrows.rkt b/plot-lib/plot/private/plot3d/arrows.rkt index 72c82c45..22a50e2f 100644 --- a/plot-lib/plot/private/plot3d/arrows.rkt +++ b/plot-lib/plot/private/plot3d/arrows.rkt @@ -16,26 +16,19 @@ Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real (U (List '= Nonnegative-Real) Nonnegative-Real) Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) (define ((arrows3d-render-fun vs color line-width line-style alpha - arrow-head-size-or-scale arrow-head-angle - label) area) + arrow-head-size-or-scale arrow-head-angle) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (send area get-bounds-rect)) - (cond - [(and x-min x-max y-min y-max z-min z-max) + (when (and x-min x-max y-min y-max z-min z-max) (send area put-alpha alpha) (send area put-pen color line-width line-style) (send area put-arrow-head arrow-head-size-or-scale arrow-head-angle) (for ([x (in-list vs)]) - (send area put-arrow (car x) (cdr x) #t)) - (cond [label (arrow-legend-entry label color line-width line-style)] - [else empty])] - [else empty]) - ) + (send area put-arrow (car x) (cdr x) #t)))) (define-type LVof (All (A) (U (Listof A)(Vectorof A)))) @@ -120,14 +113,14 @@ (filter vrational? (append p1 p2)))) (cond - [(empty? rvs) (renderer3d #f #f #f #f)] + [(empty? rvs) empty-renderer3d] [else (define-values (x- x+ y- y+ z- z+) (get-bounds x-min x-max y-min y-max z-min z-max rvs)) (renderer3d (vector (ivl x- x+) (ivl y- y+) (ivl z- z+)) #f default-ticks-fun + (and label (λ (_) (arrow-legend-entry label color width style))) (arrows3d-render-fun vs* color width style alpha - arrow-head-size-or-scale arrow-head-angle - label))])])) + arrow-head-size-or-scale arrow-head-angle))])])) (define (get-bounds [x-min : (Option Real)][x-max : (Option Real)] diff --git a/plot-lib/plot/private/plot3d/contour.rkt b/plot-lib/plot/private/plot3d/contour.rkt index d80ea120..3bf50e62 100644 --- a/plot-lib/plot/private/plot3d/contour.rkt +++ b/plot-lib/plot/private/plot3d/contour.rkt @@ -14,9 +14,8 @@ (: isoline3d-render-proc (-> 2D-Sampler Real Positive-Integer Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((isoline3d-render-proc f z samples color width style alpha label) area) +(define ((isoline3d-render-proc f z samples color width style alpha) area) (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) (match-define (ivl z-min z-max) z-ivl) (define num (animated-samples samples)) @@ -30,9 +29,7 @@ (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) (match-define (list v1 v2) line) (send area put-line v1 v2)))) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + (void)) (:: isoline3d (->* [(-> Real Real Real) Real] @@ -77,54 +74,80 @@ (define g (2d-function->sampler f (vector x-ivl y-ivl))) (renderer3d (vector x-ivl y-ivl z-ivl) #f default-ticks-fun - (isoline3d-render-proc g z samples color width style alpha label)))])) + (and label (λ (_) (line-legend-entry label color width style))) + (isoline3d-render-proc g z samples color width style alpha)))])) ;; =================================================================================================== ;; Contour lines in 3D (using marching squares) -(: contours3d-render-proc (-> 2D-Sampler Contour-Levels Positive-Integer - (Plot-Colors (Listof Real)) - (Pen-Widths (Listof Real)) - (Plot-Pen-Styles (Listof Real)) - (Alphas (Listof Real)) - (U String pict #f) - 3D-Render-Proc)) -(define ((contours3d-render-proc f levels samples colors widths styles alphas label) area) - (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) - (match-define (ivl x-min x-max) x-ivl) - (match-define (ivl y-min y-max) y-ivl) - (match-define (ivl z-min z-max) z-ivl) - (cond - [(and z-min z-max) - (define num (animated-samples samples)) - (define sample (f (vector x-ivl y-ivl) (vector num num))) - ;; can't use the actual z ticks because some or all could be collapsed - (match-define (list (tick #{zs : (Listof Real)} - #{_ : (Listof Boolean)} - #{labels : (Listof String)}) - ...) - (contour-ticks (plot-z-ticks) z-min z-max levels #f)) - - (let* ([colors (generate-list colors zs)] - [widths (generate-list widths zs)] - [styles (generate-list styles zs)] - [alphas (generate-list alphas zs)]) - (for ([z (in-list zs)] - [color (in-cycle* (in-list colors))] - [width : Nonnegative-Real (in-cycle* (in-list widths))] - [style (in-cycle* (in-list styles))] - [alpha : Nonnegative-Real (in-cycle* (in-list alphas))]) - (send area put-alpha alpha) - (send area put-pen color width style) - (for-2d-sample - (xa xb ya yb z1 z2 z3 z4) sample - (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) - (match-define (list v1 v2) line) - (send area put-line v1 v2)))) - - (cond [label (line-legend-entries label zs labels colors widths styles)] - [else empty]))] - [else empty])) +(: make-contours3d-label-and-render (-> 2D-Sampler Contour-Levels Positive-Integer + (Plot-Colors (Listof Real)) + (Pen-Widths (Listof Real)) + (Plot-Pen-Styles (Listof Real)) + (Alphas (Listof Real)) + (U String pict #f) + (Values (U #f (-> Rect (Treeof legend-entry))) + 3D-Render-Proc))) +(define (make-contours3d-label-and-render f levels samples colors widths styles alphas label) + ;; g is a 2D-sampler, which is a memoized proc. Recalculation here should be cheap. + ;; if we memoize here based on rect, smooth interactions are disabled (because of the call to `plot-z-ticks`) + (define (calculate-zs/labels [rect : Rect]) : (Values 2d-sample (Listof Real) (Listof String)) + (match-define (vector x-ivl y-ivl z-ivl) rect) + (match-define (ivl x-min x-max) x-ivl) + (match-define (ivl y-min y-max) y-ivl) + (match-define (ivl z-min z-max) z-ivl) + (cond + [(and z-min z-max) + (define num (animated-samples samples)) + (define sample (f (vector x-ivl y-ivl) (vector num num))) + ;; can't use the actual z ticks because some or all could be collapsed + (match-define (list (tick #{zs : (Listof Real)} + #{_ : (Listof Boolean)} + #{labels : (Listof String)}) + ...) + (contour-ticks (plot-z-ticks) z-min z-max levels #f)) + (values sample zs labels)] + [else + (values (2d-sample '() '() #() #f #f) empty empty)])) + + (define label-proc + (and label + (λ ([rect : Rect]) + (define-values (_ zs labels) (calculate-zs/labels rect)) + (cond + [(empty? zs) empty] + [else + (let* ([colors (generate-list colors zs)] + [widths (generate-list widths zs)] + [styles (generate-list styles zs)]) + (line-legend-entries label zs labels colors widths styles))])))) + + (: render-proc 3D-Render-Proc) + (define (render-proc area) + (define-values (sample zs _) (calculate-zs/labels (send area get-bounds-rect))) + (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) + (match-define (ivl x-min x-max) x-ivl) + (match-define (ivl y-min y-max) y-ivl) + (match-define (ivl z-min z-max) z-ivl) + (unless (empty? zs) + (let* ([colors (generate-list colors zs)] + [widths (generate-list widths zs)] + [styles (generate-list styles zs)] + [alphas (generate-list alphas zs)]) + (for ([z (in-list zs)] + [color (in-cycle* (in-list colors))] + [width : Nonnegative-Real (in-cycle* (in-list widths))] + [style (in-cycle* (in-list styles))] + [alpha : Nonnegative-Real (in-cycle* (in-list alphas))]) + (send area put-alpha alpha) + (send area put-pen color width style) + (for-2d-sample + (xa xb ya yb z1 z2 z3 z4) sample + (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) + (match-define (list v1 v2) line) + (send area put-line v1 v2))))))) + + (values label-proc render-proc)) (:: contours3d (->* [(-> Real Real Real)] @@ -165,103 +188,132 @@ (define y-ivl (ivl y-min y-max)) (define z-ivl (ivl z-min z-max)) (define g (2d-function->sampler f (vector x-ivl y-ivl))) + (define-values (label-proc render-proc) + (make-contours3d-label-and-render g levels samples colors widths styles alphas label)) (renderer3d (vector x-ivl y-ivl z-ivl) (surface3d-bounds-fun g samples) default-ticks-fun - (contours3d-render-proc g levels samples colors widths styles alphas label))])) + label-proc render-proc)])) ;; =================================================================================================== ;; Contour intervals in 3D (using marching squares) -(: contour-intervals3d-render-proc (-> 2D-Sampler Contour-Levels Positive-Integer - (Plot-Colors (Listof ivl)) - (Plot-Brush-Styles (Listof ivl)) - (Plot-Colors (Listof ivl)) - (Pen-Widths (Listof ivl)) - (Plot-Pen-Styles (Listof ivl)) - (Plot-Colors (Listof Real)) - (Pen-Widths (Listof Real)) - (Plot-Pen-Styles (Listof Real)) - (Alphas (Listof ivl)) - (U String pict #f) - 3D-Render-Proc)) -(define ((contour-intervals3d-render-proc +(: make-contour-intervals3d-label-and-renderer + (-> 2D-Sampler Contour-Levels Positive-Integer + (Plot-Colors (Listof ivl)) + (Plot-Brush-Styles (Listof ivl)) + (Plot-Colors (Listof ivl)) + (Pen-Widths (Listof ivl)) + (Plot-Pen-Styles (Listof ivl)) + (Plot-Colors (Listof Real)) + (Pen-Widths (Listof Real)) + (Plot-Pen-Styles (Listof Real)) + (Alphas (Listof ivl)) + (U String pict #f) + (Values (U #f (-> Rect (Treeof legend-entry))) + 3D-Render-Proc))) +(define (make-contour-intervals3d-label-and-renderer f levels samples colors styles line-colors line-widths line-styles contour-colors contour-widths contour-styles alphas label) - area) - (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) - (match-define (ivl x-min x-max) x-ivl) - (match-define (ivl y-min y-max) y-ivl) - (match-define (ivl z-min z-max) z-ivl) - (cond - [(and z-min z-max) - (define num (animated-samples samples)) - (define sample (f (vector x-ivl y-ivl) (vector num num))) - ;; can't use the actual z ticks because some or all could be collapsed - (match-define (list (tick #{zs : (Listof Real)} - #{_ : (Listof Boolean)} - #{labels : (Listof String)}) - ...) - (contour-ticks (plot-z-ticks) z-min z-max levels #t)) + ;; g is a 2D-sampler, which is a memoized proc. Recalculation here should be cheap. + ;; if we memoize here based on rect, smooth interactions are disabled (because of the call to `plot-z-ticks`) + (define (calculate-zivls/labels [rect : Rect]) : (Values 2d-sample (Listof ivl) (Listof Real) (Listof String)) + (match-define (vector x-ivl y-ivl z-ivl) rect) + (match-define (ivl x-min x-max) x-ivl) + (match-define (ivl y-min y-max) y-ivl) + (match-define (ivl z-min z-max) z-ivl) + (cond + [(and z-min z-max) + (define num (animated-samples samples)) + (define sample (f (vector x-ivl y-ivl) (vector num num))) + ;; can't use the actual z ticks because some or all could be collapsed + (match-define (list (tick #{zs : (Listof Real)} + #{_ : (Listof Boolean)} + #{labels : (Listof String)}) + ...) + (contour-ticks (plot-z-ticks) z-min z-max levels #t)) - (define-values (z-ivls ivl-labels) - (for/lists ([z-ivls : (Listof ivl)] - [ivl-labels : (Listof String)] - ) ([za (in-list zs)] - [zb (in-list (rest zs))] - [la (in-list labels)] - [lb (in-list (rest labels))]) - (values (ivl za zb) (format "[~a,~a]" la lb)))) - - (let* ([colors (generate-list colors z-ivls)] - [styles (generate-list styles z-ivls)] - [alphas (generate-list alphas z-ivls)] - [line-colors (generate-list line-colors z-ivls)] - [line-widths (generate-list line-widths z-ivls)] - [line-styles (generate-list line-styles z-ivls)]) - (for ([za (in-list zs)] - [zb (in-list (rest zs))] - [color (in-cycle* (in-list colors))] - [style (in-cycle* (in-list styles))] - [alpha : Nonnegative-Real (in-cycle* (in-list alphas))] - [line-color (in-cycle* (in-list line-colors))] - [line-width : Nonnegative-Real (in-cycle* (in-list line-widths))] - [line-style (in-cycle* (in-list line-styles))]) - (send area put-alpha alpha) - (send area put-pen line-color line-width line-style) - (send area put-brush color style) - (for-2d-sample - (xa xb ya yb z1 z2 z3 z4) sample - (for ([vs (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) - (define ls - (for/list : (Listof Boolean) ([v1 (in-list (cons (last vs) vs))] - [v2 (in-list vs)]) - (define z1 (vector-ref v1 2)) - (define z2 (vector-ref v2 2)) - (not (or (and (= z1 za) (= z2 za)) - (and (= z1 zb) (= z2 zb)))))) - (send area put-polygon vs 'both ls)))) + (define-values (z-ivls ivl-labels) + (for/lists ([z-ivls : (Listof ivl)] + [ivl-labels : (Listof String)] + ) ([za (in-list zs)] + [zb (in-list (rest zs))] + [la (in-list labels)] + [lb (in-list (rest labels))]) + (values (ivl za zb) (format "[~a,~a]" la lb)))) + + (values sample z-ivls zs ivl-labels)] + [else + (values (2d-sample '() '() #() #f #f) empty empty empty)])) + + (define label-proc + (and label + (λ ([rect : Rect]) + (define-values (_ z-ivls zs ivl-labels) (calculate-zivls/labels rect)) + (let* ([colors (generate-list colors z-ivls)] + [styles (generate-list styles z-ivls)] + [line-colors (generate-list line-colors z-ivls)] + [line-widths (generate-list line-widths z-ivls)] + [line-styles (generate-list line-styles z-ivls)]) + (define n (- (length zs) 2)) + (define contour-colors* + (append (list 0) (sequence-take (in-cycle* (generate-list contour-colors zs)) 0 n) (list 0))) + (define contour-widths* + (append (list 0) (sequence-take (in-cycle* (generate-list contour-widths zs)) 0 n) (list 0))) + (define contour-styles* + (append '(transparent) (sequence-take (in-cycle* (generate-list contour-styles zs)) 0 n) + '(transparent))) - ((contours3d-render-proc f levels samples contour-colors contour-widths contour-styles - alphas #f) - area) + (cond [label (interval-legend-entries + label z-ivls ivl-labels + colors styles line-colors line-widths line-styles + contour-colors* contour-widths* contour-styles* + (rest contour-colors*) (rest contour-widths*) (rest contour-styles*))] + [else empty]))))) + + (: render-proc 3D-Render-Proc) + (define (render-proc area) + (define-values (sample z-ivls zs _) (calculate-zivls/labels (send area get-bounds-rect))) + (unless (empty? zs) - (define n (- (length zs) 2)) - (define contour-colors* - (append (list 0) (sequence-take (in-cycle* (generate-list contour-colors zs)) 0 n) (list 0))) - (define contour-widths* - (append (list 0) (sequence-take (in-cycle* (generate-list contour-widths zs)) 0 n) (list 0))) - (define contour-styles* - (append '(transparent) (sequence-take (in-cycle* (generate-list contour-styles zs)) 0 n) - '(transparent))) + + (let* ([colors (generate-list colors z-ivls)] + [styles (generate-list styles z-ivls)] + [alphas (generate-list alphas z-ivls)] + [line-colors (generate-list line-colors z-ivls)] + [line-widths (generate-list line-widths z-ivls)] + [line-styles (generate-list line-styles z-ivls)]) + (for ([za (in-list zs)] + [zb (in-list (rest zs))] + [color (in-cycle* (in-list colors))] + [style (in-cycle* (in-list styles))] + [alpha : Nonnegative-Real (in-cycle* (in-list alphas))] + [line-color (in-cycle* (in-list line-colors))] + [line-width : Nonnegative-Real (in-cycle* (in-list line-widths))] + [line-style (in-cycle* (in-list line-styles))]) + (send area put-alpha alpha) + (send area put-pen line-color line-width line-style) + (send area put-brush color style) + (for-2d-sample + (xa xb ya yb z1 z2 z3 z4) sample + (for ([vs (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) + (define ls + (for/list : (Listof Boolean) ([v1 (in-list (cons (last vs) vs))] + [v2 (in-list vs)]) + (define z1 (vector-ref v1 2)) + (define z2 (vector-ref v2 2)) + (not (or (and (= z1 za) (= z2 za)) + (and (= z1 zb) (= z2 zb)))))) + (send area put-polygon vs 'both ls)))) + + (define-values (_ render-proc) + (make-contours3d-label-and-render f levels samples contour-colors contour-widths contour-styles + alphas #f)) + (render-proc area) - (cond [label (interval-legend-entries - label z-ivls ivl-labels - colors styles line-colors line-widths line-styles - contour-colors* contour-widths* contour-styles* - (rest contour-colors*) (rest contour-widths*) (rest contour-styles*))] - [else empty]))] - [else empty])) + ))) + + (values label-proc render-proc)) (:: contour-intervals3d (->* [(-> Real Real Real)] @@ -312,10 +364,12 @@ (define y-ivl (ivl y-min y-max)) (define z-ivl (ivl z-min z-max)) (define g (2d-function->sampler f (vector x-ivl y-ivl))) + (define-values (label-proc render-proc) + (make-contour-intervals3d-label-and-renderer g levels samples colors styles + line-colors line-widths line-styles + contour-colors contour-widths contour-styles + alphas label)) (renderer3d (vector x-ivl y-ivl z-ivl) (surface3d-bounds-fun g samples) default-ticks-fun - (contour-intervals3d-render-proc g levels samples colors styles - line-colors line-widths line-styles - contour-colors contour-widths contour-styles - alphas label))])) + label-proc render-proc)])) diff --git a/plot-lib/plot/private/plot3d/decoration.rkt b/plot-lib/plot/private/plot3d/decoration.rkt index 21b0381a..4c1f33b3 100644 --- a/plot-lib/plot/private/plot3d/decoration.rkt +++ b/plot-lib/plot/private/plot3d/decoration.rkt @@ -46,9 +46,7 @@ ; point (send area put-pen point-color point-line-width 'solid) (send area put-brush point-fill-color 'solid) - (send area put-glyphs (list v) point-sym point-size plot3d-front-layer)) - - empty) + (send area put-glyphs (list v) point-sym point-size plot3d-front-layer))) (:: point-label3d (->* [(Sequenceof Real)] @@ -89,7 +87,7 @@ [else (let ([v (sequence-head-vector 'point-label3d v 3)]) (match-define (vector x y z) v) - (renderer3d (vector (ivl x x) (ivl y y) (ivl z z)) #f #f + (renderer3d (vector (ivl x x) (ivl y y) (ivl z z)) #f #f #f (label3d-render-proc label v color size face family anchor angle point-color (cond [(eq? point-fill-color 'auto) (->pen-color point-color)] diff --git a/plot-lib/plot/private/plot3d/isosurface.rkt b/plot-lib/plot/private/plot3d/isosurface.rkt index 32d7a94d..8a18f0aa 100644 --- a/plot-lib/plot/private/plot3d/isosurface.rkt +++ b/plot-lib/plot/private/plot3d/isosurface.rkt @@ -15,10 +15,9 @@ Plot-Color Plot-Brush-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) (define ((isosurface3d-render-proc - f d samples color style line-color line-width line-style alpha label) + f d samples color style line-color line-width line-style alpha) area) (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) (match-define (ivl x-min x-max) x-ivl) @@ -35,10 +34,7 @@ (xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8) sample (for ([vs (in-list (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))]) (send area put-polygon vs))) - - (cond [label (rectangle-legend-entry - label color style line-color line-width line-style)] - [else empty])) + (void)) (:: isosurface3d (->* [(-> Real Real Real Real) Real] @@ -82,65 +78,82 @@ (define z-ivl (ivl z-min z-max)) (define g (3d-function->sampler f (vector x-ivl y-ivl z-ivl))) (renderer3d (vector x-ivl y-ivl z-ivl) #f default-ticks-fun + (and label (λ (_) (rectangle-legend-entry + label color style line-color line-width line-style))) (isosurface3d-render-proc - g d samples color style line-color line-width line-style alpha label))])) + g d samples color style line-color line-width line-style alpha))])) ;; =================================================================================================== ;; Nested isosurfaces -(: isosurfaces3d-render-proc +(: make-isosurfaces3d-label-and-renderer (-> 3D-Sampler (U Real #f) (U Real #f) Contour-Levels Positive-Integer (Plot-Colors (Listof Real)) (Plot-Brush-Styles (Listof Real)) (Plot-Colors (Listof Real)) (Pen-Widths (Listof Real)) (Plot-Pen-Styles (Listof Real)) (Alphas (Listof Real)) (U String pict #f) - 3D-Render-Proc)) -(define ((isosurfaces3d-render-proc f rd-min rd-max levels samples colors styles + (Values (U #f (-> Rect (Treeof legend-entry))) + 3D-Render-Proc))) +(define (make-isosurfaces3d-label-and-renderer f rd-min rd-max levels samples colors styles line-colors line-widths line-styles alphas label) - area) - (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) - (match-define (ivl x-min x-max) x-ivl) - (match-define (ivl y-min y-max) y-ivl) - (match-define (ivl z-min z-max) z-ivl) - (define num (animated-samples samples)) - (define sample (f (vector x-ivl y-ivl z-ivl) (vector num num num))) - (match-define (3d-sample xs ys zs dsss fd-min fd-max) sample) + ;; g is a 3D-sampler, which is a memoized proc. Recalculation here should be cheap. + ;; if we memoize here based on rect, smooth interactions are disabled (because of the call to `plot-z-ticks`) + (define (calculate-ds/labels [rect : Rect]) : (Values 3d-sample (Listof Real) (Listof String)) + (match-define (vector x-ivl y-ivl z-ivl) rect) + (match-define (ivl x-min x-max) x-ivl) + (match-define (ivl y-min y-max) y-ivl) + (match-define (ivl z-min z-max) z-ivl) + (define num (animated-samples samples)) + (define sample (f (vector x-ivl y-ivl z-ivl) (vector num num num))) + (match-define (3d-sample xs ys zs dsss fd-min fd-max) sample) + + (define d-min (if rd-min rd-min fd-min)) + (define d-max (if rd-max rd-max fd-max)) - (define d-min (if rd-min rd-min fd-min)) - (define d-max (if rd-max rd-max fd-max)) + (match-define (list (tick #{ds : (Listof Real)} + #{_ : (Listof Bolean)} + #{labels : (Listof String)}) + ...) + (cond [(and d-min d-max) (contour-ticks (plot-d-ticks) d-min d-max levels #f)] + [else empty])) + + (values sample ds labels)) + + (define label-proc + (and label + (λ ([rect : Rect]) + (define-values (_ ds labels) (calculate-ds/labels rect)) + (cond + [(empty? ds) empty] + [else (rectangle-legend-entries + label ds colors styles line-colors line-widths line-styles)])))) - (match-define (list (tick #{ds : (Listof Real)} - #{_ : (Listof Bolean)} - #{labels : (Listof String)}) - ...) - (cond [(and d-min d-max) (contour-ticks (plot-d-ticks) d-min d-max levels #f)] - [else empty])) + (: render-proc 3D-Render-Proc) + (define (render-proc area) + (define-values (sample ds _) (calculate-ds/labels (send area get-bounds-rect))) - (let* ([colors (generate-list colors ds)] - [styles (generate-list styles ds)] - [alphas (generate-list alphas ds)] - [line-colors (generate-list line-colors ds)] - [line-widths (generate-list line-widths ds)] - [line-styles (generate-list line-styles ds)]) - (for ([d (in-list ds)] - [color (in-cycle* colors)] - [style (in-cycle* styles)] - [alpha : Nonnegative-Real (in-cycle* alphas)] - [line-color (in-cycle* line-colors)] - [line-width : Nonnegative-Real (in-cycle* line-widths)] - [line-style (in-cycle* line-styles)]) - (send area put-alpha alpha) - (send area put-brush color style) - (send area put-pen line-color line-width line-style) - (for-3d-sample - (xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8) sample - (for ([vs (in-list (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))]) - (send area put-polygon vs))))) + (let* ([colors (generate-list colors ds)] + [styles (generate-list styles ds)] + [alphas (generate-list alphas ds)] + [line-colors (generate-list line-colors ds)] + [line-widths (generate-list line-widths ds)] + [line-styles (generate-list line-styles ds)]) + (for ([d (in-list ds)] + [color (in-cycle* colors)] + [style (in-cycle* styles)] + [alpha : Nonnegative-Real (in-cycle* alphas)] + [line-color (in-cycle* line-colors)] + [line-width : Nonnegative-Real (in-cycle* line-widths)] + [line-style (in-cycle* line-styles)]) + (send area put-alpha alpha) + (send area put-brush color style) + (send area put-pen line-color line-width line-style) + (for-3d-sample + (xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8) sample + (for ([vs (in-list (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))]) + (send area put-polygon vs)))))) - (cond - [(and label (not (empty? ds))) (rectangle-legend-entries - label ds colors styles line-colors line-widths line-styles)] - [else empty])) + (values label-proc render-proc)) (:: isosurfaces3d (->* [(-> Real Real Real Real)] @@ -186,10 +199,12 @@ (define y-ivl (ivl y-min y-max)) (define z-ivl (ivl z-min z-max)) (define g (3d-function->sampler f (vector x-ivl y-ivl z-ivl))) + (define-values (label-proc render-proc) + (make-isosurfaces3d-label-and-renderer g d-min d-max levels samples colors styles + line-colors line-widths line-styles alphas + label)) (renderer3d (vector x-ivl y-ivl z-ivl) #f default-ticks-fun - (isosurfaces3d-render-proc g d-min d-max levels samples colors styles - line-colors line-widths line-styles alphas - label))])) + label-proc render-proc)])) ;; =================================================================================================== @@ -197,9 +212,8 @@ Plot-Color Plot-Brush-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((polar3d-render-proc f g samples color style line-color line-width line-style alpha label) +(define ((polar3d-render-proc f g samples color style line-color line-width line-style alpha) area) (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) (match-define (ivl x-min x-max) x-ivl) @@ -235,10 +249,7 @@ (draw-cube xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))] [else (draw-cube xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8)])) - - (cond [label (rectangle-legend-entry - label color style line-color line-width line-style)] - [else empty])) + (void)) (define 2pi (* 2 pi)) @@ -301,7 +312,7 @@ [ϕ (in-list (linear-seq (* -1/2 pi) (* 1/2 pi) (* 2 samples)))]) (3d-polar->3d-cartesian θ ϕ (f θ ϕ)))) (define rvs (filter vrational? vs)) - (cond [(empty? rvs) (renderer3d #f #f #f #f)] + (cond [(empty? rvs) empty-renderer3d] [else (match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)} @@ -321,5 +332,7 @@ (define g (3d-function->sampler new-f (vector x-ivl y-ivl z-ivl))) (renderer3d (vector x-ivl y-ivl z-ivl) #f default-ticks-fun + (and label (λ (_) (rectangle-legend-entry + label color style line-color line-width line-style))) (polar3d-render-proc new-f g samples color style - line-color line-width line-style alpha label)))])])) + line-color line-width line-style alpha)))])])) diff --git a/plot-lib/plot/private/plot3d/line.rkt b/plot-lib/plot/private/plot3d/line.rkt index 7ea0eefa..686a48dd 100644 --- a/plot-lib/plot/private/plot3d/line.rkt +++ b/plot-lib/plot/private/plot3d/line.rkt @@ -13,15 +13,11 @@ (: lines3d-render-proc (-> (-> (Listof (Vectorof Real))) Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((lines3d-render-proc vs-fun color width style alpha label) area) +(define ((lines3d-render-proc vs-fun color width style alpha) area) (send area put-alpha alpha) (send area put-pen color width style) - (send area put-lines (vs-fun)) - - (cond [label (line-legend-entry label color width style)] - [else empty])) + (send area put-lines (vs-fun))) (: lines3d-renderer (-> (-> (Listof (Vectorof Real))) (U #f Real) (U #f Real) (U #f Real) (U #f Real) (U #f Real) (U #f Real) @@ -32,7 +28,7 @@ (define (lines3d-renderer vs-thnk x-min x-max y-min y-max z-min z-max color width style alpha label) (define rvs (filter vrational? (vs-thnk))) - (cond [(empty? rvs) (renderer3d #f #f #f #f)] + (cond [(empty? rvs) empty-renderer3d] [else (match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)} @@ -47,7 +43,8 @@ [z-max (if z-max z-max (apply max* rzs))]) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun - (lines3d-render-proc vs-thnk color width style alpha label)))])) + (and label (λ (_) (line-legend-entry label color width style))) + (lines3d-render-proc vs-thnk color width style alpha)))])) (:: lines3d (->* [(Sequenceof (Sequenceof Real))] diff --git a/plot-lib/plot/private/plot3d/param-surf.rkt b/plot-lib/plot/private/plot3d/param-surf.rkt index 8867f73f..89ffd8d4 100644 --- a/plot-lib/plot/private/plot3d/param-surf.rkt +++ b/plot-lib/plot/private/plot3d/param-surf.rkt @@ -13,18 +13,14 @@ Plot-Color Plot-Brush-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((polygons3d-render-proc vs-fun color style line-color line-width line-style alpha label) +(define ((polygons3d-render-proc vs-fun color style line-color line-width line-style alpha) area) (send area put-alpha alpha) (send area put-brush color style) (send area put-pen line-color line-width line-style) (for ([v (in-list (vs-fun))]) - (send area put-polygon v)) - - (cond [label (rectangle-legend-entry label color style line-color line-width line-style)] - [else empty])) + (send area put-polygon v))) (: polygons3d-renderer (-> (-> (Listof (Listof (Vectorof Real)))) (U #f Real) (U #f Real) (U #f Real) (U #f Real) (U #f Real) (U #f Real) @@ -37,7 +33,7 @@ color style line-color line-width line-style alpha label) (define rvs (filter vrational? (apply append (vs-thnk)))) (cond - [(empty? rvs) (renderer3d #f #f #f #f)] + [(empty? rvs) empty-renderer3d] [else (match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)} @@ -53,8 +49,9 @@ (renderer3d (vector (ivl x-min x-max)(ivl y-min y-max)(ivl z-min z-max)) #f ;surface3d-bounds-fun default-ticks-fun + (and label (λ (_) (rectangle-legend-entry label color style line-color line-width line-style))) (polygons3d-render-proc vs-thnk - color style line-color line-width line-style alpha label)))])) + color style line-color line-width line-style alpha)))])) (:: polygons3d (->* [(Sequenceof (Sequenceof (Sequenceof Real)))] [#:x-min (U #f Real) #:x-max (U #f Real) diff --git a/plot-lib/plot/private/plot3d/point.rkt b/plot-lib/plot/private/plot3d/point.rkt index 17e3834b..f80cfc0f 100644 --- a/plot-lib/plot/private/plot3d/point.rkt +++ b/plot-lib/plot/private/plot3d/point.rkt @@ -21,16 +21,12 @@ Plot-Color Plot-Color Nonnegative-Real Nonnegative-Real Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((points3d-render-proc vs sym color fill-color size line-width alpha label) area) +(define ((points3d-render-proc vs sym color fill-color size line-width alpha) area) (send area put-alpha alpha) (send area put-pen color line-width 'solid) (send area put-brush fill-color 'solid) - (send area put-glyphs vs sym size) - - (cond [label (point-legend-entry label sym color fill-color size line-width)] - [else empty])) + (send area put-glyphs vs sym size)) (:: points3d (->* [(Sequenceof (Sequenceof Real))] @@ -75,7 +71,7 @@ [else (let* ([vs (sequence->listof-vector 'points3d vs 3)] [vs (filter vrational? vs)]) - (cond [(empty? vs) (renderer3d #f #f #f #f)] + (cond [(empty? vs) empty-renderer3d] [else (unless (= 0 x-jitter y-jitter z-jitter) (points-apply-jitters vs (vector x-jitter y-jitter z-jitter) @@ -96,8 +92,9 @@ [fill-color (if (eq? fill-color 'auto) (->pen-color color) fill-color)]) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun + (and label (λ (_) (point-legend-entry label sym color fill-color size line-width))) (points3d-render-proc vs sym color fill-color - size line-width alpha label)))]))])) + size line-width alpha)))]))])) ;; =================================================================================================== @@ -106,59 +103,53 @@ Positive-Integer (U Real 'auto 'normalized) Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((vector-field3d-render-fun f samples scale color line-width line-style alpha label) area) +(define ((vector-field3d-render-fun f samples scale color line-width line-style alpha) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (send area get-bounds-rect)) - (cond - [(and x-min x-max y-min y-max z-min z-max) - (define xs0 (linear-seq x-min x-max samples #:start? #t #:end? #t)) - (define ys0 (linear-seq y-min y-max samples #:start? #t #:end? #t)) - (define zs0 (linear-seq z-min z-max samples #:start? #t #:end? #t)) + (when (and x-min x-max y-min y-max z-min z-max) + (define xs0 (linear-seq x-min x-max samples #:start? #t #:end? #t)) + (define ys0 (linear-seq y-min y-max samples #:start? #t #:end? #t)) + (define zs0 (linear-seq z-min z-max samples #:start? #t #:end? #t)) - (define-values (vs dxs dys dzs norms mags) - (for*/lists ([vs : (Listof (Vectorof Real))] - [dxs : (Listof Real)] - [dys : (Listof Real)] - [dzs : (Listof Real)] - [norms : (Listof (Vectorof Real))] - [mags : (Listof Nonnegative-Real)] - ) ([x (in-list xs0)] - [y (in-list ys0)] - [z (in-list zs0)] - [dv (in-value (f x y z))] #:when (vrational? dv)) - (match-define (vector dx dy dz) dv) - (values (vector x y z) dx dy dz (vnormalize dv) (vmag dv)))) + (define-values (vs dxs dys dzs norms mags) + (for*/lists ([vs : (Listof (Vectorof Real))] + [dxs : (Listof Real)] + [dys : (Listof Real)] + [dzs : (Listof Real)] + [norms : (Listof (Vectorof Real))] + [mags : (Listof Nonnegative-Real)] + ) ([x (in-list xs0)] + [y (in-list ys0)] + [z (in-list zs0)] + [dv (in-value (f x y z))] #:when (vrational? dv)) + (match-define (vector dx dy dz) dv) + (values (vector x y z) dx dy dz (vnormalize dv) (vmag dv)))) - (cond [(empty? vs) empty] - [else (define box-x-size (/ (- x-max x-min) samples)) - (define box-y-size (/ (- y-max y-min) samples)) - (define box-z-size (/ (- z-max z-min) samples)) - - (define new-mags - (match scale - [(? real?) (map (λ ([mag : Real]) (* scale mag)) mags)] - ['normalized (make-list (length dxs) (min box-x-size box-y-size box-z-size))] - ['auto (define dx-max (real->double-flonum (apply max (map abs dxs)))) - (define dy-max (real->double-flonum (apply max (map abs dys)))) - (define dz-max (real->double-flonum (apply max (map abs dzs)))) - (define scale (min (/ box-x-size dx-max) - (/ box-y-size dy-max) - (/ box-z-size dz-max))) - (map (λ ([mag : Real]) (* scale mag)) mags)])) + (unless (empty? vs) + (define box-x-size (/ (- x-max x-min) samples)) + (define box-y-size (/ (- y-max y-min) samples)) + (define box-z-size (/ (- z-max z-min) samples)) - (send area put-alpha alpha) - (send area put-pen color line-width line-style) - (for ([v (in-list vs)] - [norm (in-list norms)] - [mag (in-list new-mags)]) - (send area put-arrow v (v+ v (v* norm mag)))) + (define new-mags + (match scale + [(? real?) (map (λ ([mag : Real]) (* scale mag)) mags)] + ['normalized (make-list (length dxs) (min box-x-size box-y-size box-z-size))] + ['auto (define dx-max (real->double-flonum (apply max (map abs dxs)))) + (define dy-max (real->double-flonum (apply max (map abs dys)))) + (define dz-max (real->double-flonum (apply max (map abs dzs)))) + (define scale (min (/ box-x-size dx-max) + (/ box-y-size dy-max) + (/ box-z-size dz-max))) + (map (λ ([mag : Real]) (* scale mag)) mags)])) - (cond [label (arrow-legend-entry label color line-width line-style)] - [else empty])])] - [else empty])) + (send area put-alpha alpha) + (send area put-pen color line-width line-style) + (for ([v (in-list vs)] + [norm (in-list norms)] + [mag (in-list new-mags)]) + (send area put-arrow v (v+ v (v* norm mag))))))) (:: vector-field3d (->* [(U (-> Real Real Real (Sequenceof Real)) @@ -198,5 +189,6 @@ [else (let ([f (fix-vector-field3d-fun 'vector-field3d f)]) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun + (and label (λ (_) (arrow-legend-entry label color line-width line-style))) (vector-field3d-render-fun - f samples scale color line-width line-style alpha label)))])) + f samples scale color line-width line-style alpha)))])) diff --git a/plot-lib/plot/private/plot3d/rectangle.rkt b/plot-lib/plot/private/plot3d/rectangle.rkt index 282146fe..aa90d5ac 100644 --- a/plot-lib/plot/private/plot3d/rectangle.rkt +++ b/plot-lib/plot/private/plot3d/rectangle.rkt @@ -15,18 +15,14 @@ Plot-Color Plot-Brush-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((rectangles3d-render-proc rects color style line-color line-width line-style alpha label) +(define ((rectangles3d-render-proc rects color style line-color line-width line-style alpha) area) (send area put-pen line-color line-width line-style) (send area put-brush color style) (send area put-alpha alpha) (for ([rect (in-list rects)]) - (send area put-rect rect)) - - (cond [label (rectangle-legend-entry label color style line-color line-width line-style)] - [else empty])) + (send area put-rect rect))) (:: rectangles3d (->* [(Sequenceof (Sequenceof ivl))] @@ -76,7 +72,7 @@ (define rys (filter rational? (append y1s y2s))) (define rzs (filter rational? (append z1s z2s))) (cond - [(or (empty? rxs) (empty? rys) (empty? rzs)) (renderer3d #f #f #f #f)] + [(or (empty? rxs) (empty? rys) (empty? rzs)) empty-renderer3d] [else (let ([x-min (if x-min x-min (apply min* rxs))] [x-max (if x-max x-max (apply max* rxs))] @@ -86,8 +82,10 @@ [z-max (if z-max z-max (apply max* rzs))]) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun + (and label (λ (_) (rectangle-legend-entry + label color style line-color line-width line-style))) (rectangles3d-render-proc rects color style line-color line-width line-style - alpha label)))]))])) + alpha)))]))])) ;; =================================================================================================== ;; Discrete histograms @@ -185,7 +183,7 @@ (list z1 z2)] [else (list z)]))))) (cond - [(empty? rzs) (renderer3d #f #f #f #f)] + [(empty? rzs) empty-renderer3d] [else (define c1s (remove-duplicates cat1s)) (define c2s (remove-duplicates cat2s)) @@ -234,8 +232,10 @@ (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f (discrete-histogram3d-ticks-fun c1s c2s tick-xs tick-ys add-x-ticks? add-y-ticks? x-far-ticks? y-far-ticks?) + (and label (λ (_) (rectangle-legend-entry + label color style line-color line-width line-style))) (rectangles3d-render-proc rects color style line-color line-width line-style - alpha label)))]))])) + alpha)))]))])) (:: stacked-histogram3d (->* [(Sequenceof (U (Vector Any Any (Sequenceof Real)) diff --git a/plot-lib/plot/private/plot3d/renderer.rkt b/plot-lib/plot/private/plot3d/renderer.rkt index 9326307f..e1a26b70 100644 --- a/plot-lib/plot/private/plot3d/renderer.rkt +++ b/plot-lib/plot/private/plot3d/renderer.rkt @@ -3,10 +3,15 @@ (require "../common/plot-element.rkt" "../common/types.rkt" "../common/type-doc.rkt" + "../common/math.rkt" "plot-area.rkt") (provide (all-defined-out)) -(deftype 3D-Render-Proc (-> (Instance 3D-Plot-Area%) (Treeof legend-entry))) +(deftype 3D-Render-Proc (-> (Instance 3D-Plot-Area%) Void)) -(struct renderer3d plot-element ([render-proc : (U #f 3D-Render-Proc)]) #:transparent) +(struct renderer3d plot-element ([label : (U #f (-> Rect (Treeof legend-entry)))] + [render-proc : (U #f 3D-Render-Proc)]) + #:transparent) + +(define empty-renderer3d (renderer3d #f #f #f #f #f)) diff --git a/plot-lib/plot/private/plot3d/surface.rkt b/plot-lib/plot/private/plot3d/surface.rkt index 727af46e..1aa37991 100644 --- a/plot-lib/plot/private/plot3d/surface.rkt +++ b/plot-lib/plot/private/plot3d/surface.rkt @@ -15,9 +15,8 @@ Plot-Color Plot-Brush-Style Plot-Color Nonnegative-Real Plot-Pen-Style Nonnegative-Real - (U String pict #f) 3D-Render-Proc)) -(define ((surface3d-render-proc f samples color style line-color line-width line-style alpha label) +(define ((surface3d-render-proc f samples color style line-color line-width line-style alpha) area) (match-define (vector x-ivl y-ivl z-ivl) (send area get-bounds-rect)) (define num (animated-samples samples)) @@ -30,9 +29,7 @@ (xa xb ya yb z1 z2 z3 z4) sample (define vs (list (vector xa ya z1) (vector xb ya z2) (vector xb yb z3) (vector xa yb z4))) (send area put-polygon vs)) - - (cond [label (rectangle-legend-entry label color style line-color line-width line-style)] - [else empty])) + (void)) (:: surface3d (->* [(-> Real Real Real)] @@ -75,5 +72,6 @@ (renderer3d (vector x-ivl y-ivl z-ivl) (surface3d-bounds-fun g samples) default-ticks-fun + (and label (λ (_) (rectangle-legend-entry label color style line-color line-width line-style))) (surface3d-render-proc g samples color style - line-color line-width line-style alpha label))])) + line-color line-width line-style alpha))])) diff --git a/plot-lib/plot/private/utils-and-no-gui.rkt b/plot-lib/plot/private/utils-and-no-gui.rkt index a2567765..d2a44b07 100644 --- a/plot-lib/plot/private/utils-and-no-gui.rkt +++ b/plot-lib/plot/private/utils-and-no-gui.rkt @@ -313,4 +313,6 @@ (struct-out plot-element) (struct-out nonrenderer) (struct-out renderer2d) - (struct-out renderer3d)) + empty-renderer2d + (struct-out renderer3d) + empty-renderer3d)