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

improve the performance for dragging around items in mrlib/graph

Browse Source 
(used by Redex's traces window and the module browser)

original commit: 9d4a3a6e07545cfad5ad38072ddaf2862eb9475a
This commit is contained in:
Robby Findler 2012-10-24 23:45:38 -05:00
parent 06e7b26962
commit 9767fde76d
1 changed files with 40 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
collects/mrlib/graph.rkt
View File

@ -3,6 +3,7 @@
racket/list racket/list
racket/math racket/math
racket/gui/base racket/gui/base
racket/match
(for-syntax racket/base) (for-syntax racket/base)
racket/contract) racket/contract)
@ -401,19 +402,20 @@
;; invalidate-to-children/parents : snip dc -> void ;; invalidate-to-children/parents : snip dc -> void
;; invalidates the region containing this snip and ;; invalidates the region containing this snip and
;; all of its children and parents. ;; all of its children and parents.
(inherit invalidate-bitmap-cache)
(define/private (invalidate-to-children/parents snip dc) (define/private (invalidate-to-children/parents snip dc)
(when (is-a? snip graph-snip<%>) (when (is-a? snip graph-snip<%>)
(unless (eq? last-dc dc)
(define-values (w h a s) (send dc get-text-extent "Label" #f #f 0))
(set! last-dc dc)
(set! text-height h))
(let* ([parents-and-children (append (get-all-parents snip) (let* ([parents-and-children (append (get-all-parents snip)
(get-all-children snip))] (get-all-children snip))]
[rects (eliminate-redundancies (get-rectangles snip parents-and-children))] [rects (get-rectangles snip parents-and-children)]
[or/c (or/c-rects rects)] [or/c (or/c-rects rects)]
[text-height (call-with-values
(λ () (send dc get-text-extent "Label" #f #f 0))
(λ (w h a s) h))]
[invalidate-rect [invalidate-rect
(lambda (rect) (lambda (rect)
(invalidate-bitmap-cache (- (rect-left rect) text-height) (save-rectangle-to-invalidate
(- (rect-left rect) text-height)
(- (rect-top rect) text-height) (- (rect-top rect) text-height)
(+ (- (rect-right rect) (+ (- (rect-right rect)
(rect-left rect)) (rect-left rect))
@ -427,31 +429,31 @@
(invalidate-rect or/c)] (invalidate-rect or/c)]
[else [else
(for-each invalidate-rect rects)])))) (for-each invalidate-rect rects)]))))
(inherit invalidate-bitmap-cache)
(define text-height #f)
(define last-dc #f)
;; (listof rect) -> (listof rect) (define pending-invalidate-rectangle #f)
(define/private (eliminate-redundancies rects) (define pending-invalidate-rectangle-timer #f)
(let loop ([rects rects] (define/private (run-pending-invalidate-rectangle)
[acc null]) (define the-pending-invalidate-rectangle pending-invalidate-rectangle)
(set! pending-invalidate-rectangle #f)
(invalidate-bitmap-cache . the-pending-invalidate-rectangle))
(define/private (save-rectangle-to-invalidate l t r b)
(unless pending-invalidate-rectangle-timer
(set! pending-invalidate-rectangle-timer
(new timer% [notify-callback
(λ () (run-pending-invalidate-rectangle))])))
(cond (cond
[(null? rects) acc] [pending-invalidate-rectangle
[else (let ([r (car rects)]) (match pending-invalidate-rectangle
(cond [(list l2 t2 r2 b2)
[(or (ormap (lambda (other-rect) (rect-included-in? r other-rect)) (set! pending-invalidate-rectangle
(cdr rects)) (list (min l l2) (min t t2) (max r r2) (max b b2)))])]
(ormap (lambda (other-rect) (rect-included-in? r other-rect))
acc))
(loop (cdr rects)
acc)]
[else [else
(loop (cdr rects) (set! pending-invalidate-rectangle (list l t r b))])
(cons r acc))]))]))) (send pending-invalidate-rectangle-timer start 20 #t))
;; rect-included-in? : rect rect -> boolean
(define/private (rect-included-in? r1 r2)
(and ((rect-left r1) . >= . (rect-left r2))
((rect-top r1) . >= . (rect-top r2))
((rect-right r1) . <= . (rect-right r2))
((rect-bottom r1) . <= . (rect-bottom r2))))
;; get-rectangles : snip (listof snip) -> rect ;; get-rectangles : snip (listof snip) -> rect
;; computes the rectangles that need to be invalidated for connecting ;; computes the rectangles that need to be invalidated for connecting
@ -519,7 +521,7 @@
(let ([old-font (send dc get-font)]) (let ([old-font (send dc get-font)])
(when edge-label-font (when edge-label-font
(send dc set-font edge-label-font)) (send dc set-font edge-label-font))
(draw-edges dc left top right bottom dx dy) (unless pending-invalidate-rectangle (draw-edges dc left top right bottom dx dy))
(when edge-label-font (when edge-label-font
(send dc set-font old-font)))) (send dc set-font old-font))))
(super on-paint before? dc left top right bottom dx dy draw-caret)) (super on-paint before? dc left top right bottom dx dy draw-caret))