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

slideshow/pict: add 'outline style for `text'

Browse Source
This commit is contained in:
Matthew Flatt 2013-05-12 06:52:51 -06:00
parent 9da1d9ca00
commit b08ff186e2
4 changed files with 66 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -216,6 +216,11 @@ The @racket[style] argument must be one of the following:
@item{@racket[(cons 'superscript style)]} @item{@racket[(cons 'superscript style)]}
@item{@racket[(cons 'caps style)]} @item{@racket[(cons 'caps style)]}
@item{@racket[(cons 'outline style)] --- draws an outline of the text
instead of solid glyphs; if a @racket[color%] object is
provided, it determines the outline color, while the current
color (or white if there is none) is used to fill the glyphs}
@item{@racket[(cons 'combine style)] --- allows kerning and ligatures @item{@racket[(cons 'combine style)] --- allows kerning and ligatures
(the default, unless the @racket['modern] family is specified)} (the default, unless the @racket['modern] family is specified)}

1
collects/texpict/mrpict.rkt
View File

@ -42,6 +42,7 @@
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 (or/c 'bold 'italic 'superscript 'subscript 'combine 'no-combine 'caps (cons/c (or/c 'bold 'italic 'superscript 'subscript 'combine 'no-combine 'caps
'outline 'aligned 'unaligned
(is-a?/c color%)) (is-a?/c color%))
text-style/c)))) text-style/c))))

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

@ -196,7 +196,7 @@
style)] style)]
[else font]))] [else font]))]
[(and (pair? style) [(and (pair? style)
(memq (car style) '(combine no-combine))) (memq (car style) '(combine no-combine outline)))
(loop (cdr style))] (loop (cdr style))]
[(and (pair? style) [(and (pair? style)
(is-a? (car style) color%)) (is-a? (car style) color%))
@ -213,12 +213,12 @@
[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]) [outline? (memq* 'outline orig-style)]
[color (let loop ([style orig-style])
(cond (cond
[(not (pair? style)) values] [(not (pair? style)) #f]
[(is-a? (car style) color%) [(is-a? (car style) color%)
(define c (car style)) (resolve-color (car style))]
(lambda (p) (colorize p c))]
[else (loop (cdr style))]))]) [else (loop (cdr style))]))])
(let ([s-font (if (or sub? sup?) (let ([s-font (if (or sub? sup?)
(extend-font font (extend-font font
@ -234,29 +234,47 @@
dc dc
(lambda () (lambda ()
(send dc get-text-extent string s-font combine?)))]) (send dc get-text-extent string s-font combine?)))])
(add-color (define (make-draw adj-x adj-y)
(define p
(and outline?
(let ([p (new dc-path%)])
(send p text-outline
font string 0 0 combine?)
p)))
(lambda (dc x y)
(let ([f (send dc get-font)])
(define dest-x (adj-x x))
(define dest-y (adj-y y))
(cond
[outline?
(define pn (and color (send dc get-pen)))
(when color (send dc set-pen color (send pn get-width) (send pn get-style)))
(send dc draw-path p dest-x dest-y)
(when color (send dc set-pen pn))]
[else
(define fg (and color (send dc get-text-foreground)))
(when color (send dc set-text-foreground color))
(send dc set-font s-font)
(send dc draw-text string
dest-x dest-y
combine?)
(when fg (send dc set-text-foreground fg))
(send dc set-font f)]))))
(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
(lambda () (lambda ()
(send dc get-text-extent "Wy" font)))]) (send dc get-text-extent "Wy" font)))])
(prog-picture (lambda (dc x y) (prog-picture (make-draw
(let ([f (send dc get-font)]) (lambda (x) x)
(send dc set-font s-font) (lambda (y) (if sub?
(send dc draw-text string
x (if sub?
(+ y (- wh h)) (+ y (- wh h))
y) y)))
combine?)
(send dc set-font f)))
w wh (- wh wd) wd)) w wh (- wh wd) wd))
(if (zero? angle) (if (zero? angle)
;; Normal case: no rotation ;; Normal case: no rotation
(prog-picture (lambda (dc x y) (prog-picture (make-draw (lambda (x) x)
(let ([f (send dc get-font)]) (lambda (y) y))
(send dc set-font font)
(send dc draw-text string x y combine?)
(send dc set-font f)))
w h (- h d) d) w h (- h d) d)
;; Rotation case. Need to find the bounding box. ;; Rotation case. Need to find the bounding box.
;; Calculate the four corners, relative to top left as origin: ;; Calculate the four corners, relative to top left as origin:
@ -286,13 +304,9 @@
[(positive? ca) (* w sa)] [(positive? ca) (* w sa)]
[(negative? sa) (- (* h ca))] [(negative? sa) (- (* h ca))]
[else (+ (- (* h ca)) (* w sa))])]) [else (+ (- (* h ca)) (* w sa))])])
(prog-picture (lambda (dc x y) (prog-picture (make-draw (lambda (x) (+ x dx))
(let ([f (send dc get-font)]) (lambda (y) (+ y dy)))
(send dc set-font font) pw ph ph 0)))))))))
(send dc draw-text string (+ x dx) (+ y dy)
combine? 0 angle)
(send dc set-font f)))
pw ph ph 0))))))))))
(define caps-text (define caps-text
(case-lambda (case-lambda
@ -373,6 +387,20 @@
[(exact close-enough x1 y1 x2 y2 arrow?) [(exact close-enough x1 y1 x2 y2 arrow?)
`((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,(- x2 x1) ,(- y2 y1) #f)))])) `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,(- x2 x1) ,(- y2 y1) #f)))]))
(define (resolve-color c)
(let* ([requested-color (cond
[(is-a? c color%) c]
[(string? c)
(send the-color-database find-color c)]
[(list? c)
(apply make-object color% c)])]
[color (or requested-color
(send the-color-database find-color "BLACK"))])
(unless requested-color
(eprintf "WARNING: couldn't find color: ~s\n" c))
color))
(define (render dc h+top l dx dy) (define (render dc h+top l dx dy)
(define b&w? #f) (define b&w? #f)
@ -458,16 +486,7 @@
(let ([p (get-pen)] (let ([p (get-pen)]
[b (get-brush)] [b (get-brush)]
[fg (get-text-foreground)]) [fg (get-text-foreground)])
(let* ([requested-color (cond (let ([color (resolve-color (cadr x))])
[(is-a? (cadr x) color%) (cadr x)]
[(string? (cadr x))
(send the-color-database find-color (cadr x))]
[(list? (cadr x))
(apply make-object color% (cadr x))])]
[color (or requested-color
(send the-color-database find-color "BLACK"))])
(unless requested-color
(eprintf "WARNING: couldn't find color: ~s\n" (cadr x)))
(set-pen (find-or-create-pen color (send p get-width) (send p get-style))) (set-pen (find-or-create-pen color (send p get-width) (send p get-style)))
(set-brush (find-or-create-brush color 'solid)) (set-brush (find-or-create-brush color 'solid))
(set-text-foreground color)) (set-text-foreground color))

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

@ -1,6 +1,7 @@
Version 5.3.4.10 Version 5.3.4.10
Move explode-path from racket/path to racket/base Move explode-path from racket/path to racket/base
Changed read-on-demand-source to support #t Changed read-on-demand-source to support #t
slideshow/pict: added 'outline style for text
Version 5.3.4.9 Version 5.3.4.9
racket/place: allow keywords as place messages racket/place: allow keywords as place messages