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

57
collects/mrlib/graph.rkt
View File

@ -388,8 +388,7 @@
(invalidate-to-children/parents new-currently-over dc)) (invalidate-to-children/parents new-currently-over dc))
new-currently-overs)))) new-currently-overs))))
(define/public (on-mouse-over-snips snips) (define/public (on-mouse-over-snips snips) (void))
(void))
;; set-equal : (listof snip) (listof snip) -> boolean ;; set-equal : (listof snip) (listof snip) -> boolean
;; typically lists will be small (length 1), ;; typically lists will be small (length 1),
@ -404,37 +403,20 @@
;; all of its children and parents. ;; all of its children and parents.
(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 (_1 text-height _2 _3) (send dc get-text-extent "Label" #f #f 0))
(define-values (w h a s) (send dc get-text-extent "Label" #f #f 0)) (define parents-and-children (append (get-all-parents snip)
(set! last-dc dc) (get-all-children snip)))
(set! text-height h)) (define rects (get-rectangles snip parents-and-children))
(let* ([parents-and-children (append (get-all-parents snip) (for ([rect (in-list rects)])
(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 (save-rectangle-to-invalidate
(- (rect-left rect) text-height) (- (rect-left rect) text-height)
(- (rect-top rect) text-height) (- (rect-top rect) text-height)
(+ (- (rect-right rect) (+ (rect-right rect) text-height)
(rect-left rect)) (+ (rect-bottom rect) text-height)))))
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 pending-invalidate-rectangle #f) (define pending-invalidate-rectangle #f)
(define pending-invalidate-rectangle-timer #f) (define pending-invalidate-rectangle-timer #f)
(inherit invalidate-bitmap-cache)
(define/private (run-pending-invalidate-rectangle) (define/private (run-pending-invalidate-rectangle)
(define the-pending-invalidate-rectangle pending-invalidate-rectangle) (define the-pending-invalidate-rectangle pending-invalidate-rectangle)
(set! pending-invalidate-rectangle #f) (set! pending-invalidate-rectangle #f)
@ -445,15 +427,16 @@
(set! pending-invalidate-rectangle-timer (set! pending-invalidate-rectangle-timer
(new timer% [notify-callback (new timer% [notify-callback
(λ () (run-pending-invalidate-rectangle))]))) (λ () (run-pending-invalidate-rectangle))])))
(cond (add-to-pending-indvalidate-rectangle l t r b)
[pending-invalidate-rectangle (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 (match pending-invalidate-rectangle
[(list l2 t2 r2 b2) [(list l2 t2 r2 b2)
(set! pending-invalidate-rectangle (list (min l l2) (min t t2) (max r r2) (max b b2))]
(list (min l l2) (min t t2) (max r r2) (max b b2)))])] [#f
[else (list l t r b)])))
(set! pending-invalidate-rectangle (list l t r b))])
(send pending-invalidate-rectangle-timer start 20 #t))
;; 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
@ -521,7 +504,11 @@
(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))
(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 (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))