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

slideshow/pict: add linestyle' and #:style' argument to `pin-line'

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-23 14:02:20 -06:00
parent f082919f0b
commit fa82d70cc6
8 changed files with 97 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -294,6 +294,10 @@ argument for consistency with the other functions.}
[#:end-pull end-pull real? 1/4]
[#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a?/c color%)) #f]
[#:style style (one-of/c 'transparent 'solid 'xor 'hilite
'dot 'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)]
[#:under? under? any/c #f])
pict?]
[(pin-arrow-line [arrow-size real?] [pict pict?]
@ -307,6 +311,10 @@ argument for consistency with the other functions.}
[#:end-pull end-pull real? 1/4]
[#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a?/c color%)) #f]
[#:style style (one-of/c 'transparent 'solid 'xor 'hilite
'dot 'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)]
[#:under? under? any/c #f]
[#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
@ -322,6 +330,10 @@ argument for consistency with the other functions.}
[#:end-pull end-pull real? 1/4]
[#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a?/c color%)) #f]
[#:style style (one-of/c 'transparent 'solid 'xor 'hilite
'dot 'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)]
[#:under? under? any/c #f]
[#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
@ -337,7 +349,8 @@ the existing @racket[pict] drawing, instead of on top. If
filled.
The @racket[start-angle], @racket[end-angle], @racket[start-pull], and
@racket[end-pull] arguments control the curve of the line:
@racket[end-pull] arguments control the curve of the line (and the
defaults produce a straight line):
@itemize[
@ -352,11 +365,13 @@ The @racket[start-angle], @racket[end-angle], @racket[start-pull], and
]
When the @racket[hide-arrowhead?] argument is a true value, then
space for the arrowhead is left behind, but the arrowhead itself
is not drawn.
The @racket[line-width], @racket[color], and @racket[style] arguments
apply to the added line.
When the @racket[hide-arrowhead?] argument is a true value, then space
for an arrowhead is kept around the line, but the arrowhead itself is
not drawn.}
The defaults produce a straight line.}
@defthing[text-style/c contract?]{
@ -520,6 +535,18 @@ for @racket[pict] that does not already use a specific pen width.
A @racket[#f] value for @racket[w] makes the pen transparent (in contrast
to a zero value, which means ``as thin as possible for the target device'').}
@defproc[(linestyle [style (one-of/c 'transparent 'solid 'xor 'hilite
'dot 'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)]
[pict pict?])
pict?]{
Selects a specific pen style for drawing, which applies to pen drawing
for @racket[pict] that does not already use a specific pen style.}
@defproc[(colorize [pict pict?] [color (or/c string?
(is-a?/c color%)
(list (integer-in 0 255)

32
collects/slideshow/pict.rkt
View File

@ -50,14 +50,17 @@
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t])
#:solid? [solid? #t]
#:style [style #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-line (ghost p)
src src-find
dest dest-find))
dest dest-find
#:style style))
p lw col under?)
(pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep 0 col lw under? #t)))
sa ea sp ep 0 col lw under? #t
style)))
(define (pin-arrow-line sz p
src src-find
@ -68,16 +71,19 @@
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f]
#: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?))
#:hide-arrowhead? hide-arrowhead?
#:style style))
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?)))
sa ea sp ep sz col lw under? solid?
style)))
(define (pin-arrows-line sz p
src src-find
@ -88,24 +94,28 @@
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrows-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?))
#:hide-arrowhead? hide-arrowhead?
#:style style))
p lw col under?)
(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?
style)))
(define (pin-curve* start-arrow? end-arrow? p
src src-find
dest dest-find
sa ea sp ep
sz col lw
under? solid?)
under? solid?
style)
(let-values ([(sx0 sy0) (src-find p src)]
[(dx0 dy0) (dest-find p dest)])
(let* ([sa (or sa
@ -131,7 +141,8 @@
#:line-width lw
#:color col
#:under? under?
#:solid? solid?)
#:solid? solid?
#:style style)
p))])
(send path move-to sx sy)
(send path curve-to
@ -159,6 +170,9 @@
p)]
[p (if lw
(linewidth lw p)
p)]
[p (if style
(linestyle style p)
p)])
p))
dx dy dx0 dy0)

1
collects/texpict/mrpict.rkt
View File

@ -26,6 +26,7 @@
caps-text current-expected-text-scale
dc
linewidth
linestyle
draw-pict
make-pict-drawer)

3
collects/texpict/private/common-sig.rkt
View File

@ -130,4 +130,5 @@
(define-signature texpict-internal^
(prepare-for-output
pict->command-list
line-thickness)))
line-thickness
line-style)))

1
collects/texpict/private/common-unit.rkt
View File

@ -317,6 +317,7 @@
(define (thick b) (thickness 'thicklines b))
(define (thin b) (thickness 'thinlines b))
(define (line-thickness n b) (thickness n b))
(define (line-style n s) (thickness n s))
(define inset
(case-lambda

23
collects/texpict/private/mrpict-extra.rkt
View File

@ -301,6 +301,13 @@
(apply hbl-append 0 picts)))]))
(define (linewidth n p) (line-thickness n p))
(define (linestyle n p)
(unless (memq n '(transparent solid xor hilite
dot long-dash short-dash dot-dash
xor-dot xor-long-dash xor-short-dash
xor-dot-dash))
(raise-type-error 'linestyle "style symbol" n))
(line-style n p))
(define connect
(case-lambda
@ -421,12 +428,16 @@
(set-pen (find-or-create-pen (send p get-color)
(if (number? (cadr x))
(cadr x)
(if (eq? (cadr x) 'thicklines)
1
0))
(if (eq? (cadr x) #f)
'transparent
'solid)))
(case (cadr x)
[(thicklines) 1]
[(thinlines) 0]
[else (send p get-width)]))
(if (number? (cadr x))
(send p get-style)
(case (cadr x)
[(#f) 'transparent]
[(thicklines thinlines) (send p get-style)]
[else (cadr x)]))))
(loop dx dy (caddr x))
(set-pen p))]
[(prog)

1
collects/texpict/private/mrpict-sig.rkt
View File

@ -9,6 +9,7 @@
text caps-text current-expected-text-scale
dc
linewidth
linestyle
draw-pict
make-pict-drawer)))

28
collects/texpict/utils.rkt
View File

@ -76,7 +76,8 @@
pict-path? (-> pict? pict-path? (values number? number?)))
((or/c false/c number?)
(or/c false/c string?)
boolean?)
boolean?
#:style (or/c false/c symbol?))
pict?)]
[pin-arrow-line (->* (number?
pict?
@ -86,6 +87,7 @@
(or/c false/c string?)
boolean?
boolean?
#:style (or/c false/c symbol?)
#:hide-arrowhead? any/c)
pict?)]
[pin-arrows-line (->* (number? pict?
@ -95,6 +97,7 @@
(or/c false/c string?)
boolean?
boolean?
#:style (or/c false/c symbol?)
#:hide-arrowhead? any/c)
pict?)])
@ -794,6 +797,7 @@
w h)))
(define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?
#:style [style #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(let-values ([(sx sy) (find-src base src)]
[(dx dy) (find-dest base dest)])
@ -832,9 +836,12 @@
solid-head?)])
`((place ,(+ sx xo) ,(+ sy yo) ,arrow)))
null)))])
(let ([p2 (if thickness
(linewidth thickness p)
p)])
(let* ([p2 (if thickness
(linewidth thickness p)
p)]
[p2 (if style
(linestyle style p2)
p2)])
(if color
(colorize p2 color)
p2)))])
@ -866,22 +873,27 @@
(values x (- (pict-height base) y)))))
(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] #:style [style #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
#:style style)))
(define pin-arrow-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
#:hide-arrowhead? [hide-arrowhead? #f]
#:style [style #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size #f under? solid-head?
#:style style
#: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]
#:hide-arrowhead? [hide-arrowhead? #f])
#:hide-arrowhead? [hide-arrowhead? #f]
#:style [style #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?
#:style style
#:hide-arrowhead? hide-arrowhead?)))
(define black-color (make-object color% 0 0 0))