Made plot snips resizeable

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)
     ))

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))

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?))]

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))

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?))]

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))