From 59324a1b0c51798b6e2270b7dd1bbfa45faffd8d Mon Sep 17 00:00:00 2001 From: James Swaine Date: Thu, 19 Jul 2012 17:42:38 -0500 Subject: [PATCH] Fix future visualizer drawing outside visible area (in y dimension) (cherry picked from commit 5042b73fc89df2c66474a391efcc8443e5ae4524) --- .../future-visualizer/private/display.rkt | 7 +- .../future-visualizer/private/pict-canvas.rkt | 5 +- .../private/visualizer-drawing.rkt | 159 ++++++++++-------- .../private/visualizer-gui.rkt | 5 +- 4 files changed, 101 insertions(+), 75 deletions(-) diff --git a/collects/future-visualizer/private/display.rkt b/collects/future-visualizer/private/display.rkt index 21f75e6fea..4a33d9430b 100644 --- a/collects/future-visualizer/private/display.rkt +++ b/collects/future-visualizer/private/display.rkt @@ -26,7 +26,8 @@ viewable-region-x-extent viewable-region-y-extent in-viewable-region - in-viewable-region-horiz + in-viewable-region-horiz + in-viewable-region-vert? scale-viewable-region between) @@ -55,6 +56,10 @@ (define (in-viewable-region-horiz vregion x) (between x (viewable-region-x vregion) (viewable-region-x-extent vregion))) +;;in-viewable-region-vert : viewable-region uint -> bool +(define (in-viewable-region-vert? vregion y) + (between y (viewable-region-y vregion) (viewable-region-y-extent vregion))) + ;;in-viewable-region : viewable-region segment -> bool (define (in-viewable-region vregion x y w h) (define-values (start-x start-y end-x end-y) diff --git a/collects/future-visualizer/private/pict-canvas.rkt b/collects/future-visualizer/private/pict-canvas.rkt index f2115e5efd..31b9fabac5 100644 --- a/collects/future-visualizer/private/pict-canvas.rkt +++ b/collects/future-visualizer/private/pict-canvas.rkt @@ -116,7 +116,10 @@ [(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)))] + #;(redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t) + (set! repainting? #f) + (redraw-the-bitmap! vregion #:only-the-overlay? #t) + (refresh)))] [(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 7cec144d98..ee631cb87e 100644 --- a/collects/future-visualizer/private/visualizer-drawing.rkt +++ b/collects/future-visualizer/private/visualizer-drawing.rkt @@ -199,8 +199,7 @@ [last-label-x-extent 0] [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) trace-start) - DEFAULT-TIME-INTERVAL)))]) - #;(define tick-time (+ last-time DEFAULT-TIME-INTERVAL)) + DEFAULT-TIME-INTERVAL)))]) (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL)) (define tick-time (+ trace-start tick-rel-time)) (define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod))) @@ -270,19 +269,11 @@ ;; get-seg-previous-to-vregion : viewable-region segment -> segment (define (get-seg-previous-to-vregion vregion seg) - (define first-seg - (let loop ([cur seg]) - (define prev (segment-prev-future-seg cur)) - (if (not prev) - cur - (loop prev)))) - (let loop ([cur first-seg]) - (define next (segment-next-future-seg cur)) - (if (or (not next) - (> (segment-x next) (viewable-region-x vregion))) - cur - (loop next)))) - + (let loop ([cur seg]) + (define prev (segment-prev-future-seg cur)) + (cond + [(or (not prev) (not ((seg-in-vregion vregion) cur))) cur] + [else (loop prev)]))) ;;adjust-work-segs! : (listof segment) -> void (define (adjust-work-segs! segs) @@ -399,7 +390,7 @@ 0 (linestyle 'dot (colorize (vline 1 - (frame-info-adjusted-height frameinfo)) + (viewable-region-height vregion)) (timeline-tick-color))))) (if (timeline-tick-show-label? tick) (pin-over pinnedline @@ -413,8 +404,14 @@ (pin-over base 0 0 - (for/fold ([pct base]) ([tl (in-list (trace-proc-timelines tr))] - [i (in-naturals)]) + (for/fold ([pct base]) ([tl (in-list (filter (λ (tline) + (define midy (calc-row-mid-y (process-timeline-proc-index tline) + (frame-info-row-height finfo))) + (define topy (- midy (frame-info-row-height finfo))) + (define boty (+ midy (frame-info-row-height finfo))) + (or (in-viewable-region-vert? vregion topy) + (in-viewable-region-vert? vregion boty))) + (trace-proc-timelines tr)))]) (let* ([line-coords (list-ref (frame-info-process-line-coords finfo) (process-timeline-proc-index tl))] [line-start (car line-coords)] @@ -431,7 +428,8 @@ [(between line-end vregion-start vregion-end) (- line-end vregion-start)] [else vregion-end])] - [proc-name (if (zero? i) + [index (process-timeline-proc-index tl)] + [proc-name (if (zero? index) "Thread 0 (Runtime Thread)" (format "Thread ~a" (process-timeline-proc-id tl)))] [proc-title (text-block-pict proc-name @@ -442,15 +440,15 @@ #:width (viewable-region-width vregion))]) (draw-stack-onto pct (at 0 - (- (* (add1 i) (frame-info-row-height finfo)) (viewable-region-y vregion)) + (- (* (add1 index) (frame-info-row-height finfo)) (viewable-region-y vregion)) (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color))) (at 0 - (+ (+ (- (* i (frame-info-row-height finfo)) (viewable-region-y vregion)) + (+ (+ (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion)) (- (frame-info-row-height finfo) (pict-height proc-title))) 1) proc-title) (at start-x - (- (calc-row-mid-y (process-timeline-proc-index tl) (frame-info-row-height finfo)) + (- (calc-row-mid-y index (frame-info-row-height finfo)) (viewable-region-y vregion)) (colorize (hline (- end-x start-x) 1) (timeline-event-baseline-color)))))))) @@ -478,55 +476,6 @@ (let ([with-ruler (draw-ruler-on base vregion finfo)]) (draw-row-lines-on with-ruler vregion tr finfo opacity))) -;;draw-connection : viewable-region segment segment pict string [uint bool symbol] -> pict -(define (draw-connection vregion - start - end - base-pct - color - #:width [width 1] - #:with-arrow [with-arrow #f] - #:style [style 'solid]) - (let*-values ([(midx midy) (calc-center (- (segment-x start) (viewable-region-x vregion)) - (- (segment-y start) (viewable-region-y vregion)) - MIN-SEG-WIDTH)] - [(nextx nexty) (calc-center (- (segment-x end) (viewable-region-x vregion)) - (- (segment-y end) (viewable-region-y vregion)) - MIN-SEG-WIDTH)] - [(dx dy) (values (- nextx midx) (- nexty midy))]) - (if (and (zero? dy) - (or (not (eq? (segment-next-proc-seg start) end)) - (< dx CONNECTION-LINE-HAT-THRESHOLD))) - (let* ([dxa (/ dx 2)] - [dya (- HAT-HEIGHT CONNECTION-LINE-HAT-THRESHOLD)] - [breakx (+ midx dxa)] - [breaky (+ midy dya)]) - (draw-line-onto (draw-line-onto base-pct - midx - midy - breakx - breaky - color - #:width width - #:style style) - breakx - breaky - nextx - nexty - color - #:width width - #:with-arrow with-arrow - #:style style)) - (draw-line-onto base-pct - midx - midy - nextx - nexty - color - #:width width - #:with-arrow with-arrow - #:style style)))) - ;;timeline-pict : (listof indexed-future-event) [viewable-region] [integer] -> pict (define (timeline-pict logs #:x [x #f] @@ -576,8 +525,74 @@ overlay)] [else tp])) -;;draw-arrows : pict viewable-region segment -> pict +;;draw-connection : viewable-region segment segment pict string [uint bool symbol] -> pict +(define (draw-connection vregion + start + end + base-pct + color + #:width [width 1] + #:with-arrow [with-arrow #f] + #:style [style 'solid]) + (let*-values ([(midx midy) (calc-center (- (segment-x start) (viewable-region-x vregion)) + (- (segment-y start) (viewable-region-y vregion)) + MIN-SEG-WIDTH)] + [(nextx nexty) (calc-center (- (segment-x end) (viewable-region-x vregion)) + (- (segment-y end) (viewable-region-y vregion)) + MIN-SEG-WIDTH)] + [(dx dy) (values (- nextx midx) (- nexty midy))]) + (if (and (zero? dy) + (or (not (eq? (segment-next-proc-seg start) end)) + (< dx CONNECTION-LINE-HAT-THRESHOLD))) + (let* ([dxa (/ dx 2)] + [dya (- HAT-HEIGHT CONNECTION-LINE-HAT-THRESHOLD)] + [breakx (+ midx dxa)] + [breaky (+ midy dya)]) + (draw-line-onto (draw-line-onto base-pct + midx + midy + breakx + breaky + color + #:width width + #:style style) + breakx + breaky + nextx + nexty + color + #:width width + #:with-arrow with-arrow + #:style style)) + (draw-line-onto base-pct + midx + midy + nextx + nexty + color + #:width width + #:with-arrow with-arrow + #:style style)))) + (define (draw-arrows base-pct vregion seg) + (define fst (get-seg-previous-to-vregion vregion seg)) + (let loop ([p base-pct] + [cur-seg fst]) + (define next-seg (segment-next-future-seg cur-seg)) + (cond + [(not next-seg) p] + [else + (define new-p (draw-connection vregion + cur-seg + next-seg + p + (event-connection-line-color) + #:width 2)) + (loop new-p next-seg)]))) + + +;;draw-arrows : pict viewable-region segment -> pict +#;(define (draw-arrows base-pct vregion seg) (let ([fst (get-seg-previous-to-vregion vregion seg)]) (let loop ([pct base-pct] [cur-seg fst]) diff --git a/collects/future-visualizer/private/visualizer-gui.rkt b/collects/future-visualizer/private/visualizer-gui.rkt index 7c02681dde..c30b2de81d 100644 --- a/collects/future-visualizer/private/visualizer-gui.rkt +++ b/collects/future-visualizer/private/visualizer-gui.rkt @@ -133,7 +133,8 @@ [stretchable-width #t])) (define graphic-panel (new panel:horizontal-dragable% [parent right-panel] - [stretchable-height #t])) + [stretchable-height #t] + [stretchable-width #t])) (define timeline-container (new vertical-panel% [parent graphic-panel] [stretchable-width #t] @@ -353,5 +354,7 @@ (send graphic-panel add-child graph-container) (send item set-label "Hide Creation Tree"))) (set! showing-create-graph (not showing-create-graph)))]) + + (send main-panel set-percentages '(1/5 4/5)) (send f show #t))