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

slideshow/pict: allow a color in a style for `text'

Browse Source
This commit is contained in:
Matthew Flatt 2013-03-27 14:37:48 -06:00
parent a499b22a3c
commit 325a9dd34b
4 changed files with 78 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -227,6 +227,9 @@ The @racket[style] argument must be one of the following:
@item{@racket[(cons 'unaligned style)] --- disables hinting (which is @item{@racket[(cons 'unaligned style)] --- disables hinting (which is
the default), so that metrics are scalable} the default), so that metrics are scalable}
@item{@racket[(cons _color style)] --- where @racket[_color] is a @racket[color%] object,
@racket[colorize]s the text}
] ]
If both @racket['combine] and @racket['no-combine] are specified, the If both @racket['combine] and @racket['no-combine] are specified, the

3
collects/texpict/mrpict.rkt
View File

@ -41,7 +41,8 @@
family/c family/c
string? ;; could be more specific, I guess. string? ;; could be more specific, I guess.
(cons/c string? family/c) (cons/c string? family/c)
(cons/c (symbols 'bold 'italic 'superscript 'subscript 'combine 'no-combine 'caps) (cons/c (or/c 'bold 'italic 'superscript 'subscript 'combine 'no-combine 'caps
(is-a?/c color%))
text-style/c)))) text-style/c))))
(provide/contract (provide/contract

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

@ -198,6 +198,9 @@
[(and (pair? style) [(and (pair? style)
(memq (car style) '(combine no-combine))) (memq (car style) '(combine no-combine)))
(loop (cdr style))] (loop (cdr style))]
[(and (pair? style)
(is-a? (car style) color%))
(loop (cdr style))]
[else (raise-type-error 'text [else (raise-type-error 'text
"style" "style"
orig-style)]))] orig-style)]))]
@ -209,7 +212,14 @@
[(eq? (car style) 'no-combine) #f] [(eq? (car style) 'no-combine) #f]
[else (loop (cdr style))]))] [else (loop (cdr style))]))]
[sub? (memq* 'subscript orig-style)] [sub? (memq* 'subscript orig-style)]
[sup? (memq* 'superscript orig-style)]) [sup? (memq* 'superscript orig-style)]
[add-color (let loop ([style orig-style])
(cond
[(not (pair? style)) values]
[(is-a? (car style) color%)
(define c (car style))
(lambda (p) (colorize p c))]
[else (loop (cdr style))]))])
(let ([s-font (if (or sub? sup?) (let ([s-font (if (or sub? sup?)
(extend-font font (extend-font font
(floor (* 6/10 (send font get-point-size))) (floor (* 6/10 (send font get-point-size)))
@ -224,6 +234,7 @@
dc dc
(lambda () (lambda ()
(send dc get-text-extent string s-font combine?)))]) (send dc get-text-extent string s-font combine?)))])
(add-color
(if (or sub? sup?) (if (or sub? sup?)
(let-values ([(ww wh wd ws) (with-text-scale (let-values ([(ww wh wd ws) (with-text-scale
dc dc
@ -281,7 +292,7 @@
(send dc draw-text string (+ x dx) (+ y dy) (send dc draw-text string (+ x dx) (+ y dy)
combine? 0 angle) combine? 0 angle)
(send dc set-font f))) (send dc set-font f)))
pw ph ph 0))))))))) pw ph ph 0))))))))))
(define caps-text (define caps-text
(case-lambda (case-lambda

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 5.3.3.8
slideshow/pict: added color% objects to text-style/c
Version 5.3.3.7 Version 5.3.3.7
Added module-compiled-cross-phase-persistent? Added module-compiled-cross-phase-persistent?
Added 'so-mode mode for system-type Added 'so-mode mode for system-type