Future visualizer - more performance improvement
(cherry picked from commit 1355c711a8
)
This commit is contained in:
parent
f458b167f0
commit
32fe5e2722
|
@ -17,24 +17,15 @@
|
|||
(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 need-redraw? #f)
|
||||
(define delaying-redraw #f)
|
||||
(define cached-bitmap #f)
|
||||
(define delaying-redraw? #f)
|
||||
(define cached-base-bitmap #f)
|
||||
(define cached-overlay-bitmap #f)
|
||||
(define cached-base-pict #f)
|
||||
(define repainting? #f)
|
||||
|
||||
(define/private (get-viewable-region)
|
||||
(define-values (x y) (get-view-start))
|
||||
|
@ -48,10 +39,8 @@
|
|||
;pict layers for the canvas
|
||||
;;rebuild-the-pict : viewable-region -> void
|
||||
(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 (or (not cached-base-bitmap) (not only-the-overlay?))
|
||||
(set! cached-base-bitmap (pict->bitmap (scale (bp vregion) scale-factor))))
|
||||
(when ob
|
||||
(set! cached-overlay-bitmap (pict->bitmap (ob vregion scale-factor)))))
|
||||
|
||||
|
@ -70,35 +59,31 @@
|
|||
[need-redraw?
|
||||
(redraw-the-bitmap! vregion #:only-the-overlay? only-the-overlay?)
|
||||
(set! need-redraw? #f)]
|
||||
[(not delaying-redraw)
|
||||
[(not delaying-redraw?)
|
||||
(new timer% [notify-callback (λ ()
|
||||
(set! delaying-redraw #f)
|
||||
(set! delaying-redraw? #f)
|
||||
(set! need-redraw? #t)
|
||||
(redraw-the-bitmap/maybe-delayed! (get-viewable-region) #:only-the-overlay? only-the-overlay?)
|
||||
(refresh))]
|
||||
[interval delay]
|
||||
[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))))
|
||||
(set! delaying-redraw? #t)]))
|
||||
|
||||
(define last-vregion #f)
|
||||
|
||||
(define (scroll-or-size-event? vregion)
|
||||
(not (equal? vregion last-vregion)))
|
||||
|
||||
(define/override (on-paint)
|
||||
(define vregion (get-viewable-region))
|
||||
(when (and (not delaying-redraw) (not (equal? vregion last-vregion)))
|
||||
(when (and (not delaying-redraw?) (scroll-or-size-event? vregion))
|
||||
(redraw-the-bitmap/maybe-delayed! vregion))
|
||||
(set! last-vregion vregion)
|
||||
(define dc (get-dc))
|
||||
(when cached-bitmap
|
||||
(when cached-base-bitmap
|
||||
(send dc
|
||||
draw-bitmap
|
||||
cached-bitmap
|
||||
cached-base-bitmap
|
||||
(viewable-region-x vregion)
|
||||
(viewable-region-y vregion)))
|
||||
(when cached-overlay-bitmap
|
||||
|
@ -115,7 +100,7 @@
|
|||
(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
|
||||
(when (mh x y vregion) ;Mouse handler returns non-false if a state change requiring redraw occurred
|
||||
(redraw-the-bitmap/maybe-delayed! vregion #:delay 0 #:only-the-overlay? #t)))]
|
||||
[(left-up)
|
||||
(when ch (ch x y vregion)) ;Ditto for click handler
|
||||
|
|
|
@ -437,20 +437,8 @@
|
|||
#:forecolor (header-forecolor)
|
||||
#:padding HEADER-PADDING
|
||||
#:opacity opacity
|
||||
#:width (viewable-region-width vregion))]
|
||||
[row-mid (- (- (* index (frame-info-row-height finfo))
|
||||
(pict-height proc-title))
|
||||
(viewable-region-y vregion))])
|
||||
#:width (viewable-region-width 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)))
|
||||
|
@ -586,14 +574,14 @@
|
|||
#:with-arrow with-arrow
|
||||
#:style style))))
|
||||
|
||||
(define (get-seg-left-of-vregion vregion seg)
|
||||
#;(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]
|
||||
[(not prev-in-time) seg]
|
||||
[((segment-edge prev-in-time) . < . (viewable-region-x vregion)) prev-in-time]
|
||||
[else (get-seg-left-of-vregion vregion prev-in-time)]))
|
||||
|
||||
(define (draw-arrows base-pct vregion seg)
|
||||
#;(define (draw-arrows base-pct vregion seg)
|
||||
(define fst (get-seg-left-of-vregion vregion seg))
|
||||
(let loop ([p base-pct]
|
||||
[cur-seg fst])
|
||||
|
@ -606,14 +594,14 @@
|
|||
next-seg
|
||||
p
|
||||
(event-connection-line-color)
|
||||
#:width 2))
|
||||
#:width 1))
|
||||
(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
|
||||
#;(define (draw-arrows base-pct vregion seg)
|
||||
(define (draw-arrows base-pct vregion seg)
|
||||
(let ([fst (get-seg-previous-to-vregion vregion seg)])
|
||||
(let loop ([pct base-pct]
|
||||
[cur-seg fst])
|
||||
|
|
Loading…
Reference in New Issue
Block a user