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] [#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a/c? color%)) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f]
[#:under? under? any/c #f] [#:under? under? any/c #f]
[#:solid? solid? any/c #t]) [#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
pict?] pict?]
[(pin-arrows-line [arrow-size real?] [pict pict?] [(pin-arrows-line [arrow-size real?] [pict pict?]
[src pict-path?] [src pict-path?]
@ -319,7 +320,8 @@ argument for consistency with the other functions.}
[#:line-width line-width (or/c #f real?) #f] [#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a/c? color%)) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f]
[#:under? under? any/c #f] [#:under? under? any/c #f]
[#:solid? solid? any/c #t]) [#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
pict?])]{ pict?])]{
Adds a line or line-with-arrows onto @scheme[pict], using one of the 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.} The defaults produce a straight line.}
@defthing[text-style/c contract?]{ @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 (pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep sz col lw under? #t))) sa ea sp ep sz col lw under? #t)))
(define (pin-arrow-line sz p (define (pin-arrow-line sz p
src src-find src src-find
dest dest-find dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f] #:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f] #:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f] #:color [col #f]
#:line-width [lw #f] #:line-width [lw #f]
#:under? [under? #f] #:under? [under? #f]
#:solid? [solid? #t]) #:solid? [solid? #t]
(if (not (or sa ea)) #:hide-arrowhead? [hide-arrowhead? #f])
(finish-pin (launder (t:pin-arrow-line sz (ghost p) (if (not (or sa ea))
src src-find (finish-pin (launder (t:pin-arrow-line sz (ghost p)
dest dest-find src src-find
#f #f #f solid?)) dest dest-find
p lw col under?) #f #f #f solid?
(pin-curve* #f #t p src src-find dest dest-find #:hide-arrowhead? hide-arrowhead?))
sa ea sp ep sz col lw under? solid?))) 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 (define (pin-arrows-line sz p
src src-find src src-find
dest dest-find dest dest-find
@ -85,14 +87,17 @@
#:color [col #f] #:color [col #f]
#:line-width [lw #f] #:line-width [lw #f]
#:under? [under? #f] #:under? [under? #f]
#:solid? [solid? #t]) #:solid? [solid? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not sa ea) (if (not sa ea)
(finish-pin (launder (t:pin-arrows-line sz (ghost p) (finish-pin (launder (t:pin-arrows-line sz (ghost p)
src src-find src src-find
dest dest-find dest dest-find
#f #f #f solid?)) #f #f #f solid?
#:hide-arrowhead? hide-arrowhead?))
p lw col under?) 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?))) sa ea sp ep sz col lw under? solid?)))
(define (pin-curve* start-arrow? end-arrow? p (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 number?)
(or/c false/c string?) (or/c false/c string?)
boolean? boolean?
boolean?) boolean?
#:hide-arrowhead? any/c)
pict?)] pict?)]
[pin-arrows-line (->* (number? pict? [pin-arrows-line (->* (number? pict?
pict? (-> pict? pict? (values number? number?)) pict? (-> pict? pict? (values number? number?))
@ -80,7 +81,8 @@
((or/c false/c number?) ((or/c false/c number?)
(or/c false/c string?) (or/c false/c string?)
boolean? boolean?
boolean?) boolean?
#:hide-arrowhead? any/c)
pict?)]) pict?)])
@ -774,7 +776,8 @@
(send dc set-brush old-brush))) (send dc set-brush old-brush)))
w h))) 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)] (let-values ([(sx sy) (find-src base src)]
[(dx dy) (find-dest base dest)]) [(dx dy) (find-dest base dest)])
(let ([arrows (let ([arrows
@ -790,7 +793,8 @@
[dsx (* (or arrow2-size 0) 0.5 (- cosa))] [dsx (* (or arrow2-size 0) 0.5 (- cosa))]
[dsy (* (or arrow2-size 0) 0.5 (- sina))]) [dsy (* (or arrow2-size 0) 0.5 (- sina))])
`(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy))) `(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy)))
,@(if arrow-size ,@(if (and arrow-size
(not hide-arrowhead?))
(let-values ([(arrow xo yo) (let-values ([(arrow xo yo)
(arrowhead/delta (arrowhead/delta
(or thickness 0) (or thickness 0)
@ -800,7 +804,8 @@
solid-head?)]) solid-head?)])
`((place ,(+ dx xo) ,(+ dy yo) ,arrow))) `((place ,(+ dx xo) ,(+ dy yo) ,arrow)))
null) null)
,@(if arrow2-size ,@(if (and arrow2-size
(not hide-arrowhead?))
(let-values ([(arrow xo yo) (let-values ([(arrow xo yo)
(arrowhead/delta (arrowhead/delta
(or thickness 0) (or thickness 0)
@ -827,12 +832,16 @@
(-add-line base src find-src dest find-dest thickness color #f #f under? #t))) (-add-line base src find-src dest find-dest thickness color #f #f under? #t)))
(define add-arrow-line (define add-arrow-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (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))) #: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 (define add-arrows-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (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))) #: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-) (define (flip-find-y find-)
(lambda (base path) (lambda (base path)
@ -842,17 +851,21 @@
(define pin-line (define pin-line
(lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (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) (-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 (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) (-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 (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) (-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)) (define black-color (make-object color% 0 0 0))