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

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

@ -27,6 +27,7 @@
viewable-region-y-extent
in-viewable-region
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)

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

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

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

@ -200,7 +200,6 @@
[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))
(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])

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

@ -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]
@ -354,4 +355,6 @@
(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))