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

added #:hide-arrowhead? flag

Browse Source 
svn: r13881
This commit is contained in:
Robby Findler 2009-02-28 15:44:41 +00:00
parent 95cc90e0e4
commit d5ee6c6813
3 changed files with 62 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/scribblings/slideshow/picts.scrbl
View File

@ -305,7 +305,8 @@ argument for consistency with the other functions.}
[#: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])
[#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
pict?]
[(pin-arrows-line [arrow-size real?] [pict pict?]
[src pict-path?]
@ -319,7 +320,8 @@ argument for consistency with the other functions.}
[#: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])
[#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
pict?])]{
Adds a line or line-with-arrows onto @scheme[pict], using one of the
@ -347,6 +349,10 @@ The @scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and
]
When the @scheme[hide-arrowhead?] argument is a true value, then
space for the arrowhead is left behind, but the arrowhead itself
is not drawn.
The defaults produce a straight line.}
@defthing[text-style/c contract?]{

47
collects/slideshow/pict.ss
View File

@ -59,24 +59,26 @@
(pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep sz col lw under? #t)))
(define (pin-arrow-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?))
p lw col under?)
(pin-curve* #f #t p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?)))
(define (pin-arrow-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?))
p lw col under?)
(pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?)))
(define (pin-arrows-line sz p
src src-find
dest dest-find
@ -85,14 +87,17 @@
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t])
#:solid? [solid? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not sa ea)
(finish-pin (launder (t:pin-arrows-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?))
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?))
p lw col under?)
(pin-curve* #t #t p src src-find dest dest-find
(pin-curve* (not hide-arrowhead?) (not hide-arrowhead?)
p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?)))
(define (pin-curve* start-arrow? end-arrow? p

43
collects/texpict/utils.ss
View File

@ -72,7 +72,8 @@
((or/c false/c number?)
(or/c false/c string?)
boolean?
boolean?)
boolean?
#:hide-arrowhead? any/c)
pict?)]
[pin-arrows-line (->* (number? pict?
pict? (-> pict? pict? (values number? number?))
@ -80,7 +81,8 @@
((or/c false/c number?)
(or/c false/c string?)
boolean?
boolean?)
boolean?
#:hide-arrowhead? any/c)
pict?)])
@ -774,7 +776,8 @@
(send dc set-brush old-brush)))
w h)))
(define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?)
(define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?
#:hide-arrowhead? [hide-arrowhead? #f])
(let-values ([(sx sy) (find-src base src)]
[(dx dy) (find-dest base dest)])
(let ([arrows
@ -790,7 +793,8 @@
[dsx (* (or arrow2-size 0) 0.5 (- cosa))]
[dsy (* (or arrow2-size 0) 0.5 (- sina))])
`(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy)))
,@(if arrow-size
,@(if (and arrow-size
(not hide-arrowhead?))
(let-values ([(arrow xo yo)
(arrowhead/delta
(or thickness 0)
@ -800,7 +804,8 @@
solid-head?)])
`((place ,(+ dx xo) ,(+ dy yo) ,arrow)))
null)
,@(if arrow2-size
,@(if (and arrow2-size
(not hide-arrowhead?))
(let-values ([(arrow xo yo)
(arrowhead/delta
(or thickness 0)
@ -827,12 +832,16 @@
(-add-line base src find-src dest find-dest thickness color #f #f under? #t)))
(define add-arrow-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t)))
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t
#:hide-arrowhead? hide-arrowhead?)))
(define add-arrows-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t)))
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t
#:hide-arrowhead? hide-arrowhead?)))
(define (flip-find-y find-)
(lambda (base path)
@ -842,17 +851,21 @@
(define pin-line
(lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color #f #f under? #t)))
thickness color #f #f under? #t)))
(define pin-arrow-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t])
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size #f under? solid-head?)))
thickness color arrow-size #f under? solid-head?
#:hide-arrowhead? hide-arrowhead?)))
(define pin-arrows-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t])
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size arrow-size under? solid-head?)))
thickness color arrow-size arrow-size under? solid-head?
#:hide-arrowhead? hide-arrowhead?)))
(define black-color (make-object color% 0 0 0))