diff --git a/collects/plot/common/math.rkt b/collects/plot/common/math.rkt index 1efd1aadba..0b25858d62 100644 --- a/collects/plot/common/math.rkt +++ b/collects/plot/common/math.rkt @@ -589,6 +589,10 @@ (for/fold ([res empty-ivl]) ([i (in-list is)]) (ivl-join2 res i))) +(defproc (ivl-translate [i ivl?] [d real?]) ivl? + (match-define (ivl a b) i) + (ivl (and a (+ a d)) (and b (+ b d)))) + (defproc (bounds->intervals [xs (listof real?)]) (listof ivl?) (cond [((length xs) . < . 2) (raise-type-error 'bounds->intervals "list with length >= 2" xs)] [else @@ -650,3 +654,6 @@ (define (rect-join . rs) (apply vector-map ivl-join rs)) + +(defproc (rect-translate [r (vectorof ivl?)] [v (vectorof real?)]) (vectorof ivl?) + (vector-map ivl-translate r v)) diff --git a/collects/plot/common/snip.rkt b/collects/plot/common/snip.rkt new file mode 100644 index 0000000000..a47bc2a1f8 --- /dev/null +++ b/collects/plot/common/snip.rkt @@ -0,0 +1,83 @@ +#lang racket/base + +(require racket/gui/base racket/class racket/list unstable/parameter-group + "math.rkt" + "parameters.rkt" + "plot-device.rkt") + +(provide plot-snip%) + +(define message-timeout 2000) + +(define plot-snip% + (class image-snip% + (init bm) + (init-field saved-plot-parameters) + (inherit set-bitmap get-bitmap) + + (super-make-object bm) + + (define/override (copy) (make-object this% (get-bitmap) saved-plot-parameters)) + + (define/public (get-saved-plot-parameters) saved-plot-parameters) + + (define/public (refresh) + ;(printf "~a: refresh~n" (current-milliseconds)) + (set-bitmap (get-bitmap))) + + (define message #f) + (define message-timer (make-object timer% (λ () (stop-message)))) + + (define/public (stop-message) + ;(printf "~a: stop-message~n" (current-milliseconds)) + (send message-timer stop) + (set! message #f) + (refresh)) + + (define/public (reset-message-timeout) + (send message-timer start message-timeout #t)) + + (define/public (set-message msg #:refresh? [refresh? #t]) + (define refresh? (and refresh? (not (equal? msg message)))) + (set! message msg) + (reset-message-timeout) + (when refresh? (refresh))) + + (define (draw-message dc dc-x-min dc-y-min) + (define bm (get-bitmap)) + (define width (send bm get-width)) + (define height (send bm get-height)) + + (define pd (make-object plot-device% dc dc-x-min dc-y-min width height)) + (send pd reset-drawing-params #f) + + (define lines (map (λ (line) (format " ~a " line)) (regexp-split "\n" message))) + + (define-values (_1 char-height baseline _2) (send pd get-text-extent (first lines))) + (define line-widths (map (λ (line) (send pd get-text-width line)) lines)) + + (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)) + + (send pd set-alpha 2/3) + (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-alpha 1) + (for ([line (in-list lines)] [i (in-naturals)]) + (send pd draw-text + line (vector box-x-min (+ box-y-min baseline (* i (+ char-height baseline)))) + 'top-left #: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 x y left top right bottom dx dy draw-caret) + ;(send dc draw-bitmap-section bm x y 0 0 width height) + (when message + (parameterize/group ([plot-parameters saved-plot-parameters]) + (draw-message dc x y)))))) diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index b6c21af339..f6d105f2d5 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -22,7 +22,7 @@ #:property prop:procedure (λ (t x-min x-max) (match-define (ticks layout format) t) - (define ts (layout x-min x-max)) + (define ts (map pre-tick-inexact->exact (layout x-min x-max))) (match-define (list (pre-tick xs majors) ...) ts) (map tick xs majors (format x-min x-max ts)))) @@ -633,9 +633,11 @@ (pre-tick x major?)))) format)) -(defproc (linear-scale [m real?] [b real? 0]) invertible-function? #:document-body - (invertible-function (λ (x) (+ (* m x) b)) - (λ (y) (/ (- y b) m)))) +(defproc (linear-scale [m rational?] [b rational? 0]) invertible-function? #:document-body + (let ([m (inexact->exact m)] + [b (inexact->exact b)]) + (invertible-function (λ (x) (+ (* m x) b)) + (λ (y) (/ (- y b) m))))) ;; =================================================================================================== ;; Tick utils @@ -665,3 +667,11 @@ [(m . = . 0) (list (collapse-equiv-ticks ts near-format-string))] [(m . = . 1) (filter pre-tick-major? ts)] [else (list (collapse-equiv-ticks (filter pre-tick-major? ts) near-format-string))]))))) + +(defproc (pre-tick-inexact->exact [t tick?]) tick? + (match-define (pre-tick x major?) t) + (pre-tick (inexact->exact x) major?)) + +(defproc (tick-inexact->exact [t tick?]) tick? + (match-define (tick x major? label) t) + (tick (inexact->exact x) major? label)) diff --git a/collects/plot/plot2d/plot-area.rkt b/collects/plot/plot2d/plot-area.rkt index 08c1474d32..f9feca9e4c 100644 --- a/collects/plot/plot2d/plot-area.rkt +++ b/collects/plot/plot2d/plot-area.rkt @@ -83,8 +83,8 @@ (and (equal? (plot-x-transform) id-transform) (equal? (plot-y-transform) id-transform))) - (match-define (invertible-function fx _) (apply-axis-transform (plot-x-transform) x-min x-max)) - (match-define (invertible-function fy _) (apply-axis-transform (plot-y-transform) y-min y-max)) + (match-define (invertible-function fx gx) (apply-axis-transform (plot-x-transform) x-min x-max)) + (match-define (invertible-function fy gy) (apply-axis-transform (plot-y-transform) y-min y-max)) (define plot->view (cond [identity-transforms? (λ (v) v)] @@ -135,16 +135,20 @@ (vector x (pre-tick-value t2)))) (define x-ticks - (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) + (map tick-inexact->exact rx-ticks)) (x-tick-near? y-min))) (define x-far-ticks - (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) + (map tick-inexact->exact rx-far-ticks)) (x-tick-near? y-max))) (define y-ticks - (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) + (map tick-inexact->exact ry-ticks)) (y-tick-near? x-min))) (define y-far-ticks - (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) + (map tick-inexact->exact ry-far-ticks)) (y-tick-near? x-max))) ;; =============================================================================================== @@ -305,6 +309,25 @@ (define area-y-min (+ dc-y-min top)) (define area-y-max (- dc-y-max bottom)) + (define/public (get-area-bounds-rect) + (vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max))) + + (define view->plot + (cond [identity-transforms? (λ (v) v)] + [else (λ (v) (match-let ([(vector x y) v]) + (vector (gx x) (gy y))))])) + + (define dc->view + (let ([area-per-view-x (/ (- area-x-max area-x-min) view-x-size)] + [area-per-view-y (/ (- area-y-max area-y-min) view-y-size)]) + (λ (v) + (match-define (vector x y) v) + (vector (+ x-min (/ (- x area-x-min) area-per-view-x)) + (+ y-min (/ (- area-y-max y) area-per-view-y)))))) + + (define/public (dc->plot v) + (view->plot (dc->view v))) + ;; =============================================================================================== ;; Plot decoration diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index f5935242d3..5f9b6218ea 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -15,6 +15,7 @@ "../common/deprecation-warning.rkt" "../common/contract-doc.rkt" "../common/format.rkt" + "snip.rkt" "plot-area.rkt") ;; Require lazily: without this, Racket complains while generating documentation: @@ -150,12 +151,56 @@ [#:y-label y-label (or/c string? #f) (plot-y-label)] [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)] ) (is-a?/c image-snip%) - (define bm - (plot-bitmap - renderer-tree - #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:width width #:height height - #:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)) - (make-object image-snip% bm)) + (parameterize ([plot-title title] + [plot-x-label x-label] + [plot-y-label y-label] + [plot-legend-anchor legend-anchor]) + (define saved-plot-parameters (plot-parameters)) + (define renderer-list (get-renderer-list renderer-tree)) + (define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max)) + + (define (make-plot bounds-rect) + (define area #f) + (define bm + (parameterize/group ([plot-parameters saved-plot-parameters]) + ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) + (λ (dc) + (define-values (x-ticks x-far-ticks y-ticks y-far-ticks) + (get-ticks renderer-list bounds-rect)) + (set! area (make-object 2d-plot-area% + bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks + dc 0 0 width height)) + + (send area start-plot) + + (define legend-entries + (flatten (for/list ([rend (in-list renderer-list)]) + (match-define (renderer2d rend-bounds-rect _bf _tf render-proc) rend) + (send area start-renderer + (if rend-bounds-rect rend-bounds-rect (empty-rect 2))) + (if render-proc (render-proc area) empty)))) + + (send area end-renderers) + + (when (not (empty? legend-entries)) + (send area draw-legend legend-entries)) + + (send area end-plot)) + width height))) + + (define (area-bounds->plot-bounds rect) + (match-define (vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max)) rect) + (match-define (vector x-min y-min) (send area dc->plot (vector area-x-min area-y-min))) + (match-define (vector x-max y-max) (send area dc->plot (vector area-x-max area-y-max))) + (vector (ivl x-min x-max) (ivl y-min y-max))) + + (values bm (send area get-area-bounds-rect) area-bounds->plot-bounds)) + + (define-values (bm area-bounds-rect area-bounds->plot-bounds) (make-plot bounds-rect)) + + (make-2d-plot-snip + bm saved-plot-parameters + make-plot bounds-rect area-bounds-rect area-bounds->plot-bounds))) ;; Plot to a frame (defproc (plot-frame [renderer-tree (treeof (or/c renderer2d? nonrenderer?))] diff --git a/collects/plot/plot2d/snip.rkt b/collects/plot/plot2d/snip.rkt new file mode 100644 index 0000000000..2adabbfa09 --- /dev/null +++ b/collects/plot/plot2d/snip.rkt @@ -0,0 +1,189 @@ +#lang racket/base + +(require racket/gui/base racket/class racket/match racket/list racket/math unstable/parameter-group + "../common/snip.rkt" + "../common/plot-device.rkt" + "../common/math.rkt" + "../common/format.rkt" + "../common/ticks.rkt" + "../common/parameters.rkt") + +(provide 2d-plot-snip% make-2d-plot-snip) + +(define zoom-delay 16) ; about 60 fps (just over) + +(define 2d-plot-snip% + (class plot-snip% + (init bm saved-plot-parameters) + (init-field make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds) + + (inherit set-bitmap get-bitmap + get-saved-plot-parameters + refresh set-message reset-message-timeout get-admin) + + (super-make-object bm saved-plot-parameters) + + (define/override (copy) + (make-object this% + (get-bitmap) (get-saved-plot-parameters) + make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds)) + + (define left-click-x 0) + (define left-click-y 0) + (define left-drag-x 0) + (define left-drag-y 0) + + (define plot-bounds-rects empty) + + (define (get-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))))) + + (define dragging? #f) + (define left-down? #f) ; only #t if left-down happened on this snip + (define zoom-timer #f) + + (define (set-zoom-timer) + (when (not zoom-timer) + (set! zoom-timer (make-object timer% (λ () + (set! zoom-timer #f) + (refresh)) + zoom-delay #t)))) + + (define zoomed? #f) + (define unzoomed? #f) + (define (set-click-message) + (cond [(and zoomed? unzoomed?) (void)] + [zoomed? (set-message "Click to unzoom once")] + [unzoomed? (set-message "Click and drag to zoom")] + [else (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)) + + (define/override (on-event dc x y editorx editory evt) + (define evt-type (send evt get-event-type)) + (define mouse-x (- (send evt get-x) x)) + (define mouse-y (- (send evt get-y) y)) + (case evt-type + [(left-down) (set! left-click-x mouse-x) + (set! left-click-y mouse-y) + (set! left-drag-x mouse-x) + (set! left-drag-y mouse-y) + (set! dragging? #f) + (set! left-down? #t) + (set-message #f) + (set-zoom-timer)] + [(left-up) (set! left-drag-x mouse-x) + (set! left-drag-y mouse-y) + (set! left-down? #f) + (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) + (set! zoomed? #t)] + [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! unzoomed? #t)])] + [(motion) (cond [left-down? ; not event's left-down: 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) + (set! left-drag-y mouse-y) + (set! dragging? #t) + (set-zoom-timer))] + [(and (not (send evt get-left-down)) + (<= 0 mouse-x (send (get-bitmap) get-width)) + (<= 0 mouse-y (send (get-bitmap) get-height))) + (set-click-message)])])) + + (define/override (draw dc dc-x-min dc-y-min 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) + (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/8) + (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)))) + + (define cross-cursor (make-object cursor% 'cross)) + (define/override (adjust-cursor dc x y editorx editory evt) cross-cursor) + + (send this set-flags (list* 'handles-events 'handles-all-mouse-events (send this get-flags))))) + +(define (make-2d-plot-snip bm saved-plot-parameters + make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds) + (make-object 2d-plot-snip% + bm saved-plot-parameters + make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds)) diff --git a/collects/plot/plot3d/plot-area.rkt b/collects/plot/plot3d/plot-area.rkt index da98a79566..fc0ec55736 100644 --- a/collects/plot/plot3d/plot-area.rkt +++ b/collects/plot/plot3d/plot-area.rkt @@ -247,23 +247,29 @@ (vector x y (pre-tick-value t2)))) (define x-ticks - (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) + (map tick-inexact->exact rx-ticks)) (x-ticks-near? x-axis-y))) (define y-ticks - (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) + (map tick-inexact->exact ry-ticks)) (y-ticks-near? y-axis-x))) (define z-ticks - (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks) + (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) + (map tick-inexact->exact rz-ticks)) (z-ticks-near? z-axis-x z-axis-y))) (define x-far-ticks - (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) + (map tick-inexact->exact rx-far-ticks)) (x-ticks-near? x-far-axis-y))) (define y-far-ticks - (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) + (map tick-inexact->exact ry-far-ticks)) (y-ticks-near? y-far-axis-x))) (define z-far-ticks - (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks) + (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) + (map tick-inexact->exact rz-far-ticks)) (z-ticks-near? z-far-axis-x z-far-axis-y))) ;; =============================================================================================== diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index 1cc73cf604..458b21299d 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -190,40 +190,43 @@ (define render-list-hash (make-hash)) (define legend-entries-hash (make-hash)) + (define (make-bm anim? angle altitude) + (parameterize/group ([plot-parameters saved-plot-parameters] + [plot-animating? (if anim? #t (plot-animating?))] + [plot3d-angle angle] + [plot3d-altitude altitude]) + ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) + (λ (dc) + (define area (make-object 3d-plot-area% + bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks + dc 0 0 width height)) + (send area start-plot) + + (cond [(not (hash-ref render-list-hash (plot-animating?) #f)) + (hash-set! + legend-entries-hash (plot-animating?) + (flatten (for/list ([rend (in-list renderer-list)]) + (match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend) + (send area start-renderer (cond [rend-bounds-rect rend-bounds-rect] + [else (empty-rect 3)])) + (if render-proc (render-proc area) empty)))) + + (hash-set! render-list-hash (plot-animating?) (send area get-render-list))] + [else + (send area put-render-list (hash-ref render-list-hash (plot-animating?)))]) + + (send area end-renderers) + + (define legend-entries (hash-ref legend-entries-hash (plot-animating?) #f)) + (when (not (empty? legend-entries)) + (send area draw-legend legend-entries)) + + (send area end-plot)) + width height))) + (make-3d-plot-snip - (λ (anim? angle altitude) - (parameterize ([plot-animating? (if anim? #t (plot-animating?))] - [plot3d-angle angle] - [plot3d-altitude altitude]) - ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) - (λ (dc) - (define area (make-object 3d-plot-area% - bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks - dc 0 0 width height)) - (send area start-plot) - - (cond [(not (hash-ref render-list-hash (plot-animating?) #f)) - (hash-set! - legend-entries-hash (plot-animating?) - (flatten (for/list ([rend (in-list renderer-list)]) - (match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend) - (send area start-renderer (cond [rend-bounds-rect rend-bounds-rect] - [else (empty-rect 3)])) - (if render-proc (render-proc area) empty)))) - - (hash-set! render-list-hash (plot-animating?) (send area get-render-list))] - [else - (send area put-render-list (hash-ref render-list-hash (plot-animating?)))]) - - (send area end-renderers) - - (define legend-entries (hash-ref legend-entries-hash (plot-animating?) #f)) - (when (not (empty? legend-entries)) - (send area draw-legend legend-entries)) - - (send area end-plot)) - width height))) - angle altitude saved-plot-parameters))) + (make-bm #f angle altitude) saved-plot-parameters + make-bm angle altitude))) ;; Plot to a frame (defproc (plot3d-frame [renderer-tree (treeof (or/c renderer3d? nonrenderer?))] diff --git a/collects/plot/plot3d/snip.rkt b/collects/plot/plot3d/snip.rkt index ce62e4068b..3ba5412397 100644 --- a/collects/plot/plot3d/snip.rkt +++ b/collects/plot/plot3d/snip.rkt @@ -1,17 +1,14 @@ #lang racket/base -(require racket/gui/base racket/class racket/match racket/list unstable/parameter-group - "../common/gui.rkt" +(require racket/gui/base racket/class racket/match unstable/parameter-group + "../common/snip.rkt" "../common/math.rkt" "../common/worker-thread.rkt" - "../common/plot-device.rkt" - "../common/parameters.rkt" - "plot-area.rkt") + "../common/parameters.rkt") (provide 3d-plot-snip% make-3d-plot-snip) (define update-delay 16) ; about 60 fps (just over) -(define message-timeout 2000) (struct draw-command (animating? angle altitude) #:transparent) @@ -19,38 +16,41 @@ (make-worker-thread (match-lambda [(draw-command animating? angle altitude) - (parameterize/group ([plot-parameters saved-plot-parameters]) - (make-bm animating? angle altitude))]))) + (make-bm animating? angle altitude)]))) (define (clamp x mn mx) (min* (max* x mn) mx)) (define 3d-plot-snip% - (class image-snip% - (init-field make-bm angle altitude saved-plot-parameters - [bm (make-bm #f angle altitude)]) - (inherit set-bitmap) + (class plot-snip% + (init bm saved-plot-parameters) + (init-field make-bm angle altitude) - (super-make-object bm) + (inherit set-bitmap get-bitmap get-saved-plot-parameters set-message reset-message-timeout) + + (super-make-object bm saved-plot-parameters) (define/override (copy) - (make-object this% make-bm angle altitude saved-plot-parameters bm)) - - (define width (send bm get-width)) - (define height (send bm get-height)) + (make-object this% + (get-bitmap) (get-saved-plot-parameters) + make-bm angle altitude)) (define left-click-x 0) (define left-click-y 0) (define left-drag-x 0) (define left-drag-y 0) - (define (new-angle) (real-modulo (+ angle (* (- left-drag-x left-click-x) (/ 180 width))) 360)) - (define (new-altitude) (clamp (+ altitude (* (- left-drag-y left-click-y) (/ 180 height))) 0 90)) + (define (new-angle) + (define degrees-per-pixel (/ 180 (send (get-bitmap) get-width))) + (define dx (- left-drag-x left-click-x)) + (real-modulo (+ angle (* dx degrees-per-pixel)) 360)) - (define (refresh) - ;(printf "refreshing ~a~n" (current-milliseconds)) - (send this set-bitmap bm)) + (define (new-altitude) + (define degrees-per-pixel (/ 180 (send (get-bitmap) get-height))) + (define dy (- left-drag-y left-click-y)) + (clamp (+ altitude (* dy degrees-per-pixel)) 0 90)) (define draw? #t) + (define left-down? #f) ; only #t if left-down happened on this snip (define update-timer #f) (define rth (make-render-thread make-bm saved-plot-parameters)) @@ -77,130 +77,64 @@ (when (and draw? can-draw?) (set! draw? #f) (worker-thread-put rth (draw-command #t (new-angle) (new-altitude)))) - (refresh-message-timer)) - - (define message #f) - (define message-timer #f) - - (define (stop-message) - ;(printf "stop-message ~a~n" (current-milliseconds)) - (when message-timer - (send message-timer stop) - (set! message-timer #f) - (set! message #f) - (refresh))) - - (define (refresh-message-timer) - (when message-timer - (send message-timer stop)) - (set! message-timer (make-object timer% stop-message message-timeout))) - - (define (set-message msg) - (refresh-message-timer) - (set! message msg)) + (reset-message-timeout)) (define (set-angles-message angle altitude) (set-message (format "angle = ~a\naltitude = ~a" - (number->string (round angle)) - (number->string (round altitude))))) + (number->string (inexact->exact (round angle))) + (number->string (inexact->exact (round altitude)))) + #:refresh? #f)) - (define (start-message msg) - (define refresh? (not (equal? msg message))) - (set-message msg) - (when refresh? (refresh))) - - (define dragged? #f) - (define (start-click-message) - (unless dragged? - (start-message "Click and drag to rotate"))) + (define rotated? #f) + (define (set-click-message) + (unless rotated? + (set-message "Click and drag to rotate"))) (define/override (on-event dc x y editorx editory evt) (define evt-type (send evt get-event-type)) - #;(when (not (eq? evt-type 'motion)) - (printf "evt-type = ~v~n" evt-type)) - #;(when (eq? evt-type 'motion) - (printf "motion for ~a; x,y = ~a,~a~n" (eq-hash-code this) (send evt get-x) (send evt get-y))) + (define mouse-x (- (send evt get-x) x)) + (define mouse-y (- (send evt get-y) y)) (case evt-type [(left-down) (worker-thread-wait rth) + (set! left-click-x mouse-x) + (set! left-click-y mouse-y) + (set! left-drag-x mouse-x) + (set! left-drag-y mouse-y) (set! angle (new-angle)) (set! altitude (new-altitude)) (set-angles-message angle altitude) - (set! left-click-x (send evt get-x)) - (set! left-click-y (send evt get-y)) - (set! left-drag-x left-click-x) - (set! left-drag-y left-click-y) + (set! left-down? #t) (set! draw? #t) (start-update-timer)] - [(left-up) (when update-timer + [(left-up) (when left-down? (stop-update-timer) (set! draw? #f) + (set! left-down? #f) (worker-thread-wait rth) - (set! left-drag-x (send evt get-x)) - (set! left-drag-y (send evt get-y)) + (set! left-drag-x mouse-x) + (set! left-drag-y mouse-y) (set! angle (new-angle)) (set! altitude (new-altitude)) (set-angles-message angle altitude) - (set! left-click-x 0) - (set! left-click-y 0) - (set! left-drag-x 0) - (set! left-drag-y 0) - (worker-thread-put rth (draw-command #f angle altitude)) - (define new-bm (worker-thread-get rth)) + (define new-bm (worker-thread-send rth (draw-command #f angle altitude))) (when (is-a? new-bm bitmap%) - (set! bm new-bm) - (set-bitmap bm)))] - [(motion) (when (and update-timer (send evt get-left-down)) - (when (not (and (= left-drag-x (send evt get-x)) - (= left-drag-y (send evt get-y)))) - (set! left-drag-x (send evt get-x)) - (set! left-drag-y (send evt get-y)) - (set! draw? #t) - (set! dragged? #t))) - (when (and (not (send evt get-left-down)) - (<= x (send evt get-x) (+ x width)) - (<= y (send evt get-y) (+ y height))) - (start-click-message))])) - - (define (draw-message dc dc-x-min dc-y-min) - (define pd (make-object plot-device% dc dc-x-min dc-y-min width height)) - (send pd reset-drawing-params #f) - - (define lines (map (λ (line) (format " ~a " line)) (regexp-split "\n" message))) - - (define-values (_1 char-height baseline _2) (send pd get-text-extent (first lines))) - (define line-widths (map (λ (line) (send pd get-text-width line)) lines)) - - (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)) - - (send pd set-alpha 2/3) - (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-alpha 1) - (for ([line (in-list lines)] [i (in-naturals)]) - (send pd draw-text - line (vector box-x-min (+ box-y-min baseline (* i (+ char-height baseline)))) - 'top-left #:outline? #t)) - (send pd restore-drawing-params)) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - ;(printf "drawing ~a~n" (current-milliseconds)) - (super draw dc x y left top right bottom dx dy draw-caret) - ;(send dc draw-bitmap-section bm x y 0 0 width height) - (when message - (parameterize/group ([plot-parameters saved-plot-parameters]) - (draw-message dc x y)))) + (set-bitmap new-bm)))] + [(motion) (cond [left-down? + (when (not (and (= left-drag-x mouse-x) + (= left-drag-y mouse-y))) + (set! left-drag-x mouse-x) + (set! left-drag-y mouse-y) + (set! draw? #t) + (set! rotated? #t))] + [else (and (not (send evt get-left-down)) + (<= 0 mouse-x (send (get-bitmap) get-width)) + (<= 0 mouse-y (send (get-bitmap) get-height))) + (set-click-message)])])) (define cross-cursor (make-object cursor% 'cross)) (define/override (adjust-cursor dc x y editorx editory evt) cross-cursor) (send this set-flags (list* 'handles-events 'handles-all-mouse-events (send this get-flags))))) -;; make-3d-plot-snip : (real real real -> bitmap) real real -> 3d-plot-snip% -(define (make-3d-plot-snip make-bm angle altitude saved-plot-parameters) - (make-object 3d-plot-snip% make-bm angle altitude saved-plot-parameters)) +(define (make-3d-plot-snip bm saved-plot-parameters make-bm angle altitude) + (make-object 3d-plot-snip% bm saved-plot-parameters make-bm angle altitude))