diff --git a/collects/plot/common/format.rkt b/collects/plot/common/format.rkt index 173210e5f7..797e9b6b47 100644 --- a/collects/plot/common/format.rkt +++ b/collects/plot/common/format.rkt @@ -51,9 +51,10 @@ ;; Returns the number of fractional digits needed to distinguish numbers [x-min..x-max] (defproc (digits-for-range [x-min real?] [x-max real?] + [base (and/c exact-integer? (>=/c 2)) 10] [extra-digits exact-integer? 3]) exact-integer? (define range (abs (- x-max x-min))) - (+ extra-digits (if (zero? range) 0 (- (floor-log/base 10 range))))) + (+ extra-digits (if (zero? range) 0 (- (floor-log/base base range))))) (define (int-str->e-str str) (define n (string-length str)) @@ -144,14 +145,14 @@ [(-inf.0) "-inf.0"] [else ""])) -(defproc (ivl->string [i ivl?] [extra-digits exact-integer? 3]) string? +(defproc (ivl->plot-label [i ivl?] [extra-digits exact-integer? 3]) string? (match-define (ivl a b) i) (cond [(and (not (rational? a)) (not (rational? b))) (format "[~a,~a]" (format-special a) (format-special b))] [(not (rational? a)) (format "[~a,~a]" (format-special a) (real->plot-label b 15))] [(not (rational? b)) (format "[~a,~a]" (real->plot-label a 15) (format-special b))] [else - (define digits (digits-for-range a b extra-digits)) + (define digits (digits-for-range a b 10 extra-digits)) (format "[~a,~a]" (real->plot-label a digits) (real->plot-label b digits))])) @@ -161,6 +162,7 @@ (cond [(string? a) a] [(symbol? a) (symbol->string a)] [(real? a) (real->plot-label a digits)] + [(ivl? a) (ivl->plot-label a)] [(list? a) (string-append "(" (string-join (map loop a) " ") ")")] [(cons? a) (string-append "(" (loop (car a)) " . " (loop (cdr a)) ")")] [(boolean? a) (if a "true" "false")] diff --git a/collects/plot/common/snip.rkt b/collects/plot/common/snip.rkt index 8aa845af56..c637ee1c55 100644 --- a/collects/plot/common/snip.rkt +++ b/collects/plot/common/snip.rkt @@ -21,6 +21,13 @@ (define/public (get-saved-plot-parameters) saved-plot-parameters) + (define x-mid (* 1/2 (send bm get-width))) + (define y-mid (* 1/2 (send bm get-height))) + + (define/public (set-message-center new-x-mid new-y-mid) + (set! x-mid new-x-mid) + (set! y-mid new-y-mid)) + (define/public (refresh) ;(printf "~a: refresh~n" (current-milliseconds)) (set-bitmap (get-bitmap))) @@ -58,14 +65,24 @@ (define box-x-size (apply max line-widths)) (define box-y-size (+ baseline (* (length lines) (+ char-height baseline)))) - (define box-x-min (+ dc-x-min (* 1/2 (- width box-x-size)))) - (define box-y-min (+ dc-y-min (* 1/2 (- height box-y-size)))) - (define box-x-max (+ box-x-min box-x-size)) - (define box-y-max (+ box-y-min box-y-size)) + (define box-x-min (+ dc-x-min (- x-mid (* 1/2 box-x-size)))) + (define box-x-max (+ dc-x-min (+ x-mid (* 1/2 box-x-size)))) + (define box-y-min (+ dc-y-min (- y-mid (* 1/2 box-y-size)))) + (define box-y-max (+ dc-y-min (+ y-mid (* 1/2 box-y-size)))) - (send pd set-alpha 2/3) + (define box-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max))) + + ;; inside selection + (send pd set-pen (plot-foreground) 1 'transparent) + (send pd set-brush (plot-background) 'solid) + (send pd set-alpha 1/4) + (send pd draw-rect box-rect) + + ;; selection border (send pd set-minor-pen) - (send pd draw-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max))) + (send pd set-brush (plot-background) 'transparent) + (send pd set-alpha 3/4) + (send pd draw-rect box-rect) (send pd set-alpha 1) (for ([line (in-list lines)] [i (in-naturals)]) diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index f6d105f2d5..d8429df907 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -593,16 +593,25 @@ (let ([x (- x w)]) (format "~a ~a/~a" w (numerator x) (denominator x)))])])) -(defproc (fraction-ticks-format) ticks-format/c +(defproc (fraction-ticks-format [#:base base (and/c exact-integer? (>=/c 2)) 10] + [#:divisors divisors (listof exact-positive-integer?) '(1 2 3 4 5)] + ) ticks-format/c + (define fracs (remove-duplicates (map (λ (d) (/ d base)) divisors))) (λ (x-min x-max ts) + (define digits (digits-for-range x-min x-max base (ceiling-log/base base 1000))) + (define fracs (remove-duplicates (map (λ (d) (* (/ base d) (expt base (- digits)))) divisors))) (for/list ([t (in-list ts)]) - (format-fraction (pre-tick-value t))))) + (define x (inexact->exact (pre-tick-value t))) + (define xs + (for/list ([frac (in-list fracs)]) + (* frac (round (/ x frac))))) + (format-fraction (argmin (λ (y) (abs (- x y))) xs))))) (defproc (fraction-ticks [#:base base (and/c exact-integer? (>=/c 2)) 10] [#:divisors divisors (listof exact-positive-integer?) '(1 2 3 4 5)] ) ticks? #:document-body (ticks (linear-ticks #:base base #:divisors divisors) - (fraction-ticks-format))) + (fraction-ticks-format #:base base #:divisors divisors))) ;; =================================================================================================== ;; Tick combinators diff --git a/collects/plot/contracted/format.rkt b/collects/plot/contracted/format.rkt index d637f44b42..2abd949ea8 100644 --- a/collects/plot/contracted/format.rkt +++ b/collects/plot/contracted/format.rkt @@ -7,5 +7,5 @@ integer->superscript digits-for-range real->decimal-string* real->string/trunc - real->plot-label ivl->string ->plot-label + real->plot-label ivl->plot-label ->plot-label parse-format-string apply-formatter)) diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index 5f9b6218ea..8cd5f838c7 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -41,7 +41,7 @@ (rect-zero-area? plot-bounds-rect)) (match-define (vector x-ivl y-ivl) plot-bounds-rect) (error 'plot "could not determine sensible plot bounds; got x ∈ ~a, y ∈ ~a" - (ivl->string x-ivl) (ivl->string y-ivl))) + (ivl->plot-label x-ivl) (ivl->plot-label y-ivl))) plot-bounds-rect) (define (get-ticks renderer-list bounds-rect) diff --git a/collects/plot/plot2d/snip.rkt b/collects/plot/plot2d/snip.rkt index 683eef663f..521218af3d 100644 --- a/collects/plot/plot2d/snip.rkt +++ b/collects/plot/plot2d/snip.rkt @@ -25,6 +25,12 @@ (super-make-object bm saved-plot-parameters) + (define (set-message-center) + (match-define (vector x-mid y-mid) (rect-center area-bounds-rect)) + (send this set-message-center x-mid y-mid)) + + (set-message-center) + (define/override (copy) (make-object this% (get-bitmap) (get-saved-plot-parameters) @@ -37,7 +43,7 @@ (define plot-bounds-rects empty) - (define (get-area-bounds-rect) + (define (get-new-area-bounds-rect) (rect-meet area-bounds-rect (rect-inexact->exact (vector (ivl left-click-x left-drag-x) (ivl left-click-y left-drag-y))))) @@ -58,12 +64,32 @@ (set-message "Click and drag to zoom\n Click to unzoom once"))) (define (update-plot new-plot-bounds-rect) - (define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds) - (make-plot new-plot-bounds-rect)) - (set! plot-bounds-rect new-plot-bounds-rect) - (set! area-bounds-rect new-area-bounds-rect) - (set! area-bounds->plot-bounds new-area-bounds->plot-bounds) - (set-bitmap new-bm)) + (with-handlers ([(λ (e) #t) (λ (e) + (refresh) + (make-object timer% (λ () (raise e)) 1))]) + (define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds) + (make-plot new-plot-bounds-rect)) + (set! plot-bounds-rect new-plot-bounds-rect) + (set! area-bounds-rect new-area-bounds-rect) + (set! area-bounds->plot-bounds new-area-bounds->plot-bounds) + (set-bitmap new-bm) + (set-message-center))) + + (define (zoom-or-unzoom) + (cond [dragging? + (set! dragging? #f) + (define new-rect (area-bounds->plot-bounds (get-new-area-bounds-rect))) + (cond [(and (rect-rational? new-rect) (not (rect-zero-area? new-rect))) + #;(printf "~a: new-plot-bounds-rect = ~v~n" + (current-milliseconds) new-rect) + (set! plot-bounds-rects (cons plot-bounds-rect plot-bounds-rects)) + (update-plot new-rect)] + [else (refresh)])] + [(not (empty? plot-bounds-rects)) + (define new-rect (first plot-bounds-rects)) + (set! plot-bounds-rects (rest plot-bounds-rects)) + (set! show-zoom-message? #f) + (update-plot new-rect)])) (define/override (on-event dc x y editorx editory evt) (define evt-type (send evt get-event-type)) @@ -79,21 +105,8 @@ (set-zoom-timer)] [(left-up) (set! left-drag-x mouse-x) (set! left-drag-y mouse-y) - (cond [dragging? - (set! dragging? #f) - (define new-rect (area-bounds->plot-bounds (get-area-bounds-rect))) - (cond [(and (rect-rational? new-rect) (not (rect-zero-area? new-rect))) - #;(printf "~a: new-plot-bounds-rect = ~v~n" - (current-milliseconds) new-rect) - (set! plot-bounds-rects (cons plot-bounds-rect plot-bounds-rects)) - (update-plot new-rect)] - [else (refresh)])] - [(not (empty? plot-bounds-rects)) - (define new-rect (first plot-bounds-rects)) - (set! plot-bounds-rects (rest plot-bounds-rects)) - (update-plot new-rect) - (set! show-zoom-message? #f)])] - [(motion) (cond [(get-left-down-here?) ; not event's left-down: only #t if clicked on snip + (zoom-or-unzoom)] + [(motion) (cond [(get-left-down-here?) ; only #t if clicked on snip (when (not (and (= left-drag-x mouse-x) (= left-drag-y mouse-y))) (set! left-drag-x mouse-x) @@ -106,72 +119,75 @@ (set-click-message)])]) (super on-event dc x y editorx editory evt)) - (define/override (draw dc dc-x-min dc-y-min left top right bottom dx dy draw-caret) + (define (draw-selection dc dc-x-min dc-y-min rect) + (when (and (rect-rational? rect) (not (rect-zero-area? rect))) + (define width (send (get-bitmap) get-width)) + (define height (send (get-bitmap) get-height)) + + (define pd (make-object plot-device% dc dc-x-min dc-y-min width height)) + (send pd reset-drawing-params #f) + + (define select-color (get-highlight-background-color)) + (define select-rect (rect-translate rect (vector dc-x-min dc-y-min))) + + ;; inside selection + (send pd set-pen select-color 1 'transparent) + (send pd set-brush select-color 'solid) + (send pd set-alpha 1/4) + (send pd draw-rect select-rect) + + ;; selection border + (send pd set-minor-pen) + (send pd set-brush select-color 'transparent) + (send pd set-alpha 3/4) + (send pd draw-rect select-rect) + + ;; format side labels + (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect) + (match-define (vector (ivl new-x-min new-x-max) (ivl new-y-min new-y-max)) + (area-bounds->plot-bounds rect)) + + (match-define (list new-x-min-str new-x-max-str) + ((ticks-format (plot-x-ticks)) + x-min x-max (list (pre-tick new-x-min #t) (pre-tick new-x-max #t)))) + + (match-define (list new-y-min-str new-y-max-str) + ((ticks-format (plot-y-ticks)) + y-min y-max (list (pre-tick new-y-min #t) (pre-tick new-y-max #t)))) + + ;; draw side labels + (match-define (vector (ivl new-area-x-min new-area-x-max) + (ivl new-area-y-min new-area-y-max)) + rect) + (define new-area-x-mid (* 1/2 (+ new-area-x-min new-area-x-max))) + (define new-area-y-mid (* 1/2 (+ new-area-y-min new-area-y-max))) + + (send pd set-alpha 1) + + (send pd draw-text new-x-min-str + (vector (+ dc-x-min new-area-x-min) (+ dc-y-min new-area-y-mid)) + 'center (* 1/2 pi) #:outline? #t) + + (send pd draw-text new-x-max-str + (vector (+ dc-x-min new-area-x-max) (+ dc-y-min new-area-y-mid)) + 'center (* 1/2 pi) #:outline? #t) + + (send pd draw-text new-y-min-str + (vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-max)) + 'center #:outline? #t) + + (send pd draw-text new-y-max-str + (vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-min)) + 'center #:outline? #t) + + (send pd restore-drawing-params))) + + (define/override (draw dc x y left top right bottom dx dy draw-caret) ;(printf "~a: drawing~n" (current-milliseconds)) - (super draw dc dc-x-min dc-y-min left top right bottom dx dy draw-caret) + (super draw dc x y left top right bottom dx dy draw-caret) (when dragging? - (define new-rect (get-area-bounds-rect)) - (when (and (rect-rational? new-rect) (not (rect-zero-area? new-rect))) - (define width (send (get-bitmap) get-width)) - (define height (send (get-bitmap) get-height)) - - (define pd (make-object plot-device% dc dc-x-min dc-y-min width height)) - (send pd reset-drawing-params #f) - - (define select-color (get-highlight-background-color)) - (define draw-rect (rect-translate new-rect (vector dc-x-min dc-y-min))) - - ;; inside of selection box - (send pd set-pen select-color 1 'transparent) - (send pd set-brush select-color 'solid) - (send pd set-alpha 1/4) - (send pd draw-rect draw-rect) - - ;; border of selection box - (send pd set-minor-pen) - (send pd set-brush select-color 'transparent) - (send pd set-alpha 3/4) - (send pd draw-rect draw-rect) - - ;; side labels - (parameterize/group ([plot-parameters (get-saved-plot-parameters)]) - (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect) - (match-define (vector (ivl new-area-x-min new-area-x-max) - (ivl new-area-y-min new-area-y-max)) - new-rect) - (match-define (vector (ivl new-x-min new-x-max) (ivl new-y-min new-y-max)) - (area-bounds->plot-bounds new-rect)) - - (define new-area-x-mid (* 1/2 (+ new-area-x-min new-area-x-max))) - (define new-area-y-mid (* 1/2 (+ new-area-y-min new-area-y-max))) - - ;; format new-x-min and new-x-max - (match-define (list new-x-min-str new-x-max-str) - ((ticks-format (plot-x-ticks)) - x-min x-max (list (pre-tick new-x-min #t) (pre-tick new-x-max #t)))) - ;; draw new-x-min - (send pd draw-text new-x-min-str - (vector (+ dc-x-min new-area-x-min) (+ dc-y-min new-area-y-mid)) - 'center (* 1/2 pi) #:outline? #t) - ;; draw new-x-max - (send pd draw-text new-x-max-str - (vector (+ dc-x-min new-area-x-max) (+ dc-y-min new-area-y-mid)) - 'center (* 1/2 pi) #:outline? #t) - - ;; format new-y-min and new-y-max - (match-define (list new-y-min-str new-y-max-str) - ((ticks-format (plot-y-ticks)) - y-min y-max (list (pre-tick new-y-min #t) (pre-tick new-y-max #t)))) - ;; draw new-y-min - (send pd draw-text new-y-min-str - (vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-max)) - 'center #:outline? #t) - ;; draw new-y-max - (send pd draw-text new-y-max-str - (vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-min)) - 'center #:outline? #t)) - - (send pd restore-drawing-params)))) + (parameterize/group ([plot-parameters (get-saved-plot-parameters)]) + (draw-selection dc x y (get-new-area-bounds-rect))))) )) (define (make-2d-plot-snip bm saved-plot-parameters diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index 458b21299d..03d48f852d 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -41,7 +41,7 @@ (rect-zero-area? plot-bounds-rect)) (match-define (vector x-ivl y-ivl z-ivl) plot-bounds-rect) (error 'plot "could not determine sensible plot bounds; got x ∈ ~a, y ∈ ~a, z ∈ ~a" - (ivl->string x-ivl) (ivl->string y-ivl) (ivl->string z-ivl))) + (ivl->plot-label x-ivl) (ivl->plot-label y-ivl) (ivl->plot-label z-ivl))) plot-bounds-rect) (define (get-ticks renderer-list bounds-rect) diff --git a/collects/plot/tests/selection-tests.rkt b/collects/plot/tests/selection-tests.rkt new file mode 100644 index 0000000000..c8281fa592 --- /dev/null +++ b/collects/plot/tests/selection-tests.rkt @@ -0,0 +1,24 @@ +#lang racket + +;; These tests aren't meant to be run so much as manipulated after running + +(require plot plot/utils) + +(parameterize ([plot-x-transform log-transform]) + (plot (function values +min.0 1))) + +(define raise-error? #f) + +(plot (function (λ (x) + (when raise-error? + (error 'buh "buh buh")) + (sin x)) + -4 4)) + +(plot3d (surface3d (λ (x y) + (when raise-error? + (error 'buh "buh buh buh")) + (- (sqr x) (sqr y))) + -1 1 -1 1)) + +(set! raise-error? #t)