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

.

Browse Source 
original commit: 6c12e120b9518055fca947fce68e4e1fa8c144ae
This commit is contained in:
Robby Findler 2005-01-25 21:49:43 +00:00
parent 84f0f073e4
commit 0cce14890d
1 changed files with 68 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
collects/mrlib/graph.ss
View File

@ -257,32 +257,75 @@
(inherit invalidate-bitmap-cache) (inherit invalidate-bitmap-cache)
(define/private (invalidate-to-children/parents snip) (define/private (invalidate-to-children/parents snip)
(when (is-a? snip graph-snip<%>) (when (is-a? snip graph-snip<%>)
(let ([children (get-all-children snip)] (let* ([children (get-all-children snip)]
[parents (get-all-parents snip)]) [parents (get-all-parents snip)]
(let-values ([(fx fy fw fh) (get-position snip)]) [rects (get-rectangles snip (append children parents))]
(let loop ([snips (append children parents)] [union (union-rects rects)]
[l fx] [invalidate-rect
[t fy] (lambda (rect)
[r (+ fx (max 0 fw))] (invalidate-bitmap-cache (rect-left rect)
[b (+ fy (max 0 fh))]) (rect-top rect)
(cond (- (rect-right rect)
[(null? snips) (rect-left rect))
(invalidate-bitmap-cache l t (- r l) (- b t))] (- (rect-bottom rect)
[else (rect-top rect))))])
(let ([c/p (car snips)]) (cond
(let-values ([(sx sy sw sh) (get-position c/p)]) [(< (rect-area union)
(if (eq? c/p snip) (apply + (map (lambda (x) (rect-area x)) rects)))
(loop (cdr snips) (invalidate-rect union)]
(- (min l sx) self-offset) [else
(min t sy) (for-each invalidate-rect rects)]))))
(+ (max r (+ sx sw)) self-offset)
(+ (max b (+ sy sh)) self-offset))
(loop (cdr snips)
(min l sx)
(min t sy)
(max r (+ sx sw))
(max b (+ sy sh))))))]))))))
;; 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)
(let ([main-snip-rect (snip->rect main-snip)])
(let loop ([c/p-snips c/p-snips])
(cond
[(null? c/p-snips) null]
[else
(let* ([c/p (car c/p-snips)]
[rect
(if (eq? c/p main-snip)
(let-values ([(sx sy sw sh) (get-position c/p)])
(make-rect (- sx self-offset)
sy
(+ (+ sx sw) self-offset)
(+ (+ sy sh) self-offset)))
(union-rects (list main-snip-rect
(snip->rect c/p))))])
(cons rect (loop (cdr c/p-snips))))]))))
(define/private (snip->rect snip)
(let-values ([(sx sy sw sh) (get-position snip)])
(make-rect sx sy (+ sx sw) (+ sy sh))))
(define/private (rect-area rect)
(* (- (rect-right rect)
(rect-left rect))
(- (rect-bottom rect)
(rect-top rect))))
(define/private (union-rects rects)
(cond
[(null? rects) (make-rect 0 0 0 0)]
[else
(let loop ([rects (cdr rects)]
[l (rect-left (car rects))]
[t (rect-top (car rects))]
[r (rect-right (car rects))]
[b (rect-bottom (car rects))])
(cond
[(null? rects) (make-rect l t r b)]
[else
(let ([rect (car rects)])
(loop (cdr rects)
(min l (rect-left rect))
(min t (rect-top rect))
(max r (rect-right rect))
(max b (rect-bottom rect))))]))]))
;; on-paint : ... -> void ;; on-paint : ... -> void
;; see docs, same as super ;; see docs, same as super
;; draws all of the lines and then draws all of the arrow heads ;; draws all of the lines and then draws all of the arrow heads