suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix future visualizer drawing outside visible area (in y dimension)

Browse Source 
(cherry picked from commit 5042b73fc8)
This commit is contained in:
James Swaine 2012-07-19 17:42:38 -05:00 committed by Ryan Culpepper
parent ce41446bd4
commit 59324a1b0c
4 changed files with 101 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/future-visualizer/private/display.rkt
View File

@ -26,7 +26,8 @@
viewable-region-x-extent viewable-region-x-extent
viewable-region-y-extent viewable-region-y-extent
in-viewable-region in-viewable-region
in-viewable-region-horiz in-viewable-region-horiz
in-viewable-region-vert?
scale-viewable-region scale-viewable-region
between) between)
@ -55,6 +56,10 @@
(define (in-viewable-region-horiz vregion x) (define (in-viewable-region-horiz vregion x)
(between x (viewable-region-x vregion) (viewable-region-x-extent vregion))) (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 ;;in-viewable-region : viewable-region segment -> bool
(define (in-viewable-region vregion x y w h) (define (in-viewable-region vregion x y w h)
(define-values (start-x start-y end-x end-y) (define-values (start-x start-y end-x end-y)

5
collects/future-visualizer/private/pict-canvas.rkt
View File

@ -116,7 +116,10 @@
[(motion) [(motion)
(when mh (when mh
(when (mh x y vregion) ;Mouse handler returns non-false if a state change requiring redraw occurred (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) [(left-up)
(when ch (ch x y vregion)) ;Ditto for click handler (when ch (ch x y vregion)) ;Ditto for click handler
(redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t)])) (redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t)]))

159
collects/future-visualizer/private/visualizer-drawing.rkt
View File

@ -199,8 +199,7 @@
[last-label-x-extent 0] [last-label-x-extent 0]
[remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr)
trace-start) trace-start)
DEFAULT-TIME-INTERVAL)))]) DEFAULT-TIME-INTERVAL)))])
#;(define tick-time (+ last-time DEFAULT-TIME-INTERVAL))
(define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL)) (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL))
(define tick-time (+ trace-start tick-rel-time)) (define tick-time (+ trace-start tick-rel-time))
(define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod))) (define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod)))
@ -270,19 +269,11 @@
;; get-seg-previous-to-vregion : viewable-region segment -> segment ;; get-seg-previous-to-vregion : viewable-region segment -> segment
(define (get-seg-previous-to-vregion vregion seg) (define (get-seg-previous-to-vregion vregion seg)
(define first-seg (let loop ([cur seg])
(let loop ([cur seg]) (define prev (segment-prev-future-seg cur))
(define prev (segment-prev-future-seg cur)) (cond
(if (not prev) [(or (not prev) (not ((seg-in-vregion vregion) cur))) cur]
cur [else (loop prev)])))
(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))))
;;adjust-work-segs! : (listof segment) -> void ;;adjust-work-segs! : (listof segment) -> void
(define (adjust-work-segs! segs) (define (adjust-work-segs! segs)
@ -399,7 +390,7 @@
0 0
(linestyle 'dot (linestyle 'dot
(colorize (vline 1 (colorize (vline 1
(frame-info-adjusted-height frameinfo)) (viewable-region-height vregion))
(timeline-tick-color))))) (timeline-tick-color)))))
(if (timeline-tick-show-label? tick) (if (timeline-tick-show-label? tick)
(pin-over pinnedline (pin-over pinnedline
@ -413,8 +404,14 @@
(pin-over base (pin-over base
0 0
0 0
(for/fold ([pct base]) ([tl (in-list (trace-proc-timelines tr))] (for/fold ([pct base]) ([tl (in-list (filter (λ (tline)
[i (in-naturals)]) (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) (let* ([line-coords (list-ref (frame-info-process-line-coords finfo)
(process-timeline-proc-index tl))] (process-timeline-proc-index tl))]
[line-start (car line-coords)] [line-start (car line-coords)]
@ -431,7 +428,8 @@
[(between line-end vregion-start vregion-end) [(between line-end vregion-start vregion-end)
(- line-end vregion-start)] (- line-end vregion-start)]
[else vregion-end])] [else vregion-end])]
[proc-name (if (zero? i) [index (process-timeline-proc-index tl)]
[proc-name (if (zero? index)
"Thread 0 (Runtime Thread)" "Thread 0 (Runtime Thread)"
(format "Thread ~a" (process-timeline-proc-id tl)))] (format "Thread ~a" (process-timeline-proc-id tl)))]
[proc-title (text-block-pict proc-name [proc-title (text-block-pict proc-name
@ -442,15 +440,15 @@
#:width (viewable-region-width vregion))]) #:width (viewable-region-width vregion))])
(draw-stack-onto pct (draw-stack-onto pct
(at 0 (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))) (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color)))
(at 0 (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))) (- (frame-info-row-height finfo) (pict-height proc-title)))
1) 1)
proc-title) proc-title)
(at start-x (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)) (viewable-region-y vregion))
(colorize (hline (- end-x start-x) 1) (colorize (hline (- end-x start-x) 1)
(timeline-event-baseline-color)))))))) (timeline-event-baseline-color))))))))
@ -478,55 +476,6 @@
(let ([with-ruler (draw-ruler-on base vregion finfo)]) (let ([with-ruler (draw-ruler-on base vregion finfo)])
(draw-row-lines-on with-ruler vregion tr finfo opacity))) (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 ;;timeline-pict : (listof indexed-future-event) [viewable-region] [integer] -> pict
(define (timeline-pict logs (define (timeline-pict logs
#:x [x #f] #:x [x #f]
@ -576,8 +525,74 @@
overlay)] overlay)]
[else tp])) [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 (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 ([fst (get-seg-previous-to-vregion vregion seg)])
(let loop ([pct base-pct] (let loop ([pct base-pct]
[cur-seg fst]) [cur-seg fst])

5
collects/future-visualizer/private/visualizer-gui.rkt
View File

@ -133,7 +133,8 @@
[stretchable-width #t])) [stretchable-width #t]))
(define graphic-panel (new panel:horizontal-dragable% (define graphic-panel (new panel:horizontal-dragable%
[parent right-panel] [parent right-panel]
[stretchable-height #t])) [stretchable-height #t]
[stretchable-width #t]))
(define timeline-container (new vertical-panel% (define timeline-container (new vertical-panel%
[parent graphic-panel] [parent graphic-panel]
[stretchable-width #t] [stretchable-width #t]
@ -353,5 +354,7 @@
(send graphic-panel add-child graph-container) (send graphic-panel add-child graph-container)
(send item set-label "Hide Creation Tree"))) (send item set-label "Hide Creation Tree")))
(set! showing-create-graph (not showing-create-graph)))]) (set! showing-create-graph (not showing-create-graph)))])
(send main-panel set-percentages '(1/5 4/5))
(send f show #t)) (send f show #t))