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

slideshow/pict: for `text' in caps mode, kern captials with following

Browse Source
This commit is contained in:
Matthew Flatt 2012-05-17 16:21:27 -06:00
parent e0256bc9c7
commit d430656a03
1 changed files with 29 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -281,7 +281,7 @@
[(string style) (caps-text string style 12)]
[(string style size)
(let ([strings
(let loop ([l (string->list string)][this null][results null][up? #f])
(let loop ([l (string->list string)] [this null] [results null] [up? #f])
(if (null? l)
(reverse (cons (reverse this) results))
(if (eq? up? (char-upper-case? (car l)))
@ -302,14 +302,36 @@
[else s]))]
[cap-size (floor (* 8/10 size))])
(let ([picts
(let loop ([l strings][up? #f])
(let loop ([l strings] [up? #f])
(if (null? l)
null
(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?)))))])
(let* ([first-string (list->string (map char-upcase (car l)))]
[first
(not-caps-text first-string
(if up? style cap-style)
(if up? size cap-size)
0)]
[rest (loop (cdr l) (not up?))])
(if (and up? (pair? (cdr l)))
;; kern capital followed by non-captial
(let ([plain-first (not-caps-text first-string
cap-style
cap-size
0)]
[together (not-caps-text (string-append
first-string
(list->string (map char-upcase (cadr l))))
cap-style
cap-size
0)])
(cons (hbl-append (- (pict-width together)
(+ (pict-width plain-first)
(pict-width (car rest))))
first
(car rest))
(cdr rest)))
;; no kerning needed:
(cons first rest)))))])
(apply hbl-append 0 picts)))]))
(define (linewidth n p) (line-thickness n p))