added support for special-case drawing of individual edges to the graph library and support to be able to use that to redex
svn: r13226 original commit: af810c8a6ff52e1af97b7096ec7383b54ea98465
This commit is contained in:
Robby Findler
parent
7c51232ab6
commit
6d0d1640f3
|
|
@ -231,7 +231,8 @@
|
|||
(mixin ((class->interface pasteboard%)) (graph-pasteboard<%>)
|
||||
(inherit find-first-snip find-next-selected-snip)
|
||||
|
||||
(init-field [edge-label-font #f])
|
||||
(init-field [edge-label-font #f]
|
||||
[edge-labels? #t])
|
||||
|
||||
(define draw-arrow-heads? #t)
|
||||
(inherit refresh get-admin)
|
||||
|
|
@ -535,12 +536,12 @@
|
|||
[(b45x b45y) (values s5x s4y)]
|
||||
[(b56x b56y) (values s5x s6y)])
|
||||
|
||||
(update-polygon s4x s4y sx s4y)
|
||||
(update-arrowhead-polygon s4x s4y sx s4y)
|
||||
(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))
|
||||
|
||||
(when (link-label the-link)
|
||||
(when (and edge-labels? (link-label the-link))
|
||||
(let* ((textlen (get-text-length (link-label the-link)))
|
||||
(linelen (- s6x s3x))
|
||||
(offset (* 1/2 (- linelen textlen))))
|
||||
|
|
@ -606,19 +607,8 @@
|
|||
;; the snips overlap, draw nothing
|
||||
(void)]
|
||||
[else
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))
|
||||
(update-polygon from-x from-y to-x to-y)
|
||||
(when (and draw-arrow-heads?
|
||||
(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)
|
||||
(send dc draw-polygon points dx dy))
|
||||
(when (named-link? from-link)
|
||||
(draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
|
||||
(when (and edge-labels? (link-label from-link))
|
||||
(let-values ([(text-len h d v) (send dc get-text-extent (link-label from-link))])
|
||||
(let* ([arrow-end-x (send point3 get-x)]
|
||||
[arrow-end-y (send point3 get-y)]
|
||||
|
|
@ -628,15 +618,14 @@
|
|||
(- (* 1/2 vec)
|
||||
(make-polar (/ text-len 2) (angle vec))))])
|
||||
(when (> (sqrt (+ (sqr (- arrow-end-x from-x))
|
||||
(sqr (- arrow-end-y from-y))))
|
||||
text-len)
|
||||
(sqr (- arrow-end-y from-y))))
|
||||
text-len)
|
||||
(send dc draw-text (link-label from-link)
|
||||
(+ dx (real-part middle))
|
||||
(+ dy (imag-part middle))
|
||||
#f
|
||||
0
|
||||
(- (angle vec)))))))]))))))))
|
||||
(define (named-link? l) (link-label l))
|
||||
|
||||
(define (set-pen/brush from-link dark-lines?)
|
||||
(send dc set-brush
|
||||
|
|
@ -678,6 +667,20 @@
|
|||
(send dc set-text-foreground old-fg)
|
||||
(send dc set-brush old-brush))))
|
||||
|
||||
(define/public (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))
|
||||
(update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4)
|
||||
(when (and draw-arrow-heads?
|
||||
(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)
|
||||
(send dc draw-polygon points dx dy)))
|
||||
|
||||
;; for-each-to-redraw : number number number number (link snip -> void)
|
||||
(define/private (for-each-to-redraw left top right bottom f)
|
||||
(let ()
|
||||
|
|
@ -727,11 +730,11 @@
|
|||
[point4 (make-object point% 0 0)]
|
||||
[points (list point1 point2 point3 point4)])
|
||||
|
||||
;; update-polygon : number^4 -> void
|
||||
;; update-arrowhead-polygon : number^4 -> void
|
||||
;; updates points1, 2, and 3 with the arrow head's
|
||||
;; points. Use a turtle-like movement to find the points.
|
||||
;; point3 is the point where the line should end.
|
||||
(define/private (update-polygon from-x from-y to-x to-y)
|
||||
(define/public (update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4)
|
||||
(define (move tx ty ta d) (values (+ tx (* d (cos ta)))
|
||||
(+ ty (* d (sin ta)))
|
||||
ta))
|
||||
|
|
|
|||
|
|
@ -60,5 +60,51 @@ different nodes.
|
|||
is @scheme[#t].
|
||||
}
|
||||
|
||||
@defmethod[(draw-single-edge [dc (is-a?/c dc<%>)]
|
||||
[dx real?]
|
||||
[dy real?]
|
||||
[from (is-a?/c graph-snip<%>)]
|
||||
[to (is-a?/c graph-snip<%>)]
|
||||
[from-x real?]
|
||||
[from-y real?]
|
||||
[to-x real?]
|
||||
[to-y real?]
|
||||
[arrow-point-ok? (-> real? real? boolean?)]) void?]{
|
||||
|
||||
This method is called to draw each edge in the graph, except
|
||||
for the edges that connect a node to itself.
|
||||
|
||||
The @scheme[dc], @scheme[dx], and @scheme[dy] arguments are
|
||||
the same as in @method[editor<%> on-paint].
|
||||
|
||||
The
|
||||
@scheme[from-x], @scheme[from-y], @scheme[to-x], and
|
||||
@scheme[to-y] arguments specify points on the source and
|
||||
destination snip's bounding box where a straight line
|
||||
between the centers of the snip would intersect.
|
||||
|
||||
The @scheme[arrow-point-ok?] function returns @scheme[#t]
|
||||
when the point specified by its arguments is inside the the
|
||||
smallest rectangle that covers both the source and
|
||||
destination snips, but is outside of both of the rectangles
|
||||
that surround the source and destination snips themselves.
|
||||
|
||||
This default implementation uses @scheme[update-polygon] to compute
|
||||
the arrowheads and otherwise draws a straight line between the two
|
||||
points and then the arrowheads, unless the arrowhead points
|
||||
are not ok according to @scheme[arrow-point-ok?], in which case
|
||||
it just draws the line.
|
||||
}
|
||||
|
||||
@defmethod[(update-arrowhead-polygon [from-x real?] [from-y real?] [to-x real?] [to-y real?]
|
||||
[point1 (is-a?/c point%)]
|
||||
[point2 (is-a?/c point%)]
|
||||
[point3 (is-a?/c point%)]
|
||||
[point4 (is-a?/c point%)]) void?]{
|
||||
|
||||
Updates the arguments @scheme[point1], @scheme[point2], @scheme[point3], @scheme[point4] with the coordinates
|
||||
of an arrowhead for a line that connects (@scheme[from-x],@scheme[from-y]) to (@scheme[to-x],@scheme[to-y]).
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,11 @@
|
|||
|
||||
@defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{
|
||||
|
||||
@defconstructor/auto-super[([edge-label-font (or/c #f (is-a?/c font%)) #f])]{
|
||||
@defconstructor/auto-super[([edge-labels? boolean? #t]
|
||||
[edge-label-font (or/c #f (is-a?/c font%)) #f])]{
|
||||
|
||||
If @scheme[edge-labels?] is @scheme[#f], no edge labels are
|
||||
drawn. Otherwise, they are.
|
||||
|
||||
If @scheme[edge-label-font] is supplied, it is used when drawing the
|
||||
labels on the edges. Otherwise, the font is not set before drawing
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user