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

.

Browse Source 
original commit: 4ae82b1f91bdeb9546db210b789bb0df8c7f8312
This commit is contained in:
Robby Findler 2005-01-22 21:59:49 +00:00
parent 6f8905fd1f
commit aab616a984
1 changed files with 32 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/mrlib/graph.ss
View File

@ -262,8 +262,8 @@
(let loop ([snips (append children parents)] (let loop ([snips (append children parents)]
[l fx] [l fx]
[t fy] [t fy]
[r (+ fx fw)] [r (+ fx (max 0 fw))]
[b (+ fy fh)]) [b (+ fy (max 0 fh))])
(cond (cond
[(null? snips) [(null? snips)
(invalidate-bitmap-cache l t (- r l) (- b t))] (invalidate-bitmap-cache l t (- r l) (- b t))]
@ -377,18 +377,18 @@
[(b56x b56y) (values s5x s6y)]) [(b56x b56y) (values s5x s6y)])
(update-polygon s4x s4y sx s4y) (update-polygon s4x s4y sx s4y)
(cond
[arrow-heads?
(let ([os (send dc get-smoothing)]) (let ([os (send dc get-smoothing)])
(send dc set-smoothing 'aligned) (send dc set-smoothing 'aligned)
(send dc draw-polygon points dx dy) (cond
(send dc set-smoothing os))] [arrow-heads?
(send dc draw-polygon points dx dy)]
[else [else
(send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y)) (send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y))
(send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y)) (send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y))
(send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y)) (send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y))
(send dc draw-spline (+ dx s4x) (+ dy s4y) (+ dx b45x) (+ dy b45y) (+ dx s5x) (+ dy s5y)) (send dc draw-spline (+ dx s4x) (+ dy s4y) (+ dx b45x) (+ dy b45y) (+ dx s5x) (+ dy s5y))
(send dc draw-spline (+ dx s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) (+ dy s6y))]))) (send dc draw-spline (+ dx s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) (+ dy s6y))])
(send dc set-smoothing os))))
(define/private (draw-non-self-connection dc dx dy from to (define/private (draw-non-self-connection dc dx dy from to
left top right bottom left top right bottom
@ -453,24 +453,28 @@
(arrow-point-ok? (send point4 get-x) (send point4 get-y))) (arrow-point-ok? (send point4 get-x) (send point4 get-y)))
;; the arrowhead is not overlapping the snips, so draw it ;; the arrowhead is not overlapping the snips, so draw it
;; (this is only an approximate test, but probably good enough) ;; (this is only an approximate test, but probably good enough)
(cond
[arrow-heads?
(let ([os (send dc get-smoothing)]) (let ([os (send dc get-smoothing)])
(send dc set-smoothing 'aligned) (send dc set-smoothing 'aligned)
(send dc draw-polygon points dx dy) (cond
(send dc set-smoothing os))] [arrow-heads?
(send dc draw-polygon points dx dy)]
[else [else
(send dc draw-line (send dc draw-line
(+ dx from-x) (+ dy from-y) (+ dx from-x) (+ dy from-y)
(+ dx to-x) (+ dy to-y))])] (+ dx to-x) (+ dy to-y))])
(send dc set-smoothing os))]
[else [else
;; give up on the arrowhead and just draw a line ;; give up on the arrowhead and just draw a line
(cond (cond
[arrow-heads? (void)] [arrow-heads? (void)]
[else [else
(let ([os (send dc get-smoothing)])
(send dc set-smoothing 'aligned)
(send dc draw-line (send dc draw-line
(+ dx from-x) (+ dy from-y) (+ dx from-x) (+ dy from-y)
(+ dx to-x) (+ dy to-y))])])))))))) (+ dx to-x) (+ dy to-y))
(send dc set-smoothing os))])]))))))))
(field (field