.
original commit: 1f8a77c6ef9087dc1883ba471fca6d900338db9c
This commit is contained in:
Robby Findler
parent
6b54946ec1
commit
25179b393f
|
|
@ -355,63 +355,173 @@
|
|||
;; see docs, same as super
|
||||
;; draws all of the lines and then draws all of the arrow heads
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(when before?
|
||||
(let ([old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
|
||||
(draw-all-connections dc dx dy left top right bottom #f)
|
||||
(draw-all-connections dc dx dy left top right bottom #t)
|
||||
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret))
|
||||
|
||||
;; draw-all-connections : ... boolean -> void
|
||||
;; draws all of the connections between the snips
|
||||
;; first args are the same as those to on-paint
|
||||
(define/private (draw-all-connections dc dx dy left top right bottom arrow-heads?)
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(when snip
|
||||
(when (and (send snip get-admin)
|
||||
(is-a? snip graph-snip<%>))
|
||||
(for-each (lambda (parent-link)
|
||||
(draw-connection
|
||||
dc dx dy parent-link snip #f
|
||||
left top right bottom
|
||||
arrow-heads?))
|
||||
(send snip get-parent-links)))
|
||||
(loop (send snip next))))
|
||||
|
||||
(for-each
|
||||
(lambda (currently-over)
|
||||
(for-each
|
||||
(lambda (child)
|
||||
(let ([parent-link-f
|
||||
(memf (lambda (parent-link) (eq? currently-over (link-snip parent-link)))
|
||||
(send child get-parent-links))])
|
||||
(when parent-link-f
|
||||
(draw-connection dc dx dy
|
||||
(car parent-link-f) child #t
|
||||
left top right bottom
|
||||
arrow-heads?))))
|
||||
(send currently-over get-children))
|
||||
(for-each
|
||||
(lambda (parent-link)
|
||||
(draw-connection dc dx dy parent-link currently-over #t
|
||||
left top right bottom
|
||||
(let ()
|
||||
;; draw-all-connections : ... boolean -> void
|
||||
;; draws all of the connections between the snips
|
||||
;; first args are the same as those to on-paint
|
||||
(define (draw-all-connections arrow-heads?)
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(when snip
|
||||
(when (and (send snip get-admin)
|
||||
(is-a? snip graph-snip<%>))
|
||||
(for-each (lambda (parent-link)
|
||||
(draw-connection
|
||||
parent-link snip #f
|
||||
arrow-heads?))
|
||||
(send currently-over get-parent-links)))
|
||||
currently-overs))
|
||||
|
||||
;; draw-connection : dc number number link snip boolean number number number number boolean -> void
|
||||
;; sets the drawing context (pen and brush)
|
||||
;; determines if the connection is between a snip and itself or two different snips
|
||||
;; and calls draw-self-connection or draw-non-self-connection
|
||||
(define/private (draw-connection dc raw-dx raw-dy from-link to dark-lines?
|
||||
left top right bottom
|
||||
arrow-heads?)
|
||||
(let ([from (link-snip from-link)])
|
||||
(when (send from get-admin)
|
||||
(send snip get-parent-links)))
|
||||
(loop (send snip next))))
|
||||
|
||||
(for-each
|
||||
(lambda (currently-over)
|
||||
(for-each
|
||||
(lambda (child)
|
||||
(let ([parent-link-f
|
||||
(memf (lambda (parent-link) (eq? currently-over (link-snip parent-link)))
|
||||
(send child get-parent-links))])
|
||||
(when parent-link-f
|
||||
(draw-connection (car parent-link-f) child #t
|
||||
arrow-heads?))))
|
||||
(send currently-over get-children))
|
||||
(for-each
|
||||
(lambda (parent-link)
|
||||
(draw-connection parent-link currently-over #t
|
||||
arrow-heads?))
|
||||
(send currently-over get-parent-links)))
|
||||
currently-overs))
|
||||
|
||||
;; draw-connection : link snip boolean boolean -> void
|
||||
;; sets the drawing context (pen and brush)
|
||||
;; determines if the connection is between a snip and itself or two different snips
|
||||
;; and calls draw-self-connection or draw-non-self-connection
|
||||
(define (draw-connection from-link to dark-lines? arrow-heads?)
|
||||
(let ([from (link-snip from-link)])
|
||||
(when (send from get-admin)
|
||||
(let ([dx (+ dx (link-dx from-link))]
|
||||
[dy (+ dy (link-dy from-link))])
|
||||
(cond
|
||||
[(eq? from to)
|
||||
(set-pen/brush from-link dark-lines?)
|
||||
(draw-self-connection dx dy (link-snip from-link) arrow-heads?)]
|
||||
[else
|
||||
(draw-non-self-connection dx dy from-link dark-lines? to arrow-heads?)])))))
|
||||
|
||||
(define (draw-self-connection dx dy snip arrow-heads?)
|
||||
(let*-values ([(sx sy sw sh) (get-position snip)]
|
||||
[(s1x s1y) (values (+ sx sw) (+ sy (* sh 1/2)))]
|
||||
[(s2x s2y) (values (+ sx sw self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))]
|
||||
[(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))]
|
||||
[(b12x b12y) (values s2x s1y)]
|
||||
[(b23x b23y) (values s2x s3y)]
|
||||
|
||||
[(s4x s4y) (values (- sx arrowhead-short-side)
|
||||
(+ sy (* sh 1/2)))]
|
||||
[(s5x s5y) (values (- sx arrowhead-short-side self-offset)
|
||||
(+ sy (* 3/4 sh) (* 1/2 self-offset)))]
|
||||
[(s6x s6y) (values (- sx arrowhead-short-side)
|
||||
(+ sy sh self-offset))]
|
||||
[(b45x b45y) (values s5x s4y)]
|
||||
[(b56x b56y) (values s5x s6y)])
|
||||
|
||||
(update-polygon s4x s4y sx s4y)
|
||||
(let ([os (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(cond
|
||||
[arrow-heads?
|
||||
(send dc draw-polygon points dx dy)]
|
||||
[else
|
||||
(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-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 s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) (+ dy s6y))])
|
||||
(send dc set-smoothing os))))
|
||||
|
||||
(define (draw-non-self-connection dx dy from-link dark-lines? to arrow-heads?)
|
||||
(let ([from (link-snip from-link)])
|
||||
(let*-values ([(xf yf wf hf) (get-position from)]
|
||||
[(xt yt wt ht) (get-position to)]
|
||||
[(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))]
|
||||
[(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))])
|
||||
(let ([x1 (+ xf (/ wf 2))]
|
||||
[y1 (+ yf (/ hf 2))]
|
||||
[x2 (+ xt (/ wt 2))]
|
||||
[y2 (+ yt (/ ht 2))])
|
||||
|
||||
(unless (or (and (x1 . <= . left)
|
||||
(x2 . <= . left))
|
||||
(and (x1 . >= . right)
|
||||
(x2 . >= . right))
|
||||
(and (y1 . <= . top)
|
||||
(y2 . <= . top))
|
||||
(and (y1 . >= . bottom)
|
||||
(y2 . >= . bottom)))
|
||||
(set-pen/brush from-link dark-lines?)
|
||||
(let-values ([(from-x from-y)
|
||||
(or-2v (find-intersection x1 y1 x2 y2
|
||||
lf tf rf tf)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lf bf rf bf)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lf tf lf bf)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
rf tf rf bf))]
|
||||
[(to-x to-y)
|
||||
(or-2v (find-intersection x1 y1 x2 y2
|
||||
lt tt rt tt)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lt bt rt bt)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lt tt lt bt)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
rt tt rt bt))])
|
||||
(when (and from-x from-y to-x to-y)
|
||||
(let ()
|
||||
(define (arrow-point-ok? point-x point-y)
|
||||
(and (in-rectangle? point-x point-y
|
||||
(min lt rt lf rf) (min tt bt tf bf)
|
||||
(max lt rt lf rf) (max tt bt tf bf))
|
||||
(not (strict-in-rectangle? point-x point-y
|
||||
(min lt rt) (min tt bt)
|
||||
(max lt rt) (max tt bt)))
|
||||
(not (strict-in-rectangle? point-x point-y
|
||||
(min lf rf) (min tf bf)
|
||||
(max lf rf) (max tf bf)))))
|
||||
(update-polygon from-x from-y to-x to-y)
|
||||
(cond
|
||||
[(or (in-rectangle? from-x from-y lt tt rt bt)
|
||||
(in-rectangle? to-x to-y lf tf rf bf))
|
||||
;; the snips overlap, draw nothing
|
||||
(void)]
|
||||
[(and (arrow-point-ok? (send point1 get-x) (send point1 get-y))
|
||||
(arrow-point-ok? (send point2 get-x) (send point2 get-y))
|
||||
(arrow-point-ok? (send point3 get-x) (send point3 get-y))
|
||||
(arrow-point-ok? (send point4 get-x) (send point4 get-y)))
|
||||
;; the arrowhead is not overlapping the snips, so draw it
|
||||
;; (this is only an approximate test, but probably good enough)
|
||||
(let ([os (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(cond
|
||||
[arrow-heads?
|
||||
(send dc draw-polygon points dx dy)]
|
||||
[else
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))])
|
||||
|
||||
(send dc set-smoothing os))]
|
||||
[else
|
||||
;; give up on the arrowhead and just draw a line
|
||||
(cond
|
||||
[arrow-heads? (void)]
|
||||
[else
|
||||
(let ([os (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))
|
||||
(send dc set-smoothing os))])])))))))))
|
||||
|
||||
(define (set-pen/brush from-link dark-lines?)
|
||||
(send dc set-brush
|
||||
(if dark-lines?
|
||||
(link-dark-brush from-link)
|
||||
|
|
@ -419,130 +529,20 @@
|
|||
(send dc set-pen
|
||||
(if dark-lines?
|
||||
(link-dark-pen from-link)
|
||||
(link-light-pen from-link)))
|
||||
(let ([dx (+ raw-dx (link-dx from-link))]
|
||||
[dy (+ raw-dy (link-dy from-link))])
|
||||
(cond
|
||||
[(eq? from to)
|
||||
(draw-self-connection dc dx dy from left top right bottom arrow-heads?)]
|
||||
[else
|
||||
(draw-non-self-connection dc dx dy from to left top right bottom arrow-heads?)])))))
|
||||
|
||||
(define/private (draw-self-connection dc dx dy snip left top right bottom arrow-heads?)
|
||||
(let*-values ([(sx sy sw sh) (get-position snip)]
|
||||
[(s1x s1y) (values (+ sx sw) (+ sy (* sh 1/2)))]
|
||||
[(s2x s2y) (values (+ sx sw self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))]
|
||||
[(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))]
|
||||
[(b12x b12y) (values s2x s1y)]
|
||||
[(b23x b23y) (values s2x s3y)]
|
||||
|
||||
[(s4x s4y) (values (- sx arrowhead-short-side)
|
||||
(+ sy (* sh 1/2)))]
|
||||
[(s5x s5y) (values (- sx arrowhead-short-side self-offset)
|
||||
(+ sy (* 3/4 sh) (* 1/2 self-offset)))]
|
||||
[(s6x s6y) (values (- sx arrowhead-short-side)
|
||||
(+ sy sh self-offset))]
|
||||
[(b45x b45y) (values s5x s4y)]
|
||||
[(b56x b56y) (values s5x s6y)])
|
||||
(link-light-pen from-link))))
|
||||
|
||||
(update-polygon s4x s4y sx s4y)
|
||||
(let ([os (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(cond
|
||||
[arrow-heads?
|
||||
(send dc draw-polygon points dx dy)]
|
||||
[else
|
||||
(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-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 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
|
||||
left top right bottom
|
||||
arrow-heads?)
|
||||
(let*-values ([(xf yf wf hf) (get-position from)]
|
||||
[(xt yt wt ht) (get-position to)]
|
||||
[(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))]
|
||||
[(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))])
|
||||
(let ([x1 (+ xf (/ wf 2))]
|
||||
[y1 (+ yf (/ hf 2))]
|
||||
[x2 (+ xt (/ wt 2))]
|
||||
[y2 (+ yt (/ ht 2))])
|
||||
|
||||
(unless (or (and (x1 . <= . left)
|
||||
(x2 . <= . left))
|
||||
(and (x1 . >= . right)
|
||||
(x2 . >= . right))
|
||||
(and (y1 . <= . top)
|
||||
(y2 . <= . top))
|
||||
(and (y1 . >= . bottom)
|
||||
(y2 . >= . bottom)))
|
||||
(let-values ([(from-x from-y)
|
||||
(or-2v (find-intersection x1 y1 x2 y2
|
||||
lf tf rf tf)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lf bf rf bf)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lf tf lf bf)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
rf tf rf bf))]
|
||||
[(to-x to-y)
|
||||
(or-2v (find-intersection x1 y1 x2 y2
|
||||
lt tt rt tt)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lt bt rt bt)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
lt tt lt bt)
|
||||
(find-intersection x1 y1 x2 y2
|
||||
rt tt rt bt))])
|
||||
(when (and from-x from-y to-x to-y)
|
||||
(let ()
|
||||
(define (arrow-point-ok? point-x point-y)
|
||||
(and (in-rectangle? point-x point-y
|
||||
(min lt rt lf rf) (min tt bt tf bf)
|
||||
(max lt rt lf rf) (max tt bt tf bf))
|
||||
(not (strict-in-rectangle? point-x point-y
|
||||
(min lt rt) (min tt bt)
|
||||
(max lt rt) (max tt bt)))
|
||||
(not (strict-in-rectangle? point-x point-y
|
||||
(min lf rf) (min tf bf)
|
||||
(max lf rf) (max tf bf)))))
|
||||
(update-polygon from-x from-y to-x to-y)
|
||||
(cond
|
||||
[(or (in-rectangle? from-x from-y lt tt rt bt)
|
||||
(in-rectangle? to-x to-y lf tf rf bf))
|
||||
;; the snips overlap, draw nothing
|
||||
(void)]
|
||||
[(and (arrow-point-ok? (send point1 get-x) (send point1 get-y))
|
||||
(arrow-point-ok? (send point2 get-x) (send point2 get-y))
|
||||
(arrow-point-ok? (send point3 get-x) (send point3 get-y))
|
||||
(arrow-point-ok? (send point4 get-x) (send point4 get-y)))
|
||||
;; the arrowhead is not overlapping the snips, so draw it
|
||||
;; (this is only an approximate test, but probably good enough)
|
||||
(let ([os (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(cond
|
||||
[arrow-heads?
|
||||
(send dc draw-polygon points dx dy)]
|
||||
[else
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))])
|
||||
|
||||
(send dc set-smoothing os))]
|
||||
[else
|
||||
;; give up on the arrowhead and just draw a line
|
||||
(cond
|
||||
[arrow-heads? (void)]
|
||||
[else
|
||||
(let ([os (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))
|
||||
(send dc set-smoothing os))])]))))))))
|
||||
;;; body of on-paint
|
||||
|
||||
(when before?
|
||||
(let ([old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
|
||||
(draw-all-connections #f)
|
||||
(draw-all-connections #t)
|
||||
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)))
|
||||
|
||||
|
||||
(field
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user