From 3ed1a7871385afd286c96507b3d4287e6fdf4af3 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Sat, 25 Feb 2012 15:40:47 -0700 Subject: [PATCH] Made plot snips resizeable --- collects/plot/common/snip.rkt | 73 +++++++++- collects/plot/common/worker-thread.rkt | 7 +- collects/plot/plot2d/plot.rkt | 10 +- collects/plot/plot2d/snip.rkt | 83 ++++++++---- collects/plot/plot3d/plot.rkt | 6 +- collects/plot/plot3d/snip.rkt | 180 +++++++++++++------------ 6 files changed, 235 insertions(+), 124 deletions(-) diff --git a/collects/plot/common/snip.rkt b/collects/plot/common/snip.rkt index 49131a377a..7ddef5f322 100644 --- a/collects/plot/common/snip.rkt +++ b/collects/plot/common/snip.rkt @@ -3,10 +3,18 @@ (require racket/gui/base racket/class racket/list unstable/parameter-group "math.rkt" "parameters.rkt" - "plot-device.rkt") + "plot-device.rkt" + "worker-thread.rkt") (provide plot-snip%) +;; delay between update timer ticks +(define update-delay 16) ; about 60 fps (just over) + +;; update timer cancels itself if no useful work has been done in this amount of time +(define useful-work-timeout 1000) + +;; message disappears after this long (define message-timeout 2000) (define plot-snip% @@ -30,7 +38,10 @@ (define/public (refresh) ;(printf "~a: refresh~n" (current-milliseconds)) - (set-bitmap (get-bitmap))) + (define s-admin (get-admin)) + (when s-admin + (define bm (get-bitmap)) + (send s-admin needs-update this 0 0 (send bm get-width) (send bm get-height)))) (define message #f) (define message-timer (make-object timer% (λ () (stop-message)))) @@ -134,6 +145,64 @@ [(right-up middle-up) (send editor on-local-event evt)] )) + (define rth #f) + (define update-timer #f) + (define update? #t) + ;; timestamp of the last known time a timer tick did useful work + (define last-useful-work-time #f) + + (define/public (stop-update-thread) + (when rth + (worker-thread-kill rth) + (set! rth #f)) + (when update-timer + (send update-timer stop) + (set! update-timer #f)) + (set! last-useful-work-time #f)) + + (define/public (update-thread-running?) + (and rth #t)) + + (define/public (start-update-thread make-render-thread make-draw-command poll-worker-thread + animating?) + (stop-update-thread) + (set! rth (make-render-thread)) + (set! update-timer + (make-object timer% + (update-tick make-render-thread make-draw-command poll-worker-thread animating?) + update-delay))) + + (define/public (set-update up) + (set! update? up)) + + (define ((update-tick make-render-thread make-draw-command poll-worker-thread animating?)) + (cond [animating? + (define can-update? + (cond [(worker-thread-working? rth) + ;; rendering is useful work (otherwise, animating would stutter if rendering a + ;; plot takes too long) + (set! last-useful-work-time (current-milliseconds)) + (poll-worker-thread rth)] + [else #t])) + ;; can-update? is #t if the worker thread is ready for another command + (when (and update? can-update?) + (set! update? #f) + (set! last-useful-work-time (current-milliseconds)) + (worker-thread-put rth (make-draw-command animating?))) + ;; if it's been too long since useful work was done, switch to drawing the final plot + (when (and last-useful-work-time + ((- (current-milliseconds) last-useful-work-time) . > . useful-work-timeout)) + (stop-update-thread) + (start-update-thread make-render-thread make-draw-command poll-worker-thread #f)) + ;; keep any messages up + (reset-message-timeout)] + [else + (cond [(worker-thread-working? rth) + (when (poll-worker-thread rth) + (stop-update-thread))] + [else + (worker-thread-put rth (make-draw-command animating?))])])) + (define cross-cursor (make-object cursor% 'cross)) (define/override (adjust-cursor dc x y editorx editory evt) cross-cursor) )) diff --git a/collects/plot/common/worker-thread.rkt b/collects/plot/common/worker-thread.rkt index 4e7c5aa527..5edb0744f7 100644 --- a/collects/plot/common/worker-thread.rkt +++ b/collects/plot/common/worker-thread.rkt @@ -6,7 +6,8 @@ worker-thread-put worker-thread-try-put worker-thread-get worker-thread-try-get worker-thread-wait - worker-thread-send) + worker-thread-send + worker-thread-kill) (struct worker-thread (state message-channel result-channel thread) #:mutable #:transparent) (struct values-result (value-list) #:transparent) @@ -75,3 +76,7 @@ (worker-thread-wait r) (worker-thread-put r msg) (worker-thread-get r)) + +(define (worker-thread-kill r) + (match-define (worker-thread state msg-ch res-ch th) r) + (kill-thread th)) diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index f018aaa64a..e4c950e055 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -162,10 +162,11 @@ (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 (make-bm anim? bounds-rect width height) (define area #f) (define bm - (parameterize/group ([plot-parameters saved-plot-parameters]) + (parameterize/group ([plot-parameters saved-plot-parameters] + [plot-animating? (if anim? #t (plot-animating?))]) ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) (λ (dc) (define-values (x-ticks x-far-ticks y-ticks y-far-ticks) @@ -200,11 +201,12 @@ (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)) + (define-values (bm area-bounds-rect area-bounds->plot-bounds) + (make-bm #f bounds-rect width height)) (make-2d-plot-snip bm saved-plot-parameters - make-plot bounds-rect area-bounds-rect area-bounds->plot-bounds))) + make-bm bounds-rect area-bounds-rect area-bounds->plot-bounds width height))) ;; 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 index 6a04d5a362..20bac385f1 100644 --- a/collects/plot/plot2d/snip.rkt +++ b/collects/plot/plot2d/snip.rkt @@ -6,24 +6,29 @@ "../common/math.rkt" "../common/format.rkt" "../common/ticks.rkt" + "../common/worker-thread.rkt" "../common/parameters.rkt") (provide 2d-plot-snip% make-2d-plot-snip) -(define zoom-delay 16) ; about 60 fps (just over) +(define update-delay 16) (define show-zoom-message? #t) +(struct draw-command (animating? plot-bounds-rect width height) #:transparent) + (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) + (init init-bm saved-plot-parameters) + (init-field make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height) (inherit set-bitmap get-bitmap get-saved-plot-parameters - refresh set-message reset-message-timeout + refresh + stop-message set-message reset-message-timeout + update-thread-running? set-update get-left-down-here?) - (super-make-object bm saved-plot-parameters) + (super-make-object init-bm saved-plot-parameters) (define (set-message-center) (match-define (vector x-mid y-mid) (rect-center area-bounds-rect)) @@ -34,7 +39,7 @@ (define/override (copy) (make-object this% (get-bitmap) (get-saved-plot-parameters) - make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds)) + make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height)) (define left-click-x 0) (define left-click-y 0) @@ -57,24 +62,12 @@ (λ () (set! zoom-timer #f) (refresh)) - zoom-delay #t)))) + update-delay #t)))) (define (set-click-message) (when show-zoom-message? (set-message "Click and drag to zoom\n Click to unzoom once"))) - (define (update-plot new-plot-bounds-rect) - (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) @@ -83,13 +76,38 @@ #;(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)])] + (set! plot-bounds-rect new-rect) + (update-plot)] + [else + (refresh)])] [(not (empty? plot-bounds-rects)) - (define new-rect (first plot-bounds-rects)) + (set! plot-bounds-rect (first plot-bounds-rects)) (set! plot-bounds-rects (rest plot-bounds-rects)) (set! show-zoom-message? #f) - (update-plot new-rect)])) + (update-plot)])) + + (define (start-update-thread animating?) + (send this start-update-thread + (λ () (make-worker-thread + (match-lambda + [(draw-command animating? plot-bounds-rect width height) + (make-bm animating? plot-bounds-rect width height)]))) + (λ (animating?) (draw-command animating? plot-bounds-rect width height)) + (λ (rth) + (define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds) + (worker-thread-try-get rth (λ () (values #f #f #f)))) + (cond [(is-a? new-bm bitmap%) + (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) + #t] + [else #f])) + animating?)) + + (define (update-plot) + (start-update-thread #f) + (set-update #t)) (define/override (on-event dc x y editorx editory evt) (define evt-type (send evt get-event-type)) @@ -178,10 +196,21 @@ (when dragging? (parameterize/group ([plot-parameters (get-saved-plot-parameters)]) (draw-selection dc x y (get-new-area-bounds-rect))))) + + (define/override (resize w h) + (when (not (and (= w width) (= h height))) + (set! width w) + (set! height h) + (stop-message) + (when (not (update-thread-running?)) + (start-update-thread #t)) + (set-update #t)) + #f) )) -(define (make-2d-plot-snip bm saved-plot-parameters - make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds) +(define (make-2d-plot-snip + init-bm saved-plot-parameters + make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height) (make-object 2d-plot-snip% - bm saved-plot-parameters - make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds)) + init-bm saved-plot-parameters + make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height)) diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index 9453c925a3..39adeaa0a3 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -193,7 +193,7 @@ (define render-list-hash (make-hash)) (define legend-entries-hash (make-hash)) - (define (make-bm anim? angle altitude) + (define (make-bm anim? angle altitude width height) (parameterize/group ([plot-parameters saved-plot-parameters] [plot-animating? (if anim? #t (plot-animating?))] [plot3d-angle angle] @@ -229,8 +229,8 @@ width height))) (make-3d-plot-snip - (make-bm #f angle altitude) saved-plot-parameters - make-bm angle altitude))) + (make-bm #f angle altitude width height) saved-plot-parameters + make-bm angle altitude width height))) ;; 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 d3c8ee4653..102c08bcb1 100644 --- a/collects/plot/plot3d/snip.rkt +++ b/collects/plot/plot3d/snip.rkt @@ -8,80 +8,67 @@ (provide 3d-plot-snip% make-3d-plot-snip) -(define update-delay 16) ; about 60 fps (just over) (define show-rotate-message? #t) -(struct draw-command (animating? angle altitude) #:transparent) - -(define (make-render-thread make-bm saved-plot-parameters) - (make-worker-thread - (match-lambda - [(draw-command animating? angle altitude) - (make-bm animating? angle altitude)]))) +(struct draw-command (animating? angle altitude width height) #:transparent) (define (clamp x mn mx) (min* (max* x mn) mx)) (define 3d-plot-snip% (class plot-snip% - (init bm saved-plot-parameters) - (init-field make-bm angle altitude) + (init init-bm saved-plot-parameters) + (init-field make-bm angle altitude width height) (inherit set-bitmap get-bitmap - get-saved-plot-parameters set-message reset-message-timeout + get-saved-plot-parameters + set-message stop-message set-message-center reset-message-timeout + update-thread-running? set-update get-left-down-here?) - (super-make-object bm saved-plot-parameters) + (super-make-object init-bm saved-plot-parameters) (define/override (copy) (make-object this% (get-bitmap) (get-saved-plot-parameters) - make-bm angle altitude)) + make-bm angle altitude width height)) + (define mouse-x 0) + (define mouse-y 0) (define left-click-x 0) (define left-click-y 0) - (define left-drag-x 0) - (define left-drag-y 0) - (define (new-angle) + (define last-angle angle) + (define last-altitude altitude) + + (define (set-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 dx (- mouse-x left-click-x)) + (set! angle (real-modulo (+ last-angle (* dx degrees-per-pixel)) 360))) - (define (new-altitude) + (define (set-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 dy (- mouse-y left-click-y)) + (set! altitude (clamp (+ last-altitude (* dy degrees-per-pixel)) 0 90))) - (define rth (make-render-thread make-bm saved-plot-parameters)) - (define draw? #t) - (define update-timer #f) + (define (start-update-thread animating?) + (send this start-update-thread + (λ () (make-worker-thread + (match-lambda + [(draw-command animating? angle altitude width height) + (make-bm animating? angle altitude width height)]))) + (λ (animating?) (draw-command animating? angle altitude width height)) + (λ (rth) + (define new-bm (worker-thread-try-get rth)) + (cond [(is-a? new-bm bitmap%) + (set-bitmap new-bm) + (when (not (and (= last-angle angle) + (= last-altitude altitude))) + (set-angles-message)) + #t] + [else #f])) + animating?)) - (define (stop-update-timer) - (when update-timer - (send update-timer stop) - (set! update-timer #f))) - - (define (start-update-timer) - (stop-update-timer) - (set! update-timer (make-object timer% update update-delay))) - - (define (update) - ;(printf "update ~a~n" (current-milliseconds)) - (define can-draw? - (cond [(worker-thread-working? rth) - (define new-bm (worker-thread-try-get rth)) - (cond [(is-a? new-bm bitmap%) (set! bm new-bm) - (set-angles-message (new-angle) (new-altitude)) - (set-bitmap bm) - #t] - [else #f])] - [else #t])) - (when (and draw? can-draw?) - (set! draw? #f) - (worker-thread-put rth (draw-command #t (new-angle) (new-altitude)))) - (reset-message-timeout)) - - (define (set-angles-message angle altitude) + (define (set-angles-message) (set-message (format "angle = ~a\naltitude = ~a" (number->string (inexact->exact (round angle))) (number->string (inexact->exact (round altitude)))) @@ -91,46 +78,65 @@ (when show-rotate-message? (set-message "Click and drag to rotate"))) + (define (on-left-down) + (set! left-click-x mouse-x) + (set! left-click-y mouse-y) + (set! last-angle angle) + (set! last-altitude altitude) + (set-angles-message) + (start-update-thread #t) + (set-update #t)) + + (define (on-left-up) + (when (get-left-down-here?) + (set! last-angle angle) + (set! last-altitude altitude) + (when (update-thread-running?) + (start-update-thread #f) + (set-update #t)))) + + (define (on-motion evt last-mouse-x last-mouse-y) + (cond [(get-left-down-here?) + (when (not (and (= last-mouse-x mouse-x) + (= last-mouse-y mouse-y))) + (set! show-rotate-message? #f) + (set-angle!) + (set-altitude!) + (unless (update-thread-running?) + (start-update-thread #t)) + (set-update #t))] + [(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 (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)) + (define last-mouse-x mouse-x) + (define last-mouse-y mouse-y) + (set! mouse-x (- (send evt get-x) x)) + (set! 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! draw? #t) - (start-update-timer)] - [(left-up) (when (get-left-down-here?) - (stop-update-timer) - (set! draw? #f) - (worker-thread-wait rth) - (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) - (define new-bm (worker-thread-send rth (draw-command #f angle altitude))) - (when (is-a? new-bm bitmap%) - (set-bitmap new-bm)))] - [(motion) (cond [(get-left-down-here?) - (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! show-rotate-message? #f))] - [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)])]) + [(left-down) (on-left-down)] + [(left-up) (on-left-up)] + [(motion) (on-motion evt last-mouse-x last-mouse-y)]) (super on-event dc x y editorx editory evt)) + + (define/override (resize w h) + (when (not (and (= w width) (= h height))) + (set! width w) + (set! height h) + (set-message-center (* 1/2 w) (* 1/2 h)) + (stop-message) + (when (not (update-thread-running?)) + (start-update-thread #t)) + (set-update #t)) + #f) )) -(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)) +(define (make-3d-plot-snip + init-bm saved-plot-parameters + make-bm angle altitude width height) + (make-object 3d-plot-snip% + init-bm saved-plot-parameters + make-bm angle altitude width height))