diff --git a/collects/future-visualizer/private/pict-canvas.rkt b/collects/future-visualizer/private/pict-canvas.rkt index 31b9fabac5..7d27710413 100644 --- a/collects/future-visualizer/private/pict-canvas.rkt +++ b/collects/future-visualizer/private/pict-canvas.rkt @@ -29,9 +29,10 @@ (define/public (set-scale-factor! s) (set! scale-factor s)) - (define needs-redraw #f) + (define need-redraw? #f) (define delaying-redraw #f) (define cached-bitmap #f) + (define cached-overlay-bitmap #f) (define cached-base-pict #f) (define repainting? #f) @@ -46,45 +47,36 @@ ;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)) + (define/private (rebuild-the-pict! vregion #:only-the-overlay? [only-the-overlay? #f]) + (when (or (not cached-base-pict) (not only-the-overlay?)) + (define base (scale (bp vregion) scale-factor)) + ;(set! cached-base-pict base) + (set! cached-bitmap (pict->bitmap base))) + (when ob + (set! cached-overlay-bitmap (pict->bitmap (ob vregion scale-factor))))) ;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)) + (rebuild-the-pict! vregion #:only-the-overlay? only-the-overlay?) + (set! need-redraw? #f)) ;;redraw-the-bitmap/maybe-delayed! : viewable-region -> void (define/private (redraw-the-bitmap/maybe-delayed! vregion + #:delay [delay 100] #:only-the-overlay? [only-the-overlay? #f]) (cond - [needs-redraw (redraw-the-bitmap! vregion #:only-the-overlay? only-the-overlay?)] + [need-redraw? + (redraw-the-bitmap! vregion #:only-the-overlay? only-the-overlay?) + (set! need-redraw? #f)] [(not delaying-redraw) (new timer% [notify-callback (λ () (set! delaying-redraw #f) - (set! needs-redraw #t) + (set! need-redraw? #t) (redraw-the-bitmap/maybe-delayed! (get-viewable-region) #:only-the-overlay? only-the-overlay?) - (set! repainting? #t) (refresh))] - [interval 100] + [interval delay] [just-once? #t]) (set! delaying-redraw #t)])) @@ -95,17 +87,25 @@ (when redraw-on-size (redraw-the-bitmap/maybe-delayed! (get-viewable-region)))) + (define last-vregion #f) + (define/override (on-paint) (define vregion (get-viewable-region)) - (unless repainting? + (when (and (not delaying-redraw) (not (equal? vregion last-vregion))) (redraw-the-bitmap/maybe-delayed! vregion)) - (set! repainting? #f) + (set! last-vregion vregion) (define dc (get-dc)) (when cached-bitmap (send dc draw-bitmap cached-bitmap (viewable-region-x vregion) + (viewable-region-y vregion))) + (when cached-overlay-bitmap + (send dc + draw-bitmap + cached-overlay-bitmap + (viewable-region-x vregion) (viewable-region-y vregion)))) (define/override (on-event event) @@ -116,10 +116,7 @@ [(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) - (set! repainting? #f) - (redraw-the-bitmap! vregion #:only-the-overlay? #t) - (refresh)))] + (redraw-the-bitmap/maybe-delayed! vregion #:delay 0 #: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)])) diff --git a/collects/future-visualizer/private/visualizer-drawing.rkt b/collects/future-visualizer/private/visualizer-drawing.rkt index ee631cb87e..824cd2cb6a 100644 --- a/collects/future-visualizer/private/visualizer-drawing.rkt +++ b/collects/future-visualizer/private/visualizer-drawing.rkt @@ -437,8 +437,20 @@ #:forecolor (header-forecolor) #:padding HEADER-PADDING #:opacity opacity - #:width (viewable-region-width vregion))]) + #:width (viewable-region-width vregion))] + [row-mid (- (- (* index (frame-info-row-height finfo)) + (pict-height proc-title)) + (viewable-region-y vregion))]) (draw-stack-onto pct + (at 0 + (- (* (add1 index) (frame-info-row-height finfo)) (frame-info-row-height finfo)) + (colorize (filled-rectangle (viewable-region-width vregion) (/ (frame-info-row-height finfo) 2)) + (make-object color% 212 210 214 0.3))) + + (at 0 + row-mid + (colorize (filled-rectangle (viewable-region-width vregion) (/ (frame-info-row-height finfo) 2)) + (make-object color% 230 229 231 0.3))) (at 0 (- (* (add1 index) (frame-info-row-height finfo)) (viewable-region-y vregion)) (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color))) @@ -574,8 +586,15 @@ #:with-arrow with-arrow #:style style)))) +(define (get-seg-left-of-vregion vregion seg) + (define prev-in-time (segment-prev-future-seg seg)) + (cond + [(or (not prev-in-time) (not (in-viewable-region-horiz vregion (segment-edge seg)))) + seg] + [else (get-seg-left-of-vregion vregion prev-in-time)])) + (define (draw-arrows base-pct vregion seg) - (define fst (get-seg-previous-to-vregion vregion seg)) + (define fst (get-seg-left-of-vregion vregion seg)) (let loop ([p base-pct] [cur-seg fst]) (define next-seg (segment-next-future-seg cur-seg)) @@ -588,7 +607,9 @@ p (event-connection-line-color) #:width 2)) - (loop new-p next-seg)]))) + (if (not (in-viewable-region-horiz vregion (segment-x next-seg))) + new-p + (loop new-p next-seg))]))) ;;draw-arrows : pict viewable-region segment -> pict diff --git a/collects/future-visualizer/private/visualizer-gui.rkt b/collects/future-visualizer/private/visualizer-gui.rkt index c30b2de81d..a5642883b4 100644 --- a/collects/future-visualizer/private/visualizer-gui.rkt +++ b/collects/future-visualizer/private/visualizer-gui.rkt @@ -159,7 +159,7 @@ [else (set! hover-seg seg) (post-event listener-table 'segment-hover timeline-panel seg) - #t])))] + seg])))] [click-handler (λ (x y vregion) (let ([seg (find-seg-for-coords x y timeline-mouse-index)]) (set! tacked-seg seg) @@ -356,5 +356,6 @@ (set! showing-create-graph (not showing-create-graph)))]) (send main-panel set-percentages '(1/5 4/5)) + (send right-panel set-percentages '(3/4 1/4)) (send f show #t))