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

clean up rectangle computations, fixing some bugs along the way

Browse Source
This commit is contained in:
Robby Findler 2012-10-26 21:48:58 -05:00
parent c6caf11323
commit 8bc3b70a3c
1 changed files with 28 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/mrlib/graph.rkt
View File

@ -378,7 +378,7 @@
(let ([old-currently-overs currently-overs])
(set! currently-overs new-currently-overs)
(on-mouse-over-snips currently-overs)
(on-mouse-over-snips currently-overs)
(for-each
(lambda (old-currently-over)
(invalidate-to-children/parents old-currently-over dc))
@ -388,8 +388,7 @@
(invalidate-to-children/parents new-currently-over dc))
new-currently-overs))))
(define/public (on-mouse-over-snips snips)
(void))
(define/public (on-mouse-over-snips snips) (void))
;; set-equal : (listof snip) (listof snip) -> boolean
;; typically lists will be small (length 1),
@ -404,37 +403,20 @@
;; all of its children and parents.
(define/private (invalidate-to-children/parents snip dc)
(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)
(get-all-children snip))]
[rects (get-rectangles snip parents-and-children)]
[or/c (or/c-rects rects)]
[invalidate-rect
(lambda (rect)
(save-rectangle-to-invalidate
(- (rect-left rect) text-height)
(- (rect-top rect) text-height)
(+ (- (rect-right rect)
(rect-left rect))
text-height)
(+ (- (rect-bottom rect)
(rect-top rect))
text-height)))])
(cond
[(< (rect-area or/c)
(apply + (map (lambda (x) (rect-area x)) rects)))
(invalidate-rect or/c)]
[else
(for-each invalidate-rect rects)]))))
(inherit invalidate-bitmap-cache)
(define text-height #f)
(define last-dc #f)
(define-values (_1 text-height _2 _3) (send dc get-text-extent "Label" #f #f 0))
(define parents-and-children (append (get-all-parents snip)
(get-all-children snip)))
(define rects (get-rectangles snip parents-and-children))
(for ([rect (in-list rects)])
(save-rectangle-to-invalidate
(- (rect-left rect) text-height)
(- (rect-top rect) text-height)
(+ (rect-right rect) text-height)
(+ (rect-bottom rect) text-height)))))
(define pending-invalidate-rectangle #f)
(define pending-invalidate-rectangle-timer #f)
(inherit invalidate-bitmap-cache)
(define/private (run-pending-invalidate-rectangle)
(define the-pending-invalidate-rectangle pending-invalidate-rectangle)
(set! pending-invalidate-rectangle #f)
@ -445,16 +427,17 @@
(set! pending-invalidate-rectangle-timer
(new timer% [notify-callback
(λ () (run-pending-invalidate-rectangle))])))
(cond
[pending-invalidate-rectangle
(match pending-invalidate-rectangle
[(list l2 t2 r2 b2)
(set! pending-invalidate-rectangle
(list (min l l2) (min t t2) (max r r2) (max b b2)))])]
[else
(set! pending-invalidate-rectangle (list l t r b))])
(add-to-pending-indvalidate-rectangle l t r b)
(send pending-invalidate-rectangle-timer start 20 #t))
(define/private (add-to-pending-indvalidate-rectangle l t r b)
(set! pending-invalidate-rectangle
(match pending-invalidate-rectangle
[(list l2 t2 r2 b2)
(list (min l l2) (min t t2) (max r r2) (max b b2))]
[#f
(list l t r b)])))
;; get-rectangles : snip (listof snip) -> rect
;; computes the rectangles that need to be invalidated for connecting
(define/private (get-rectangles main-snip c/p-snips)
@ -521,7 +504,11 @@
(let ([old-font (send dc get-font)])
(when edge-label-font
(send dc set-font edge-label-font))
(unless pending-invalidate-rectangle (draw-edges dc left top right bottom dx dy))
(cond
[pending-invalidate-rectangle
(add-to-pending-indvalidate-rectangle left top right bottom)]
[else
(draw-edges dc left top right bottom dx dy)])
(when edge-label-font
(send dc set-font old-font))))
(super on-paint before? dc left top right bottom dx dy draw-caret))