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

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

@ -305,11 +305,33 @@
(let loop ([l strings] [up? #f]) (let loop ([l strings] [up? #f])
(if (null? l) (if (null? l)
null null
(cons (not-caps-text (list->string (map char-upcase (car l))) (let* ([first-string (list->string (map char-upcase (car l)))]
[first
(not-caps-text first-string
(if up? style cap-style) (if up? style cap-style)
(if up? size cap-size) (if up? size cap-size)
0) 0)]
(loop (cdr l) (not up?)))))]) [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)))])) (apply hbl-append 0 picts)))]))
(define (linewidth n p) (line-thickness n p)) (define (linewidth n p) (line-thickness n p))