Performance improvements in future visualizer GUI (dragging, scrolling, sizing)

collects/future-visualizer/private/gui-helpers.rkt

@@ -2,9 +2,9 @@
 (require framework 
          slideshow/pict
          "display.rkt" 
-         "constants.rkt")
+         "constants.rkt" 
-(provide pict-canvas%
+         "pict-canvas.rkt") 
-         label 
+(provide label 
          mt-label 
          bold-label 
          mt-bold-label 
@@ -14,115 +14,6 @@
          add-receiver 
          post-event)
 
-(define pict-canvas%
-  (class canvas%       
-    (init redraw-on-resize pict-builder hover-handler click-handler overlay-builder)
-    (inherit get-dc get-client-size refresh get-view-start)
-    (define bp pict-builder) ;Builds the main pict for the canvas
-    (define mh hover-handler) ;Mouse hover handler
-    (define ob overlay-builder) ;Hover overlay pict builder
-    (define ch click-handler) ;Mouse click handler  
-    (define draw-on-resize redraw-on-resize)
-    (define do-logging #f)
-    (define redraw-overlay #f) ;Whether we should redraw the overlay pict in the canvas 
-    (define redo-bitmap-on-paint #t) ;Redraw the base bitmap on paint? #f for mouse events
-    (define scale-factor 1)
-    
-    (define/public (set-redo-bitmap-on-paint! v) 
-      (set! redo-bitmap-on-paint v))
-    
-    (define/public (set-do-logging! v) 
-      (set! do-logging v))
-    
-    ;;set-build-pict! : (viewable-region -> pict) -> void
-    (define/public (set-build-pict! f) 
-      (set! bp f)) 
-    
-    ;;set-mouse-handler! : (uint uint -> segment) -> void
-    (define/public (set-mouse-handler! f) 
-      (set! mh f)) 
-    
-    ;;set-overlay-builder! : (viewable-region -> pict) -> void
-    (define/public (set-overlay-builder! f) 
-      (set! ob f))
-    
-    ;;set-click-handler! : (uint uint -> segment) -> void
-    (define/public (set-click-handler! f) 
-      (set! ch f))
-    
-    ;;set-redraw-overlay! : bool -> void
-    (define/public (set-redraw-overlay! b) 
-      (set! redraw-overlay b))
-    
-    (define/public (set-scale-factor! s) 
-      (set! scale-factor s))
-    
-    (define the-drawer #f)
-    (define img-width 0)
-    (define bm #f)
-    (define overlay-pict #f) 
-    
-    (define/private (get-viewable-region) 
-      (define-values (x y) (get-view-start)) 
-      (define-values (w h) (get-client-size)) 
-      (scale-viewable-region (viewable-region x y w h) (/ 1 scale-factor)))
-    
-    (define/private (overlay-drawer dc vregion) 
-      (when ob 
-        (define p (ob vregion scale-factor))
-        (unless (or (not p) (void? p))
-          (draw-pict p
-                     dc 
-                     (viewable-region-x vregion)
-                     (viewable-region-y vregion)))))
-    
-    (define/private (redo-bitmap vregion)  
-      (when bp 
-        (define p (scale (bp vregion) scale-factor)) 
-        (set! bm (pict->bitmap p))))
-    
-    (define/public (redraw-everything) 
-      (redo-bitmap (get-viewable-region)) 
-      (refresh))
-    
-    (define/override (on-size width height)
-      (when (or draw-on-resize 
-                (not bm)) 
-        (set! bm #f)
-        (refresh)) 
-      (set! redraw-overlay #t))
-    
-    (define/override (on-paint) 
-      (define vregion (get-viewable-region))
-      (when (or redo-bitmap-on-paint (not bm))
-        (redo-bitmap vregion))
-      (unless redo-bitmap-on-paint
-        (set! redo-bitmap-on-paint #t))
-      (when bm
-        (let ([dc (get-dc)])
-          (send dc draw-bitmap 
-                bm 
-                (viewable-region-x vregion) 
-                (viewable-region-y vregion)) 
-          (overlay-drawer dc vregion))))
-    
-    (define/override (on-event event)
-      (define vregion (get-viewable-region))
-      (define x (+ (viewable-region-x vregion) (/ (send event get-x) scale-factor))) 
-      (define y (+ (viewable-region-y vregion) (/ (send event get-y) scale-factor)))
-      (case (send event get-event-type) 
-        [(motion)
-         (set! redo-bitmap-on-paint #f)
-         (when mh (mh x y vregion))] 
-        [(left-up)
-         (set! redo-bitmap-on-paint #f)
-         (when ch (ch x y vregion))]) 
-      (when redraw-overlay 
-          (refresh)))
-    
-    (super-new) 
-    (send (get-dc) set-smoothing 'aligned)))
-
 (define bold-system-font
   (send the-font-list find-or-create-font	 	
         (send normal-control-font get-point-size)	 
@@ -165,9 +56,6 @@
                                                                                            HEADER-HEIGHT) 
                                                                          (header-backcolor))
                                                                text-container))] 
-                               [hover-handler #f]
-                               [click-handler #f] 
-                               [overlay-builder #f]
                                [min-height HEADER-HEIGHT] 
                                [stretchable-width #t] 
                                [stretchable-height #f])]) 
@@ -182,9 +70,6 @@
                                                                                (header-backcolor))
                                                                      text-container)
                                                      -1.57079633))] 
-                               [hover-handler #f]
-                               [click-handler #f] 
-                               [overlay-builder #f]
                                [min-width HEADER-HEIGHT] 
                                [stretchable-width #f] 
                                [stretchable-height #t])]) 

collects/future-visualizer/private/pict-canvas.rkt

@@ -0,0 +1,131 @@
+#lang racket/gui
+(require framework 
+         slideshow/pict 
+         "display.rkt") 
+(provide pict-canvas%) 
+
+
+(define pict-canvas%
+  (class canvas%      
+    (init pict-builder [hover-handler #f] 
+                       [click-handler #f] 
+                       [overlay-builder #f] 
+                       [redraw-on-resize #f])
+    (inherit get-dc get-client-size refresh get-view-start)
+    (define bp pict-builder) ;Builds the main pict for the canvas
+    (define mh hover-handler) ;Mouse hover handler
+    (define ob overlay-builder) ;Hover overlay pict builder
+    (define ch click-handler) ;Mouse click handler  
+    (define redraw-on-size redraw-on-resize) ;Whether we should rebuild the pict for on-size events
+    
+    (define redraw-overlay #f) ;Whether we should redraw the overlay pict in the canvas 
+    (define redo-bitmap-on-paint #t) ;Redraw the base bitmap on paint? #f for mouse events
+    (define scale-factor 1)
+    
+    ;;set-redraw-overlay! : bool -> void
+    (define/public (set-redraw-overlay! b) 
+      (set! redraw-overlay b))
+    
+    (define/public (set-scale-factor! s) 
+      (set! scale-factor s))
+    
+    (define needs-redraw #f)
+    (define delaying-redraw #f)
+    (define cached-bitmap #f)
+    (define cached-base-pict #f)
+    
+    (define/private (get-viewable-region) 
+      (define-values (x y) (get-view-start)) 
+      (define-values (w h) (get-client-size)) 
+      (scale-viewable-region (viewable-region x y w h) (/ 1 scale-factor)))
+    
+    (define/public (redraw-everything) 
+      (redraw-the-bitmap/maybe-delayed! (get-viewable-region)))
+    
+    ;Rebuild both the bottom (base) and overlay (top) 
+    ;pict layers for the canvas
+    ;;rebuild-the-pict : viewable-region -> void
+    (define/private (rebuild-the-pict vregion #:only-the-overlay? [only-the-overlay? #f]) 
+      (define p (cond 
+                  [(or (not cached-base-pict) (not only-the-overlay?)) 
+                   (define base (scale (bp vregion) scale-factor)) 
+                   (set! cached-base-pict base) 
+                   (if ob 
+                       (pin-over base 
+                                 0 
+                                 0 
+                                 (ob vregion scale-factor)) 
+                       base)] 
+                  [else (if ob 
+                            (pin-over cached-base-pict 
+                                      0 
+                                      0 
+                                      (ob vregion scale-factor))
+                            cached-base-pict)]))                   
+      (pict->bitmap p))
+    
+    ;Rebuilds the pict and stashes in a bitmap 
+    ;to be drawn to the canvas later
+    ;;redraw-the-bitmap : viewable-region -> void
+    (define/private (redraw-the-bitmap! vregion #:only-the-overlay? [only-the-overlay? #f]) 
+      (set! cached-bitmap (rebuild-the-pict vregion #:only-the-overlay? only-the-overlay?)) 
+      (set! needs-redraw #f))
+    
+    ;;redraw-the-bitmap/maybe-delayed! : viewable-region -> void
+    (define/private (redraw-the-bitmap/maybe-delayed! vregion 
+                                                      #:only-the-overlay? [only-the-overlay? #f]) 
+      (cond 
+        [needs-redraw (redraw-the-bitmap! vregion #:only-the-overlay? only-the-overlay?)] 
+        [(not delaying-redraw) 
+         (new timer% [notify-callback (λ () 
+                                        (set! delaying-redraw #f) 
+                                        (set! needs-redraw #t)
+                                        (redraw-the-bitmap/maybe-delayed! (get-viewable-region)) 
+                                        (refresh))]
+              [interval 100] 
+              [just-once? #t]) 
+         (set! delaying-redraw #t)]))
+    
+    ;If we haven't already introduced a 100ms delay, 
+    ;add one.  If the delay's expired, rebuild the pict
+    ;;on-size : uint uint -> void
+    (define/override (on-size width height)
+      (when redraw-on-size
+        (redraw-the-bitmap/maybe-delayed! (get-viewable-region))))
+    
+    (define/override (on-paint)
+      (define vregion (get-viewable-region)) 
+      (redraw-the-bitmap/maybe-delayed! vregion)
+      (define dc (get-dc))
+      (when cached-bitmap
+        (send dc 
+              draw-bitmap 
+              cached-bitmap 
+              (viewable-region-x vregion) 
+              (viewable-region-y vregion))))
+    
+    (define/override (on-event event) 
+      (define vregion (get-viewable-region)) 
+      (define x (+ (viewable-region-x vregion) (/ (send event get-x) scale-factor))) 
+      (define y (+ (viewable-region-y vregion) (/ (send event get-y) scale-factor))) 
+      (case (send event get-event-type) 
+        [(motion) 
+         (when mh 
+           (when (mh x y vregion) ;Mouse handler returns non-false if a state change requiring redraw occurred
+             (redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t)))]
+        [(left-up) 
+         (when ch (ch x y vregion)) ;Ditto for click handler
+         (redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t)]))
+    
+    (super-new) 
+    (send (get-dc) set-smoothing 'aligned)))
+
+
+
+
+
+
+
+
+
+

collects/future-visualizer/private/visualizer-gui.rkt

@@ -7,7 +7,8 @@
          "gui-helpers.rkt" 
          "graph-drawing.rkt"
          "display.rkt" 
-         "constants.rkt")    
+         "constants.rkt" 
+         "pict-canvas.rkt")    
 
 (provide show-visualizer) 
 
@@ -102,13 +103,16 @@
                  [height winh])) 
   (define main-panel (new panel:horizontal-dragable% 
                           [parent (send f get-area-container)]))
+  
   (define left-panel (new panel:horizontal-dragable% [parent main-panel] 
-                          [stretchable-width #t]))
+                          [stretchable-width #t] 
+                          [min-width 0]))
   (define hlist-ctl (new hierarchical-list% 
                          [parent left-panel] 
                          [stretchable-width #t] 
                          [stretchable-height #t] 
-                         [style '(control-border)]))
+                         [style '(control-border)] 
+                         [min-width 0]))
   
   ;Build up items in the hierlist 
   (define block-node (send hlist-ctl new-list)) 
@@ -128,8 +132,7 @@
                           [stretchable-width #t]))
   (define graphic-panel (new panel:horizontal-dragable% 
                              [parent right-panel] 
-                             [stretchable-height #t] 
+                             [stretchable-height #t]))
-                             [min-width (inexact->exact (round (* winw .8)))]))
   (define timeline-container (new vertical-panel% 
                                   [parent graphic-panel] 
                                   [stretchable-width #t] 
@@ -146,7 +149,6 @@
   (define timeline-mouse-index (rebuild-mouse-index frameinfo the-trace segments))   
   (define timeline-panel (new pict-canvas% 
                               [parent timeline-container]
-                              [redraw-on-resize #f] 
                               [pict-builder (λ (vregion) (timeline-pict-for-trace-data vregion the-trace frameinfo segments))] 
                               [hover-handler (λ (x y vregion) 
                                                (let ([seg (find-seg-for-coords x y timeline-mouse-index)]) 
@@ -155,15 +157,14 @@
                               [click-handler (λ (x y vregion) 
                                                (let ([seg (find-seg-for-coords x y timeline-mouse-index)]) 
                                                  (set! tacked-seg seg)  
-                                                 (post-event listener-table 'segment-click timeline-panel seg)))] 
+                                                 (post-event listener-table 'segment-click timeline-panel seg) 
+                                                 seg))] 
                               [overlay-builder (λ (vregion scale-factor) 
                                                  (timeline-overlay vregion 
                                                                    tacked-seg 
                                                                    hover-seg 
                                                                    frameinfo 
                                                                    the-trace))]
-                              [min-width 500] 
-                              [min-height (inexact->exact (round (* winh .7)))] 
                               [style '(hscroll vscroll)] 
                               [stretchable-width #t]))
   ;; TODO sometimes the sizes passed to the scrollbars are so big we blow up!
@@ -183,11 +184,10 @@
   (define hovered-graph-node #f)
   (define creategraph-panel (new pict-canvas% 
                                  [parent graph-container]
-                                 [redraw-on-resize #f]
                                  [pict-builder (λ (vregion) 
                                                  (draw-creategraph-pict vregion 
                                                                          creation-tree-layout))]
-                                 [hover-handler #f #;(λ (x y vregion) 
+                                 #;[hover-handler #f (λ (x y vregion) 
                                                      (set! hovered-graph-node 
                                                            (find-node-for-coords x 
                                                                                  y 
@@ -202,14 +202,12 @@
                                                     (send timeline-panel set-redraw-overlay! #t)
                                                     (send timeline-panel refresh)
                                                     (post-event listener-table 'segment-click timeline-panel seg)))]
-                                 [overlay-builder (λ (vregion scale-factor) 
+                                 #;[overlay-builder (λ (vregion scale-factor) 
                                                     (graph-overlay-pict hovered-graph-node 
                                                                         the-trace 
                                                                         creation-tree-layout 
                                                                         vregion 
                                                                         scale-factor))]
-                                 [min-width 500]
-                                 [min-height 500]
                                  [style '(hscroll vscroll)] 
                                  [stretchable-width #t]))