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

added caps style to 'text'

Browse Source 
svn: r6680
This commit is contained in:
Robby Findler 2007-06-17 02:41:54 +00:00
parent dcea96041d
commit 05ea93da4c
3 changed files with 33 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/texpict/doc.txt
View File

@ -208,6 +208,7 @@ Basic Constructors:
`(superscript . ,text-style),
`(combine . ,text-style), or
`(no-combine . ,text-style).
`(caps . ,text-style).
A size is an exact number in [1, 255] in pixels; the
default size is 12, but the size is ignored if
a font% object is provided in the text-style.
@ -221,6 +222,7 @@ Basic Constructors:
'no-combine text-style symbol overrides the default to
disable combining; if both 'combine and 'no-combine
are specified, the first one takes precedence
If caps is specified, the angle must be zero.
[MrEd only]
> text-style/c :: contract?

2
collects/texpict/mrpict.ss
View File

@ -36,7 +36,7 @@
(is-a?/c font%)
(symbols 'base 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system)
string? ;; could be more specific, I guess.
(cons/c (symbols 'bold 'italic 'superscript 'subscript 'combine 'no-combine)
(cons/c (symbols 'bold 'italic 'superscript 'subscript 'combine 'no-combine 'caps)
text-style/c))))
(provide/contract

40
collects/texpict/private/mrpict-extra.ss
View File

@ -110,12 +110,31 @@
'default
#t)))
(define text
(case-lambda
[(string) (text string '() 12)]
[(string style) (text string style 12)]
[(string style size) (text string style size 0)]
[(string orig-style size angle)
(define text
(case-lambda
[(string) (text string '() 12)]
[(string style) (text string style 12)]
[(string style size) (text string style size 0)]
[(str style size angle)
(if (il-memq 'caps style)
(begin
(unless (zero? angle)
(error 'text "the style cannot include 'caps with a non-zero angle"))
(caps-text str (il-remq 'caps style) size))
(not-caps-text str style size angle))]))
(define (il-memq sym s)
(and (pair? s)
(or (eq? sym (car s))
(il-memq sym (cdr s)))))
(define (il-remq sym s)
(if (pair? s)
(if (eq? sym (car s))
(cdr s)
(cons (car s) (il-remq sym (cdr s))))
s))
(define (not-caps-text string orig-style size angle)
(let ([font
(let loop ([style orig-style])
(cond
@ -237,7 +256,7 @@
(send dc draw-text string (+ x dx) (+ y dy)
combine? 0 angle)
(send dc set-font f)))
pw ph ph 0))))))))]))
pw ph ph 0)))))))))
(define caps-text
(case-lambda
@ -269,9 +288,10 @@
(let loop ([l strings][up? #f])
(if (null? l)
null
(cons (text (list->string (map char-upcase (car l)))
(if up? style cap-style)
(if up? size cap-size))
(cons (not-caps-text (list->string (map char-upcase (car l)))
(if up? style cap-style)
(if up? size cap-size)
0)
(loop (cdr l) (not up?)))))])
(apply hbl-append 0 picts)))]))