add pin-curve, pin-arrow-curve, pin-arrows-curve
svn: r13818
This commit is contained in:
Matthew Flatt
parent
03f3d208ca
commit
b6f3bab025
|
|
@ -12,8 +12,6 @@
|
|||
|
||||
@guideintro["regexp"]{regular expressions}
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@deftech{Regular expressions} are specified as strings or byte
|
||||
strings, using the same pattern language as the Unix utility
|
||||
@exec{egrep} or Perl. A string-specified pattern produces a character
|
||||
|
|
|
|||
|
|
@ -319,6 +319,66 @@ the existing @scheme[pict] drawing, instead of on top. If
|
|||
@scheme[solid?] is false, then the arrowheads are hollow instead of
|
||||
filled.}
|
||||
|
||||
@defproc*[([(pin-curve [pict pict?]
|
||||
[src pict-path?]
|
||||
[find-src (pict? pict-path? . -> . (values real? real?))]
|
||||
[dest pict-path?]
|
||||
[find-dest (pict? pict-path? . -> . (values real? real?))]
|
||||
[#:start-angle start-angle (or/c real? #f) #f]
|
||||
[#:end-angle end-angle (or/c real? #f) #f]
|
||||
[#:start-pull start-pull (or/c real? #f) #f]
|
||||
[#:end-pull end-pull (or/c real? #f) #f]
|
||||
[#:arrow-size arrow-size real? 12]
|
||||
[#:line-width line-width (or/c #f real?) #f]
|
||||
[#:color color (or/c #f string? (is-a/c? color%)) #f]
|
||||
[#:under? under? any/c #f])
|
||||
pict?]
|
||||
[(pin-arrow-curve [pict pict?]
|
||||
[src pict-path?]
|
||||
[find-src (pict? pict-path? . -> . (values real? real?))]
|
||||
[dest pict-path?]
|
||||
[find-dest (pict? pict-path? . -> . (values real? real?))]
|
||||
[#:start-angle start-angle (or/c real? #f) #f]
|
||||
[#:end-angle end-angle (or/c real? #f) #f]
|
||||
[#:start-pull start-pull (or/c real? #f) #f]
|
||||
[#:end-pull end-pull (or/c real? #f) #f]
|
||||
[#:arrow-size arrow-size real? 12]
|
||||
[#:line-width line-width (or/c #f real?) #f]
|
||||
[#:color color (or/c #f string? (is-a/c? color%)) #f]
|
||||
[#:under? under? any/c #f]
|
||||
[#:solid? solid? any/c #t])
|
||||
pict?]
|
||||
[(pin-arrows-curve [pict pict?]
|
||||
[src pict-path?]
|
||||
[find-src (pict? pict-path? . -> . (values real? real?))]
|
||||
[dest pict-path?]
|
||||
[find-dest (pict? pict-path? . -> . (values real? real?))]
|
||||
[#:start-angle start-angle (or/c real? #f) #f]
|
||||
[#:end-angle end-angle (or/c real? #f) #f]
|
||||
[#:start-pull start-pull (or/c real? #f) #f]
|
||||
[#:end-pull end-pull (or/c real? #f) #f]
|
||||
[#:arrow-size arrow-size real? 12]
|
||||
[#:line-width line-width (or/c #f real?) #f]
|
||||
[#:color color (or/c #f string? (is-a/c? color%)) #f]
|
||||
[#:under? under? any/c #f]
|
||||
[#:solid? solid? any/c #t])
|
||||
pict?])]{
|
||||
|
||||
Like @scheme[pin-arrow-line], etc., but draws a Bezier curve based on
|
||||
@scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and
|
||||
@scheme[end-pull].
|
||||
|
||||
The @scheme[start-angle] and @scheme[end-angle] arguments specify the
|
||||
direction of curve at its start and end positions; if either is
|
||||
@scheme[#f], it defaults to the angle of a straight line from the
|
||||
start position to end position.
|
||||
|
||||
The @scheme[start-pull] and @scheme[end-pull] arguments specify a kind
|
||||
of momentum for the starting and ending angles; larger values preserve
|
||||
the angle longer. If @scheme[start-pull] or @scheme[end-pull] is
|
||||
@scheme[#f], then it is replaced with one-fourth of the distance
|
||||
between the start and end points.}
|
||||
|
||||
@defthing[text-style/c contract?]{
|
||||
|
||||
A contract that matches the second argument of @scheme[text].}
|
||||
|
|
|
|||
|
|
@ -6,7 +6,9 @@
|
|||
(rename-in texpict/utils
|
||||
[pin-line t:pin-line]
|
||||
[pin-arrow-line t:pin-arrow-line]
|
||||
[pin-arrows-line t:pin-arrows-line]))
|
||||
[pin-arrows-line t:pin-arrows-line])
|
||||
(only-in scheme/gui/base dc-path%)
|
||||
(only-in scheme/class new send))
|
||||
|
||||
(define (hline w h #:segment [seg #f])
|
||||
(if seg
|
||||
|
|
@ -71,6 +73,110 @@
|
|||
#f #f #f solid?))
|
||||
p lw col under?))
|
||||
|
||||
(define (pin-curve p
|
||||
src src-find
|
||||
dest dest-find
|
||||
#:start-angle [sa #f] #:end-angle [ea #f]
|
||||
#:start-pull [sp #f] #:end-pull [ep #f]
|
||||
#:arrow-size [sz 12]
|
||||
#:color [col #f]
|
||||
#:line-width [lw #f]
|
||||
#:under? [under? #f]
|
||||
#:solid? [solid? #t])
|
||||
(pin-curve* #f #f p src src-find dest dest-find
|
||||
sa ea sp ep sz col lw under? #t))
|
||||
|
||||
(define (pin-arrow-curve p
|
||||
src src-find
|
||||
dest dest-find
|
||||
#:start-angle [sa #f] #:end-angle [ea #f]
|
||||
#:start-pull [sp #f] #:end-pull [ep #f]
|
||||
#:arrow-size [sz 12]
|
||||
#:color [col #f]
|
||||
#:line-width [lw #f]
|
||||
#:under? [under? #f]
|
||||
#:solid? [solid? #t])
|
||||
(pin-curve* #f #t p src src-find dest dest-find
|
||||
sa ea sp ep sz col lw under? solid?))
|
||||
|
||||
(define (pin-arrows-curve p
|
||||
src src-find
|
||||
dest dest-find
|
||||
#:start-angle [sa #f] #:end-angle [ea #f]
|
||||
#:start-pull [sp #f] #:end-pull [ep #f]
|
||||
#:arrow-size [sz 12]
|
||||
#:color [col #f]
|
||||
#:line-width [lw #f]
|
||||
#:under? [under? #f]
|
||||
#:solid? [solid? #t])
|
||||
(pin-curve* #t #t p src src-find dest dest-find
|
||||
sa ea sp ep sz col lw under? solid?))
|
||||
|
||||
(define (pin-curve* start-arrow? end-arrow? p
|
||||
src src-find
|
||||
dest dest-find
|
||||
sa ea sp ep
|
||||
sz col lw
|
||||
under? solid?)
|
||||
(let-values ([(sx0 sy0) (src-find p src)]
|
||||
[(dx0 dy0) (dest-find p dest)])
|
||||
(let* ([sa (or sa
|
||||
(atan (- sy0 dy0) (- dx0 sx0)))]
|
||||
[ea (or ea
|
||||
(atan (- sy0 dy0) (- dx0 sx0)))]
|
||||
[d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))]
|
||||
[sp (or sp (* 1/4 d))]
|
||||
[ep (or ep (* 1/4 d))])
|
||||
(let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)]
|
||||
[dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)]
|
||||
[sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)]
|
||||
[sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)]
|
||||
[path (new dc-path%)]
|
||||
[maybe-pin-line
|
||||
(lambda (arrow? p sx sy dx dy)
|
||||
(if arrow?
|
||||
(pin-arrow-line
|
||||
sz
|
||||
p
|
||||
p (lambda (a b) (values sx sy))
|
||||
p (lambda (a b) (values dx dy))
|
||||
#:line-width lw
|
||||
#:color col
|
||||
#:under? under?
|
||||
#:solid? solid?)
|
||||
p))])
|
||||
(send path move-to sx sy)
|
||||
(send path curve-to
|
||||
(+ sx (* sp (cos sa)))
|
||||
(- sy (* sp (sin sa)))
|
||||
(- dx (* ep (cos ea)))
|
||||
(+ dy (* ep (sin ea)))
|
||||
dx
|
||||
dy)
|
||||
(maybe-pin-line
|
||||
start-arrow?
|
||||
(maybe-pin-line
|
||||
end-arrow?
|
||||
((if under? pin-under pin-over)
|
||||
p
|
||||
0 0
|
||||
(let* ([p (dc (lambda (dc x y)
|
||||
(let ([b (send dc get-brush)])
|
||||
(send dc set-brush "white" 'transparent)
|
||||
(send dc draw-path path x y)
|
||||
(send dc set-brush b)))
|
||||
0 0)]
|
||||
[p (if col
|
||||
(colorize p col)
|
||||
p)]
|
||||
[p (if lw
|
||||
(linewidth lw p)
|
||||
p)])
|
||||
p))
|
||||
dx dy dx0 dy0)
|
||||
sx sy sx0 sy0)))))
|
||||
|
||||
|
||||
(define (finish-pin l p lw col under?)
|
||||
(let* ([l (if lw
|
||||
(linewidth lw l)
|
||||
|
|
@ -96,6 +202,7 @@
|
|||
frame
|
||||
pict-path?
|
||||
pin-line pin-arrow-line pin-arrows-line
|
||||
pin-curve pin-arrow-curve pin-arrows-curve
|
||||
(except-out (all-from-out texpict/mrpict)
|
||||
|
||||
dash-hline dash-vline
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user